summaryrefslogtreecommitdiff
path: root/lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp')
-rw-r--r--lisp/.arch-inventory4
-rw-r--r--lisp/.gitignore2
-rw-r--r--lisp/ChangeLog14325
-rw-r--r--lisp/ChangeLog.172
-rw-r--r--lisp/ChangeLog.1030
-rw-r--r--lisp/ChangeLog.1139
-rw-r--r--lisp/ChangeLog.1274
-rw-r--r--lisp/ChangeLog.1328
-rw-r--r--lisp/ChangeLog.1441
-rw-r--r--lisp/ChangeLog.1522810
-rw-r--r--lisp/ChangeLog.28
-rw-r--r--lisp/ChangeLog.312
-rw-r--r--lisp/ChangeLog.44
-rw-r--r--lisp/ChangeLog.5133
-rw-r--r--lisp/ChangeLog.632
-rw-r--r--lisp/ChangeLog.78
-rw-r--r--lisp/ChangeLog.896
-rw-r--r--lisp/ChangeLog.9192
-rw-r--r--lisp/Makefile.in1470
-rw-r--r--lisp/abbrev.el133
-rw-r--r--lisp/align.el11
-rw-r--r--lisp/allout-widgets.el2380
-rw-r--r--lisp/allout.el2041
-rw-r--r--lisp/ansi-color.el85
-rw-r--r--lisp/apropos.el147
-rw-r--r--lisp/arc-mode.el149
-rw-r--r--lisp/array.el54
-rw-r--r--lisp/autoarg.el4
-rw-r--r--lisp/autoinsert.el11
-rw-r--r--lisp/autorevert.el25
-rw-r--r--lisp/avoid.el8
-rw-r--r--lisp/battery.el4
-rw-r--r--lisp/bindings.el156
-rw-r--r--lisp/bookmark.el468
-rw-r--r--lisp/bs.el56
-rw-r--r--lisp/buff-menu.el14
-rw-r--r--lisp/button.el4
-rw-r--r--lisp/calc/.arch-inventory4
-rw-r--r--lisp/calc/README23
-rw-r--r--lisp/calc/README.prev3
-rw-r--r--lisp/calc/calc-aent.el115
-rw-r--r--lisp/calc/calc-alg.el30
-rw-r--r--lisp/calc/calc-arith.el4
-rw-r--r--lisp/calc/calc-bin.el8
-rw-r--r--lisp/calc/calc-comb.el4
-rw-r--r--lisp/calc/calc-cplx.el4
-rw-r--r--lisp/calc/calc-embed.el4
-rw-r--r--lisp/calc/calc-ext.el111
-rw-r--r--lisp/calc/calc-fin.el4
-rw-r--r--lisp/calc/calc-forms.el4
-rw-r--r--lisp/calc/calc-frac.el38
-rw-r--r--lisp/calc/calc-funcs.el4
-rw-r--r--lisp/calc/calc-graph.el28
-rw-r--r--lisp/calc/calc-help.el21
-rw-r--r--lisp/calc/calc-incom.el10
-rw-r--r--lisp/calc/calc-keypd.el8
-rw-r--r--lisp/calc/calc-lang.el152
-rw-r--r--lisp/calc/calc-macs.el4
-rw-r--r--lisp/calc/calc-map.el30
-rw-r--r--lisp/calc/calc-math.el6
-rw-r--r--lisp/calc/calc-menu.el108
-rw-r--r--lisp/calc/calc-misc.el37
-rw-r--r--lisp/calc/calc-mode.el4
-rw-r--r--lisp/calc/calc-mtx.el20
-rw-r--r--lisp/calc/calc-nlfit.el3
-rw-r--r--lisp/calc/calc-poly.el6
-rw-r--r--lisp/calc/calc-prog.el37
-rw-r--r--lisp/calc/calc-rewr.el4
-rw-r--r--lisp/calc/calc-rules.el4
-rw-r--r--lisp/calc/calc-sel.el14
-rw-r--r--lisp/calc/calc-stat.el4
-rw-r--r--lisp/calc/calc-store.el14
-rw-r--r--lisp/calc/calc-stuff.el4
-rw-r--r--lisp/calc/calc-trail.el32
-rw-r--r--lisp/calc/calc-undo.el5
-rw-r--r--lisp/calc/calc-units.el580
-rw-r--r--lisp/calc/calc-vec.el88
-rw-r--r--lisp/calc/calc-yank.el11
-rw-r--r--lisp/calc/calc.el89
-rw-r--r--lisp/calc/calcalg2.el18
-rw-r--r--lisp/calc/calcalg3.el4
-rw-r--r--lisp/calc/calccomp.el84
-rw-r--r--lisp/calc/calcsel2.el4
-rw-r--r--lisp/calculator.el216
-rw-r--r--lisp/calendar/.arch-inventory4
-rw-r--r--lisp/calendar/appt.el375
-rw-r--r--lisp/calendar/cal-bahai.el5
-rw-r--r--lisp/calendar/cal-china.el8
-rw-r--r--lisp/calendar/cal-coptic.el5
-rw-r--r--lisp/calendar/cal-dst.el11
-rw-r--r--lisp/calendar/cal-french.el24
-rw-r--r--lisp/calendar/cal-hebrew.el244
-rw-r--r--lisp/calendar/cal-html.el7
-rw-r--r--lisp/calendar/cal-islam.el5
-rw-r--r--lisp/calendar/cal-iso.el5
-rw-r--r--lisp/calendar/cal-julian.el5
-rw-r--r--lisp/calendar/cal-mayan.el6
-rw-r--r--lisp/calendar/cal-menu.el5
-rw-r--r--lisp/calendar/cal-move.el17
-rw-r--r--lisp/calendar/cal-persia.el5
-rw-r--r--lisp/calendar/cal-tex.el42
-rw-r--r--lisp/calendar/cal-x.el5
-rw-r--r--lisp/calendar/calendar.el22
-rw-r--r--lisp/calendar/diary-lib.el528
-rw-r--r--lisp/calendar/holidays.el54
-rw-r--r--lisp/calendar/icalendar.el222
-rw-r--r--lisp/calendar/lunar.el6
-rw-r--r--lisp/calendar/parse-time.el4
-rw-r--r--lisp/calendar/solar.el34
-rw-r--r--lisp/calendar/time-date.el86
-rw-r--r--lisp/calendar/timeclock.el22
-rw-r--r--lisp/calendar/todo-mode.el18
-rw-r--r--lisp/case-table.el5
-rw-r--r--lisp/cdl.el4
-rw-r--r--lisp/cedet/ChangeLog250
-rw-r--r--lisp/cedet/cedet-cscope.el4
-rw-r--r--lisp/cedet/cedet-files.el4
-rw-r--r--lisp/cedet/cedet-global.el4
-rw-r--r--lisp/cedet/cedet-idutils.el4
-rw-r--r--lisp/cedet/cedet.el6
-rw-r--r--lisp/cedet/data-debug.el4
-rw-r--r--lisp/cedet/ede.el9
-rw-r--r--lisp/cedet/ede/auto.el2
-rw-r--r--lisp/cedet/ede/autoconf-edit.el7
-rw-r--r--lisp/cedet/ede/base.el2
-rw-r--r--lisp/cedet/ede/cpp-root.el3
-rw-r--r--lisp/cedet/ede/custom.el2
-rw-r--r--lisp/cedet/ede/dired.el102
-rw-r--r--lisp/cedet/ede/emacs.el3
-rw-r--r--lisp/cedet/ede/files.el3
-rw-r--r--lisp/cedet/ede/generic.el2
-rw-r--r--lisp/cedet/ede/linux.el3
-rw-r--r--lisp/cedet/ede/locate.el3
-rw-r--r--lisp/cedet/ede/make.el3
-rw-r--r--lisp/cedet/ede/makefile-edit.el3
-rw-r--r--lisp/cedet/ede/pconf.el4
-rw-r--r--lisp/cedet/ede/pmake.el11
-rw-r--r--lisp/cedet/ede/proj-archive.el3
-rw-r--r--lisp/cedet/ede/proj-aux.el3
-rw-r--r--lisp/cedet/ede/proj-comp.el3
-rw-r--r--lisp/cedet/ede/proj-elisp.el22
-rw-r--r--lisp/cedet/ede/proj-info.el4
-rw-r--r--lisp/cedet/ede/proj-misc.el4
-rw-r--r--lisp/cedet/ede/proj-obj.el4
-rw-r--r--lisp/cedet/ede/proj-prog.el4
-rw-r--r--lisp/cedet/ede/proj-scheme.el3
-rw-r--r--lisp/cedet/ede/proj-shared.el3
-rw-r--r--lisp/cedet/ede/proj.el4
-rw-r--r--lisp/cedet/ede/project-am.el5
-rw-r--r--lisp/cedet/ede/shell.el3
-rw-r--r--lisp/cedet/ede/simple.el3
-rw-r--r--lisp/cedet/ede/source.el3
-rw-r--r--lisp/cedet/ede/speedbar.el10
-rw-r--r--lisp/cedet/ede/srecode.el3
-rw-r--r--lisp/cedet/ede/system.el3
-rw-r--r--lisp/cedet/ede/util.el3
-rw-r--r--lisp/cedet/inversion.el4
-rw-r--r--lisp/cedet/mode-local.el3
-rw-r--r--lisp/cedet/pulse.el3
-rw-r--r--lisp/cedet/semantic.el4
-rw-r--r--lisp/cedet/semantic/analyze.el4
-rw-r--r--lisp/cedet/semantic/analyze/complete.el3
-rw-r--r--lisp/cedet/semantic/analyze/debug.el2
-rw-r--r--lisp/cedet/semantic/analyze/fcn.el3
-rw-r--r--lisp/cedet/semantic/analyze/refs.el3
-rw-r--r--lisp/cedet/semantic/bovine.el3
-rw-r--r--lisp/cedet/semantic/bovine/c-by.el4
-rw-r--r--lisp/cedet/semantic/bovine/c.el27
-rw-r--r--lisp/cedet/semantic/bovine/debug.el3
-rw-r--r--lisp/cedet/semantic/bovine/el.el4
-rw-r--r--lisp/cedet/semantic/bovine/gcc.el3
-rw-r--r--lisp/cedet/semantic/bovine/make-by.el4
-rw-r--r--lisp/cedet/semantic/bovine/make.el4
-rw-r--r--lisp/cedet/semantic/bovine/scm-by.el3
-rw-r--r--lisp/cedet/semantic/bovine/scm.el4
-rw-r--r--lisp/cedet/semantic/chart.el3
-rw-r--r--lisp/cedet/semantic/complete.el6
-rw-r--r--lisp/cedet/semantic/ctxt.el4
-rw-r--r--lisp/cedet/semantic/db-debug.el3
-rw-r--r--lisp/cedet/semantic/db-ebrowse.el4
-rw-r--r--lisp/cedet/semantic/db-el.el4
-rw-r--r--lisp/cedet/semantic/db-file.el4
-rw-r--r--lisp/cedet/semantic/db-find.el4
-rw-r--r--lisp/cedet/semantic/db-global.el4
-rw-r--r--lisp/cedet/semantic/db-javascript.el4
-rw-r--r--lisp/cedet/semantic/db-mode.el3
-rw-r--r--lisp/cedet/semantic/db-ref.el3
-rw-r--r--lisp/cedet/semantic/db-typecache.el3
-rw-r--r--lisp/cedet/semantic/db.el4
-rw-r--r--lisp/cedet/semantic/debug.el3
-rw-r--r--lisp/cedet/semantic/decorate.el3
-rw-r--r--lisp/cedet/semantic/decorate/include.el3
-rw-r--r--lisp/cedet/semantic/decorate/mode.el90
-rw-r--r--lisp/cedet/semantic/dep.el3
-rw-r--r--lisp/cedet/semantic/doc.el4
-rw-r--r--lisp/cedet/semantic/ede-grammar.el10
-rw-r--r--lisp/cedet/semantic/edit.el4
-rw-r--r--lisp/cedet/semantic/find.el4
-rw-r--r--lisp/cedet/semantic/format.el4
-rw-r--r--lisp/cedet/semantic/fw.el4
-rw-r--r--lisp/cedet/semantic/grammar-wy.el3
-rw-r--r--lisp/cedet/semantic/grammar.el9
-rw-r--r--lisp/cedet/semantic/html.el3
-rw-r--r--lisp/cedet/semantic/ia-sb.el4
-rw-r--r--lisp/cedet/semantic/ia.el4
-rw-r--r--lisp/cedet/semantic/idle.el165
-rw-r--r--lisp/cedet/semantic/imenu.el2
-rw-r--r--lisp/cedet/semantic/java.el4
-rw-r--r--lisp/cedet/semantic/lex-spp.el3
-rw-r--r--lisp/cedet/semantic/lex.el18
-rw-r--r--lisp/cedet/semantic/mru-bookmark.el74
-rw-r--r--lisp/cedet/semantic/sb.el4
-rw-r--r--lisp/cedet/semantic/scope.el3
-rw-r--r--lisp/cedet/semantic/senator.el4
-rw-r--r--lisp/cedet/semantic/sort.el4
-rw-r--r--lisp/cedet/semantic/symref.el5
-rw-r--r--lisp/cedet/semantic/symref/cscope.el5
-rw-r--r--lisp/cedet/semantic/symref/filter.el3
-rw-r--r--lisp/cedet/semantic/symref/global.el3
-rw-r--r--lisp/cedet/semantic/symref/grep.el3
-rw-r--r--lisp/cedet/semantic/symref/idutils.el3
-rw-r--r--lisp/cedet/semantic/symref/list.el5
-rw-r--r--lisp/cedet/semantic/tag-file.el6
-rw-r--r--lisp/cedet/semantic/tag-ls.el4
-rw-r--r--lisp/cedet/semantic/tag-write.el3
-rw-r--r--lisp/cedet/semantic/tag.el4
-rw-r--r--lisp/cedet/semantic/texi.el4
-rw-r--r--lisp/cedet/semantic/util-modes.el607
-rw-r--r--lisp/cedet/semantic/util.el4
-rw-r--r--lisp/cedet/semantic/wisent.el4
-rw-r--r--lisp/cedet/semantic/wisent/comp.el34
-rw-r--r--lisp/cedet/semantic/wisent/java-tags.el4
-rw-r--r--lisp/cedet/semantic/wisent/javascript.el5
-rw-r--r--lisp/cedet/semantic/wisent/javat-wy.el3
-rw-r--r--lisp/cedet/semantic/wisent/js-wy.el3
-rw-r--r--lisp/cedet/semantic/wisent/python-wy.el3
-rw-r--r--lisp/cedet/semantic/wisent/python.el3
-rw-r--r--lisp/cedet/semantic/wisent/wisent.el4
-rw-r--r--lisp/cedet/srecode.el4
-rw-r--r--lisp/cedet/srecode/args.el3
-rw-r--r--lisp/cedet/srecode/compile.el3
-rw-r--r--lisp/cedet/srecode/cpp.el3
-rw-r--r--lisp/cedet/srecode/ctxt.el3
-rw-r--r--lisp/cedet/srecode/dictionary.el3
-rw-r--r--lisp/cedet/srecode/document.el3
-rw-r--r--lisp/cedet/srecode/el.el3
-rw-r--r--lisp/cedet/srecode/expandproto.el3
-rw-r--r--lisp/cedet/srecode/extract.el3
-rw-r--r--lisp/cedet/srecode/fields.el3
-rw-r--r--lisp/cedet/srecode/filters.el3
-rw-r--r--lisp/cedet/srecode/find.el3
-rw-r--r--lisp/cedet/srecode/getset.el3
-rw-r--r--lisp/cedet/srecode/insert.el3
-rw-r--r--lisp/cedet/srecode/java.el3
-rw-r--r--lisp/cedet/srecode/map.el3
-rw-r--r--lisp/cedet/srecode/mode.el52
-rw-r--r--lisp/cedet/srecode/semantic.el3
-rw-r--r--lisp/cedet/srecode/srt-mode.el16
-rw-r--r--lisp/cedet/srecode/srt-wy.el3
-rw-r--r--lisp/cedet/srecode/srt.el3
-rw-r--r--lisp/cedet/srecode/table.el3
-rw-r--r--lisp/cedet/srecode/template.el3
-rw-r--r--lisp/cedet/srecode/texi.el3
-rw-r--r--lisp/chistory.el4
-rw-r--r--lisp/cmuscheme.el6
-rw-r--r--lisp/color.el315
-rw-r--r--lisp/comint.el443
-rw-r--r--lisp/completion.el17
-rw-r--r--lisp/composite.el114
-rw-r--r--lisp/cus-dep.el5
-rw-r--r--lisp/cus-edit.el1382
-rw-r--r--lisp/cus-face.el108
-rw-r--r--lisp/cus-start.el167
-rw-r--r--lisp/cus-theme.el832
-rw-r--r--lisp/custom.el599
-rw-r--r--lisp/dabbrev.el7
-rw-r--r--lisp/delim-col.el18
-rw-r--r--lisp/delsel.el4
-rw-r--r--lisp/descr-text.el41
-rw-r--r--lisp/desktop.el228
-rw-r--r--lisp/dframe.el35
-rw-r--r--lisp/dired-aux.el393
-rw-r--r--lisp/dired-x.el1173
-rw-r--r--lisp/dired.el394
-rw-r--r--lisp/dirtrack.el19
-rw-r--r--lisp/disp-table.el6
-rw-r--r--lisp/dnd.el39
-rw-r--r--lisp/doc-view.el317
-rw-r--r--lisp/dos-fns.el72
-rw-r--r--lisp/dos-vars.el5
-rw-r--r--lisp/dos-w32.el15
-rw-r--r--lisp/double.el4
-rw-r--r--lisp/dynamic-setting.el (renamed from lisp/font-setting.el)42
-rw-r--r--lisp/ebuff-menu.el10
-rw-r--r--lisp/echistory.el9
-rw-r--r--lisp/edmacro.el32
-rw-r--r--lisp/ehelp.el30
-rw-r--r--lisp/electric.el241
-rw-r--r--lisp/elide-head.el4
-rw-r--r--lisp/emacs-lisp/.gitignore1
-rw-r--r--lisp/emacs-lisp/advice.el158
-rw-r--r--lisp/emacs-lisp/assoc.el14
-rw-r--r--lisp/emacs-lisp/authors.el107
-rw-r--r--lisp/emacs-lisp/autoload.el313
-rw-r--r--lisp/emacs-lisp/avl-tree.el3
-rw-r--r--lisp/emacs-lisp/backquote.el5
-rw-r--r--lisp/emacs-lisp/benchmark.el4
-rw-r--r--lisp/emacs-lisp/bindat.el3
-rw-r--r--lisp/emacs-lisp/byte-opt.el492
-rw-r--r--lisp/emacs-lisp/byte-run.el16
-rw-r--r--lisp/emacs-lisp/bytecomp.el2255
-rw-r--r--lisp/emacs-lisp/cconv.el715
-rw-r--r--lisp/emacs-lisp/chart.el84
-rw-r--r--lisp/emacs-lisp/check-declare.el13
-rw-r--r--lisp/emacs-lisp/checkdoc.el344
-rw-r--r--lisp/emacs-lisp/cl-extra.el30
-rw-r--r--lisp/emacs-lisp/cl-indent.el5
-rw-r--r--lisp/emacs-lisp/cl-loaddefs.el31
-rw-r--r--lisp/emacs-lisp/cl-macs.el374
-rw-r--r--lisp/emacs-lisp/cl-seq.el17
-rw-r--r--lisp/emacs-lisp/cl-specs.el7
-rw-r--r--lisp/emacs-lisp/cl.el20
-rw-r--r--lisp/emacs-lisp/copyright.el316
-rw-r--r--lisp/emacs-lisp/crm.el4
-rw-r--r--lisp/emacs-lisp/cust-print.el4
-rw-r--r--lisp/emacs-lisp/debug.el6
-rw-r--r--lisp/emacs-lisp/derived.el9
-rw-r--r--lisp/emacs-lisp/disass.el17
-rw-r--r--lisp/emacs-lisp/easy-mmode.el87
-rw-r--r--lisp/emacs-lisp/easymenu.el90
-rw-r--r--lisp/emacs-lisp/edebug.el88
-rw-r--r--lisp/emacs-lisp/eieio-base.el4
-rw-r--r--lisp/emacs-lisp/eieio-comp.el142
-rw-r--r--lisp/emacs-lisp/eieio-custom.el10
-rw-r--r--lisp/emacs-lisp/eieio-datadebug.el4
-rw-r--r--lisp/emacs-lisp/eieio-opt.el17
-rw-r--r--lisp/emacs-lisp/eieio-speedbar.el5
-rw-r--r--lisp/emacs-lisp/eieio.el261
-rw-r--r--lisp/emacs-lisp/eldoc.el18
-rw-r--r--lisp/emacs-lisp/elint.el50
-rw-r--r--lisp/emacs-lisp/elp.el7
-rw-r--r--lisp/emacs-lisp/ert-x.el290
-rw-r--r--lisp/emacs-lisp/ert.el2548
-rw-r--r--lisp/emacs-lisp/ewoc.el6
-rw-r--r--lisp/emacs-lisp/find-func.el16
-rw-r--r--lisp/emacs-lisp/find-gc.el8
-rw-r--r--lisp/emacs-lisp/float-sup.el31
-rw-r--r--lisp/emacs-lisp/generic.el5
-rw-r--r--lisp/emacs-lisp/gulp.el4
-rw-r--r--lisp/emacs-lisp/helper.el5
-rw-r--r--lisp/emacs-lisp/lisp-mnt.el12
-rw-r--r--lisp/emacs-lisp/lisp-mode.el84
-rw-r--r--lisp/emacs-lisp/lisp.el97
-rw-r--r--lisp/emacs-lisp/macroexp.el179
-rw-r--r--lisp/emacs-lisp/map-ynp.el4
-rw-r--r--lisp/emacs-lisp/package-x.el309
-rw-r--r--lisp/emacs-lisp/package.el1621
-rw-r--r--lisp/emacs-lisp/pcase.el692
-rw-r--r--lisp/emacs-lisp/pp.el4
-rw-r--r--lisp/emacs-lisp/re-builder.el56
-rw-r--r--lisp/emacs-lisp/regexp-opt.el17
-rw-r--r--lisp/emacs-lisp/regi.el4
-rw-r--r--lisp/emacs-lisp/ring.el4
-rw-r--r--lisp/emacs-lisp/rx.el67
-rw-r--r--lisp/emacs-lisp/shadow.el53
-rw-r--r--lisp/emacs-lisp/smie.el22
-rw-r--r--lisp/emacs-lisp/syntax.el286
-rw-r--r--lisp/emacs-lisp/tabulated-list.el366
-rw-r--r--lisp/emacs-lisp/tcover-ses.el5
-rw-r--r--lisp/emacs-lisp/tcover-unsafep.el4
-rw-r--r--lisp/emacs-lisp/testcover.el3
-rw-r--r--lisp/emacs-lisp/timer.el53
-rw-r--r--lisp/emacs-lisp/tq.el4
-rw-r--r--lisp/emacs-lisp/trace.el4
-rw-r--r--lisp/emacs-lisp/unsafep.el6
-rw-r--r--lisp/emacs-lisp/warnings.el136
-rw-r--r--lisp/emacs-lock.el9
-rw-r--r--lisp/emulation/crisp.el8
-rw-r--r--lisp/emulation/cua-base.el84
-rw-r--r--lisp/emulation/cua-gmrk.el9
-rw-r--r--lisp/emulation/cua-rect.el17
-rw-r--r--lisp/emulation/edt-lk201.el6
-rw-r--r--lisp/emulation/edt-mapper.el5
-rw-r--r--lisp/emulation/edt-pc.el5
-rw-r--r--lisp/emulation/edt-vt100.el6
-rw-r--r--lisp/emulation/edt.el350
-rw-r--r--lisp/emulation/keypad.el4
-rw-r--r--lisp/emulation/pc-select.el985
-rw-r--r--lisp/emulation/tpu-edt.el6
-rw-r--r--lisp/emulation/tpu-extras.el134
-rw-r--r--lisp/emulation/tpu-mapper.el5
-rw-r--r--lisp/emulation/vi.el1
-rw-r--r--lisp/emulation/vip.el274
-rw-r--r--lisp/emulation/viper-cmd.el67
-rw-r--r--lisp/emulation/viper-ex.el7
-rw-r--r--lisp/emulation/viper-init.el14
-rw-r--r--lisp/emulation/viper-keym.el5
-rw-r--r--lisp/emulation/viper-macs.el5
-rw-r--r--lisp/emulation/viper-mous.el5
-rw-r--r--lisp/emulation/viper-util.el7
-rw-r--r--lisp/emulation/viper.el5
-rw-r--r--lisp/emulation/ws-mode.el314
-rw-r--r--lisp/env.el5
-rw-r--r--lisp/epa-dired.el6
-rw-r--r--lisp/epa-file.el69
-rw-r--r--lisp/epa-hook.el6
-rw-r--r--lisp/epa-mail.el36
-rw-r--r--lisp/epa.el35
-rw-r--r--lisp/epg-config.el10
-rw-r--r--lisp/epg.el66
-rw-r--r--lisp/erc/ChangeLog94
-rw-r--r--lisp/erc/ChangeLog.013
-rw-r--r--lisp/erc/ChangeLog.023
-rw-r--r--lisp/erc/ChangeLog.037
-rw-r--r--lisp/erc/ChangeLog.045
-rw-r--r--lisp/erc/ChangeLog.053
-rw-r--r--lisp/erc/ChangeLog.065
-rw-r--r--lisp/erc/ChangeLog.073
-rw-r--r--lisp/erc/ChangeLog.083
-rw-r--r--lisp/erc/erc-autoaway.el4
-rw-r--r--lisp/erc/erc-backend.el30
-rw-r--r--lisp/erc/erc-button.el39
-rw-r--r--lisp/erc/erc-capab.el3
-rw-r--r--lisp/erc/erc-compat.el4
-rw-r--r--lisp/erc/erc-dcc.el16
-rw-r--r--lisp/erc/erc-ezbounce.el3
-rw-r--r--lisp/erc/erc-fill.el4
-rw-r--r--lisp/erc/erc-goodies.el4
-rw-r--r--lisp/erc/erc-ibuffer.el4
-rw-r--r--lisp/erc/erc-identd.el3
-rw-r--r--lisp/erc/erc-imenu.el3
-rw-r--r--lisp/erc/erc-join.el79
-rw-r--r--lisp/erc/erc-lang.el7
-rw-r--r--lisp/erc/erc-list.el33
-rw-r--r--lisp/erc/erc-log.el3
-rw-r--r--lisp/erc/erc-match.el4
-rw-r--r--lisp/erc/erc-menu.el4
-rw-r--r--lisp/erc/erc-netsplit.el3
-rw-r--r--lisp/erc/erc-networks.el3
-rw-r--r--lisp/erc/erc-notify.el3
-rw-r--r--lisp/erc/erc-page.el3
-rw-r--r--lisp/erc/erc-pcomplete.el17
-rw-r--r--lisp/erc/erc-replace.el4
-rw-r--r--lisp/erc/erc-ring.el4
-rw-r--r--lisp/erc/erc-services.el3
-rw-r--r--lisp/erc/erc-sound.el3
-rw-r--r--lisp/erc/erc-speedbar.el4
-rw-r--r--lisp/erc/erc-spelling.el3
-rw-r--r--lisp/erc/erc-stamp.el4
-rw-r--r--lisp/erc/erc-track.el23
-rw-r--r--lisp/erc/erc-truncate.el3
-rw-r--r--lisp/erc/erc-xdcc.el3
-rw-r--r--lisp/erc/erc.el42
-rw-r--r--lisp/eshell/.arch-inventory4
-rw-r--r--lisp/eshell/.gitignore1
-rw-r--r--lisp/eshell/em-alias.el17
-rw-r--r--lisp/eshell/em-banner.el19
-rw-r--r--lisp/eshell/em-basic.el6
-rw-r--r--lisp/eshell/em-cmpl.el17
-rw-r--r--lisp/eshell/em-dirs.el37
-rw-r--r--lisp/eshell/em-glob.el36
-rw-r--r--lisp/eshell/em-hist.el37
-rw-r--r--lisp/eshell/em-ls.el73
-rw-r--r--lisp/eshell/em-pred.el19
-rw-r--r--lisp/eshell/em-prompt.el19
-rw-r--r--lisp/eshell/em-rebind.el20
-rw-r--r--lisp/eshell/em-script.el47
-rw-r--r--lisp/eshell/em-smart.el19
-rw-r--r--lisp/eshell/em-term.el18
-rw-r--r--lisp/eshell/em-unix.el173
-rw-r--r--lisp/eshell/em-xtra.el4
-rw-r--r--lisp/eshell/esh-arg.el44
-rw-r--r--lisp/eshell/esh-cmd.el91
-rw-r--r--lisp/eshell/esh-ext.el27
-rw-r--r--lisp/eshell/esh-io.el21
-rw-r--r--lisp/eshell/esh-mode.el157
-rw-r--r--lisp/eshell/esh-module.el10
-rw-r--r--lisp/eshell/esh-opt.el68
-rw-r--r--lisp/eshell/esh-proc.el60
-rw-r--r--lisp/eshell/esh-test.el236
-rw-r--r--lisp/eshell/esh-util.el105
-rw-r--r--lisp/eshell/esh-var.el51
-rw-r--r--lisp/eshell/eshell.el29
-rw-r--r--lisp/expand.el7
-rw-r--r--lisp/ezimage.el6
-rw-r--r--lisp/face-remap.el5
-rw-r--r--lisp/facemenu.el339
-rw-r--r--lisp/faces.el522
-rw-r--r--lisp/ffap.el4
-rw-r--r--lisp/filecache.el10
-rw-r--r--lisp/files-x.el38
-rw-r--r--lisp/files.el1034
-rw-r--r--lisp/filesets.el6
-rw-r--r--lisp/find-cmd.el3
-rw-r--r--lisp/find-dired.el81
-rw-r--r--lisp/find-file.el8
-rw-r--r--lisp/find-lisp.el19
-rw-r--r--lisp/finder.el286
-rw-r--r--lisp/flow-ctrl.el4
-rw-r--r--lisp/foldout.el6
-rw-r--r--lisp/follow.el11
-rw-r--r--lisp/font-core.el22
-rw-r--r--lisp/font-lock.el203
-rw-r--r--lisp/format-spec.el4
-rw-r--r--lisp/format.el51
-rw-r--r--lisp/forms-d2.el4
-rw-r--r--lisp/forms-pass.el1
-rw-r--r--lisp/forms.el14
-rw-r--r--lisp/frame.el254
-rw-r--r--lisp/fringe.el76
-rw-r--r--lisp/generic-x.el21
-rw-r--r--lisp/gnus/.dir-locals.el4
-rw-r--r--lisp/gnus/ChangeLog8041
-rw-r--r--lisp/gnus/ChangeLog.125
-rw-r--r--lisp/gnus/ChangeLog.249
-rw-r--r--lisp/gnus/auth-source.el1476
-rw-r--r--lisp/gnus/canlock.el4
-rw-r--r--lisp/gnus/compface.el3
-rw-r--r--lisp/gnus/deuglify.el4
-rw-r--r--lisp/gnus/earcon.el233
-rw-r--r--lisp/gnus/ecomplete.el17
-rw-r--r--lisp/gnus/flow-fill.el52
-rw-r--r--lisp/gnus/gmm-utils.el45
-rw-r--r--lisp/gnus/gnus-agent.el183
-rw-r--r--lisp/gnus/gnus-art.el1503
-rw-r--r--lisp/gnus/gnus-async.el41
-rw-r--r--lisp/gnus/gnus-audio.el150
-rw-r--r--lisp/gnus/gnus-bcklg.el22
-rw-r--r--lisp/gnus/gnus-bookmark.el19
-rw-r--r--lisp/gnus/gnus-cache.el36
-rw-r--r--lisp/gnus/gnus-cite.el196
-rw-r--r--lisp/gnus/gnus-cus.el11
-rw-r--r--lisp/gnus/gnus-delay.el11
-rw-r--r--lisp/gnus/gnus-demon.el237
-rw-r--r--lisp/gnus/gnus-diary.el12
-rw-r--r--lisp/gnus/gnus-dired.el60
-rw-r--r--lisp/gnus/gnus-draft.el157
-rw-r--r--lisp/gnus/gnus-dup.el4
-rw-r--r--lisp/gnus/gnus-eform.el4
-rw-r--r--lisp/gnus/gnus-ems.el150
-rw-r--r--lisp/gnus/gnus-fun.el5
-rw-r--r--lisp/gnus/gnus-gravatar.el144
-rw-r--r--lisp/gnus/gnus-group.el838
-rw-r--r--lisp/gnus/gnus-html.el528
-rw-r--r--lisp/gnus/gnus-int.el235
-rw-r--r--lisp/gnus/gnus-kill.el18
-rw-r--r--lisp/gnus/gnus-logic.el7
-rw-r--r--lisp/gnus/gnus-mh.el4
-rw-r--r--lisp/gnus/gnus-ml.el60
-rw-r--r--lisp/gnus/gnus-mlspl.el4
-rw-r--r--lisp/gnus/gnus-move.el181
-rw-r--r--lisp/gnus/gnus-msg.el139
-rw-r--r--lisp/gnus/gnus-nocem.el453
-rw-r--r--lisp/gnus/gnus-picon.el31
-rw-r--r--lisp/gnus/gnus-range.el34
-rw-r--r--lisp/gnus/gnus-registry.el1670
-rw-r--r--lisp/gnus/gnus-salt.el301
-rw-r--r--lisp/gnus/gnus-score.el80
-rw-r--r--lisp/gnus/gnus-setup.el4
-rw-r--r--lisp/gnus/gnus-sieve.el3
-rw-r--r--lisp/gnus/gnus-soup.el611
-rw-r--r--lisp/gnus/gnus-spec.el8
-rw-r--r--lisp/gnus/gnus-srvr.el103
-rw-r--r--lisp/gnus/gnus-start.el690
-rw-r--r--lisp/gnus/gnus-sum.el1222
-rw-r--r--lisp/gnus/gnus-sync.el242
-rw-r--r--lisp/gnus/gnus-topic.el40
-rw-r--r--lisp/gnus/gnus-undo.el42
-rw-r--r--lisp/gnus/gnus-util.el488
-rw-r--r--lisp/gnus/gnus-uu.el104
-rw-r--r--lisp/gnus/gnus-vm.el4
-rw-r--r--lisp/gnus/gnus-win.el189
-rw-r--r--lisp/gnus/gnus.el636
-rw-r--r--lisp/gnus/gravatar.el159
-rw-r--r--lisp/gnus/gssapi.el105
-rw-r--r--lisp/gnus/html2text.el4
-rw-r--r--lisp/gnus/ietf-drums.el5
-rw-r--r--lisp/gnus/legacy-gnus-agent.el3
-rw-r--r--lisp/gnus/mail-parse.el7
-rw-r--r--lisp/gnus/mail-prsvr.el4
-rw-r--r--lisp/gnus/mail-source.el193
-rw-r--r--lisp/gnus/mailcap.el20
-rw-r--r--lisp/gnus/message.el754
-rw-r--r--lisp/gnus/messcompat.el4
-rw-r--r--lisp/gnus/mm-bodies.el6
-rw-r--r--lisp/gnus/mm-decode.el227
-rw-r--r--lisp/gnus/mm-encode.el17
-rw-r--r--lisp/gnus/mm-extern.el16
-rw-r--r--lisp/gnus/mm-partial.el10
-rw-r--r--lisp/gnus/mm-url.el97
-rw-r--r--lisp/gnus/mm-util.el271
-rw-r--r--lisp/gnus/mm-uu.el36
-rw-r--r--lisp/gnus/mm-view.el124
-rw-r--r--lisp/gnus/mml-sec.el22
-rw-r--r--lisp/gnus/mml-smime.el47
-rw-r--r--lisp/gnus/mml.el117
-rw-r--r--lisp/gnus/mml1991.el114
-rw-r--r--lisp/gnus/mml2015.el476
-rw-r--r--lisp/gnus/nnagent.el15
-rw-r--r--lisp/gnus/nnbabyl.el55
-rw-r--r--lisp/gnus/nndb.el325
-rw-r--r--lisp/gnus/nndiary.el57
-rw-r--r--lisp/gnus/nndir.el4
-rw-r--r--lisp/gnus/nndoc.el143
-rw-r--r--lisp/gnus/nndraft.el27
-rw-r--r--lisp/gnus/nneething.el19
-rw-r--r--lisp/gnus/nnfolder.el98
-rw-r--r--lisp/gnus/nngateway.el4
-rw-r--r--lisp/gnus/nnheader.el79
-rw-r--r--lisp/gnus/nnimap.el3585
-rw-r--r--lisp/gnus/nnir.el1375
-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.el29
-rw-r--r--lisp/gnus/nnmairix.el189
-rw-r--r--lisp/gnus/nnmbox.el34
-rw-r--r--lisp/gnus/nnmh.el87
-rw-r--r--lisp/gnus/nnml.el195
-rw-r--r--lisp/gnus/nnnil.el7
-rw-r--r--lisp/gnus/nnoo.el4
-rw-r--r--lisp/gnus/nnregistry.el66
-rw-r--r--lisp/gnus/nnrss.el170
-rw-r--r--lisp/gnus/nnslashdot.el505
-rw-r--r--lisp/gnus/nnsoup.el812
-rw-r--r--lisp/gnus/nnspool.el36
-rw-r--r--lisp/gnus/nntp.el316
-rw-r--r--lisp/gnus/nnultimate.el480
-rw-r--r--lisp/gnus/nnvirtual.el40
-rw-r--r--lisp/gnus/nnwarchive.el727
-rw-r--r--lisp/gnus/nnweb.el34
-rw-r--r--lisp/gnus/nnwfm.el432
-rw-r--r--lisp/gnus/pop3.el284
-rw-r--r--lisp/gnus/qp.el4
-rw-r--r--lisp/gnus/registry.el476
-rw-r--r--lisp/gnus/rfc1843.el7
-rw-r--r--lisp/gnus/rfc2045.el4
-rw-r--r--lisp/gnus/rfc2047.el44
-rw-r--r--lisp/gnus/rfc2104.el4
-rw-r--r--lisp/gnus/rfc2231.el22
-rw-r--r--lisp/gnus/rtree.el278
-rw-r--r--lisp/gnus/score-mode.el4
-rw-r--r--lisp/gnus/shr-color.el361
-rw-r--r--lisp/gnus/shr.el1337
-rw-r--r--lisp/gnus/sieve-manage.el275
-rw-r--r--lisp/gnus/sieve-mode.el6
-rw-r--r--lisp/gnus/sieve.el118
-rw-r--r--lisp/gnus/smiley.el8
-rw-r--r--lisp/gnus/smime.el74
-rw-r--r--lisp/gnus/spam-report.el17
-rw-r--r--lisp/gnus/spam-stat.el5
-rw-r--r--lisp/gnus/spam-wash.el3
-rw-r--r--lisp/gnus/spam.el2123
-rw-r--r--lisp/gnus/starttls.el8
-rw-r--r--lisp/gnus/utf7.el11
-rw-r--r--lisp/gnus/webmail.el1152
-rw-r--r--lisp/gnus/yenc.el8
-rw-r--r--lisp/gs.el4
-rw-r--r--lisp/help-at-pt.el3
-rw-r--r--lisp/help-fns.el237
-rw-r--r--lisp/help-macro.el5
-rw-r--r--lisp/help-mode.el92
-rw-r--r--lisp/help.el37
-rw-r--r--lisp/hex-util.el4
-rw-r--r--lisp/hexl.el454
-rw-r--r--lisp/hfy-cmap.el14
-rw-r--r--lisp/hi-lock.el79
-rw-r--r--lisp/hilit-chg.el41
-rw-r--r--lisp/hippie-exp.el7
-rw-r--r--lisp/hl-line.el6
-rw-r--r--lisp/htmlfontify.el412
-rw-r--r--lisp/ibuf-ext.el58
-rw-r--r--lisp/ibuf-macs.el5
-rw-r--r--lisp/ibuffer.el466
-rw-r--r--lisp/icomplete.el15
-rw-r--r--lisp/ido.el190
-rw-r--r--lisp/ielm.el27
-rw-r--r--lisp/iimage.el117
-rw-r--r--lisp/image-dired.el86
-rw-r--r--lisp/image-file.el4
-rw-r--r--lisp/image-mode.el156
-rw-r--r--lisp/image.el150
-rw-r--r--lisp/imenu.el6
-rw-r--r--lisp/indent.el18
-rw-r--r--lisp/info-look.el4
-rw-r--r--lisp/info-xref.el635
-rw-r--r--lisp/info.el481
-rw-r--r--lisp/informat.el8
-rw-r--r--lisp/international/ccl.el4
-rw-r--r--lisp/international/characters.el168
-rw-r--r--lisp/international/charprop.el2
-rw-r--r--lisp/international/cp51932.el1
-rw-r--r--lisp/international/eucjp-ms.el1
-rw-r--r--lisp/international/fontset.el6
-rw-r--r--lisp/international/isearch-x.el4
-rw-r--r--lisp/international/iso-ascii.el19
-rw-r--r--lisp/international/iso-cvt.el4
-rw-r--r--lisp/international/iso-transl.el4
-rw-r--r--lisp/international/ja-dic-cnv.el3
-rw-r--r--lisp/international/ja-dic-utl.el1
-rw-r--r--lisp/international/kinsoku.el4
-rw-r--r--lisp/international/kkc.el6
-rw-r--r--lisp/international/latexenc.el3
-rw-r--r--lisp/international/latin1-disp.el4
-rw-r--r--lisp/international/mule-cmds.el33
-rw-r--r--lisp/international/mule-conf.el4
-rw-r--r--lisp/international/mule-diag.el9
-rw-r--r--lisp/international/mule-util.el6
-rw-r--r--lisp/international/mule.el117
-rw-r--r--lisp/international/ogonek.el14
-rw-r--r--lisp/international/quail.el8
-rw-r--r--lisp/international/robin.el1
-rw-r--r--lisp/international/titdic-cnv.el11
-rw-r--r--lisp/international/ucs-normalize.el4
-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.el6
-rw-r--r--lisp/isearch.el99
-rw-r--r--lisp/isearchb.el4
-rw-r--r--lisp/iswitchb.el34
-rw-r--r--lisp/jit-lock.el31
-rw-r--r--lisp/jka-cmpr-hook.el43
-rw-r--r--lisp/jka-compr.el20
-rw-r--r--lisp/json.el3
-rw-r--r--lisp/kermit.el6
-rw-r--r--lisp/kmacro.el73
-rw-r--r--lisp/language/burmese.el1
-rw-r--r--lisp/language/cham.el1
-rw-r--r--lisp/language/china-util.el4
-rw-r--r--lisp/language/chinese.el4
-rw-r--r--lisp/language/cyril-util.el4
-rw-r--r--lisp/language/cyrillic.el4
-rw-r--r--lisp/language/czech.el4
-rw-r--r--lisp/language/english.el4
-rw-r--r--lisp/language/ethio-util.el6
-rw-r--r--lisp/language/ethiopic.el4
-rw-r--r--lisp/language/european.el4
-rw-r--r--lisp/language/georgian.el4
-rw-r--r--lisp/language/greek.el1
-rw-r--r--lisp/language/hanja-util.el3
-rw-r--r--lisp/language/hebrew.el192
-rw-r--r--lisp/language/ind-util.el4
-rw-r--r--lisp/language/indian.el4
-rw-r--r--lisp/language/japan-util.el4
-rw-r--r--lisp/language/japanese.el4
-rw-r--r--lisp/language/khmer.el1
-rw-r--r--lisp/language/korea-util.el4
-rw-r--r--lisp/language/korean.el4
-rw-r--r--lisp/language/lao-util.el4
-rw-r--r--lisp/language/lao.el4
-rw-r--r--lisp/language/misc-lang.el19
-rw-r--r--lisp/language/romanian.el4
-rw-r--r--lisp/language/sinhala.el1
-rw-r--r--lisp/language/slovak.el4
-rw-r--r--lisp/language/tai-viet.el14
-rw-r--r--lisp/language/thai-util.el4
-rw-r--r--lisp/language/thai-word.el1
-rw-r--r--lisp/language/thai.el4
-rw-r--r--lisp/language/tibet-util.el4
-rw-r--r--lisp/language/tibetan.el4
-rw-r--r--lisp/language/tv-util.el4
-rw-r--r--lisp/language/utf-8-lang.el4
-rw-r--r--lisp/language/viet-util.el4
-rw-r--r--lisp/language/vietnamese.el4
-rw-r--r--lisp/ldefs-boot.el4953
-rw-r--r--lisp/ledit.el4
-rw-r--r--lisp/linum.el10
-rw-r--r--lisp/loadhist.el4
-rw-r--r--lisp/loadup.el78
-rw-r--r--lisp/locate.el9
-rw-r--r--lisp/longlines.el7
-rw-r--r--lisp/lpr.el48
-rw-r--r--lisp/ls-lisp.el102
-rw-r--r--lisp/macros.el8
-rw-r--r--lisp/mail/binhex.el7
-rw-r--r--lisp/mail/blessmail.el5
-rw-r--r--lisp/mail/emacsbug.el240
-rw-r--r--lisp/mail/feedmail.el101
-rw-r--r--lisp/mail/footnote.el36
-rw-r--r--lisp/mail/hashcash.el19
-rw-r--r--lisp/mail/mail-extr.el53
-rw-r--r--lisp/mail/mail-hist.el5
-rw-r--r--lisp/mail/mail-utils.el147
-rw-r--r--lisp/mail/mailabbrev.el4
-rw-r--r--lisp/mail/mailalias.el173
-rw-r--r--lisp/mail/mailclient.el11
-rw-r--r--lisp/mail/mailheader.el11
-rw-r--r--lisp/mail/mailpost.el1
-rw-r--r--lisp/mail/metamail.el5
-rw-r--r--lisp/mail/mspools.el42
-rw-r--r--lisp/mail/reporter.el4
-rw-r--r--lisp/mail/rfc2368.el11
-rw-r--r--lisp/mail/rfc822.el4
-rw-r--r--lisp/mail/rmail-spam-filter.el5
-rw-r--r--lisp/mail/rmail.el148
-rw-r--r--lisp/mail/rmailedit.el5
-rw-r--r--lisp/mail/rmailkwd.el5
-rw-r--r--lisp/mail/rmailmm.el18
-rw-r--r--lisp/mail/rmailmsc.el5
-rw-r--r--lisp/mail/rmailout.el6
-rw-r--r--lisp/mail/rmailsort.el12
-rw-r--r--lisp/mail/rmailsum.el399
-rw-r--r--lisp/mail/sendmail.el279
-rw-r--r--lisp/mail/smtpmail.el17
-rw-r--r--lisp/mail/supercite.el40
-rw-r--r--lisp/mail/uce.el4
-rw-r--r--lisp/mail/undigest.el5
-rw-r--r--lisp/mail/unrmail.el4
-rw-r--r--lisp/mail/uudecode.el6
-rw-r--r--lisp/makefile.w32-in114
-rw-r--r--lisp/makesum.el9
-rw-r--r--lisp/man.el142
-rw-r--r--lisp/master.el4
-rw-r--r--lisp/mb-depth.el3
-rw-r--r--lisp/md4.el3
-rw-r--r--lisp/menu-bar.el2482
-rw-r--r--lisp/mh-e/.arch-inventory4
-rw-r--r--lisp/mh-e/ChangeLog71
-rw-r--r--lisp/mh-e/ChangeLog.1100
-rw-r--r--lisp/mh-e/mh-acros.el4
-rw-r--r--lisp/mh-e/mh-alias.el41
-rw-r--r--lisp/mh-e/mh-buffers.el5
-rw-r--r--lisp/mh-e/mh-comp.el15
-rw-r--r--lisp/mh-e/mh-compat.el4
-rw-r--r--lisp/mh-e/mh-e.el13
-rw-r--r--lisp/mh-e/mh-folder.el4
-rw-r--r--lisp/mh-e/mh-funcs.el14
-rw-r--r--lisp/mh-e/mh-gnus.el4
-rw-r--r--lisp/mh-e/mh-identity.el4
-rw-r--r--lisp/mh-e/mh-inc.el4
-rw-r--r--lisp/mh-e/mh-junk.el4
-rw-r--r--lisp/mh-e/mh-letter.el87
-rw-r--r--lisp/mh-e/mh-limit.el4
-rw-r--r--lisp/mh-e/mh-mime.el25
-rw-r--r--lisp/mh-e/mh-print.el4
-rw-r--r--lisp/mh-e/mh-scan.el7
-rw-r--r--lisp/mh-e/mh-search.el7
-rw-r--r--lisp/mh-e/mh-seq.el7
-rw-r--r--lisp/mh-e/mh-show.el15
-rw-r--r--lisp/mh-e/mh-speed.el4
-rw-r--r--lisp/mh-e/mh-thread.el4
-rw-r--r--lisp/mh-e/mh-tool-bar.el4
-rw-r--r--lisp/mh-e/mh-utils.el33
-rw-r--r--lisp/mh-e/mh-xface.el4
-rw-r--r--lisp/midnight.el20
-rw-r--r--lisp/minibuf-eldef.el4
-rw-r--r--lisp/minibuffer.el1064
-rw-r--r--lisp/misc.el65
-rw-r--r--lisp/misearch.el7
-rw-r--r--lisp/mouse-copy.el4
-rw-r--r--lisp/mouse-drag.el17
-rw-r--r--lisp/mouse-sel.el24
-rw-r--r--lisp/mouse.el1161
-rw-r--r--lisp/mpc.el184
-rw-r--r--lisp/msb.el11
-rw-r--r--lisp/mwheel.el6
-rw-r--r--lisp/net/ange-ftp.el58
-rw-r--r--lisp/net/browse-url.el140
-rw-r--r--lisp/net/dbus.el197
-rw-r--r--lisp/net/dig.el15
-rw-r--r--lisp/net/dns.el20
-rw-r--r--lisp/net/eudc-bob.el5
-rw-r--r--lisp/net/eudc-export.el5
-rw-r--r--lisp/net/eudc-hotlist.el26
-rw-r--r--lisp/net/eudc-vars.el45
-rw-r--r--lisp/net/eudc.el9
-rw-r--r--lisp/net/eudcb-bbdb.el5
-rw-r--r--lisp/net/eudcb-ldap.el5
-rw-r--r--lisp/net/eudcb-mab.el5
-rw-r--r--lisp/net/eudcb-ph.el5
-rw-r--r--lisp/net/gnutls.el184
-rw-r--r--lisp/net/goto-addr.el6
-rw-r--r--lisp/net/hmac-def.el7
-rw-r--r--lisp/net/hmac-md5.el5
-rw-r--r--lisp/net/imap-hash.el374
-rw-r--r--lisp/net/imap.el99
-rw-r--r--lisp/net/ldap.el83
-rw-r--r--lisp/net/mairix.el35
-rw-r--r--lisp/net/net-utils.el25
-rw-r--r--lisp/net/netrc.el105
-rw-r--r--lisp/net/network-stream.el292
-rw-r--r--lisp/net/newst-backend.el5
-rw-r--r--lisp/net/newst-plainview.el220
-rw-r--r--lisp/net/newst-reader.el5
-rw-r--r--lisp/net/newst-ticker.el5
-rw-r--r--lisp/net/newst-treeview.el4
-rw-r--r--lisp/net/newsticker.el5
-rw-r--r--lisp/net/ntlm.el9
-rw-r--r--lisp/net/quickurl.el48
-rw-r--r--lisp/net/rcirc.el699
-rw-r--r--lisp/net/rcompile.el12
-rw-r--r--lisp/net/rlogin.el91
-rw-r--r--lisp/net/sasl-cram.el4
-rw-r--r--lisp/net/sasl-digest.el8
-rw-r--r--lisp/net/sasl-ntlm.el4
-rw-r--r--lisp/net/sasl.el3
-rw-r--r--lisp/net/secrets.el868
-rw-r--r--lisp/net/snmp-mode.el4
-rw-r--r--lisp/net/soap-client.el1752
-rw-r--r--lisp/net/soap-inspect.el358
-rw-r--r--lisp/net/socks.el4
-rw-r--r--lisp/net/telnet.el25
-rw-r--r--lisp/net/tls.el12
-rw-r--r--lisp/net/tramp-cache.el193
-rw-r--r--lisp/net/tramp-cmds.el122
-rw-r--r--lisp/net/tramp-compat.el159
-rw-r--r--lisp/net/tramp-fish.el1180
-rw-r--r--lisp/net/tramp-ftp.el47
-rw-r--r--lisp/net/tramp-gvfs.el68
-rw-r--r--lisp/net/tramp-gw.el62
-rw-r--r--lisp/net/tramp-imap.el860
-rw-r--r--lisp/net/tramp-sh.el5091
-rw-r--r--lisp/net/tramp-smb.el160
-rw-r--r--lisp/net/tramp-uu.el10
-rw-r--r--lisp/net/tramp.el7134
-rw-r--r--lisp/net/trampver.el22
-rw-r--r--lisp/net/webjump.el4
-rw-r--r--lisp/net/xesam.el26
-rw-r--r--lisp/net/zeroconf.el3
-rw-r--r--lisp/newcomment.el98
-rw-r--r--lisp/notifications.el294
-rw-r--r--lisp/novice.el3
-rw-r--r--lisp/nxml/TODO468
-rw-r--r--lisp/nxml/nxml-enc.el3
-rw-r--r--lisp/nxml/nxml-glyph.el3
-rw-r--r--lisp/nxml/nxml-maint.el5
-rw-r--r--lisp/nxml/nxml-mode.el114
-rw-r--r--lisp/nxml/nxml-ns.el3
-rw-r--r--lisp/nxml/nxml-outln.el9
-rw-r--r--lisp/nxml/nxml-parse.el3
-rw-r--r--lisp/nxml/nxml-rap.el3
-rw-r--r--lisp/nxml/nxml-uchnm.el3
-rw-r--r--lisp/nxml/nxml-util.el3
-rw-r--r--lisp/nxml/rng-cmpct.el3
-rw-r--r--lisp/nxml/rng-dt.el3
-rw-r--r--lisp/nxml/rng-loc.el5
-rw-r--r--lisp/nxml/rng-maint.el3
-rw-r--r--lisp/nxml/rng-match.el3
-rw-r--r--lisp/nxml/rng-nxml.el7
-rw-r--r--lisp/nxml/rng-parse.el3
-rw-r--r--lisp/nxml/rng-pttrn.el3
-rw-r--r--lisp/nxml/rng-uri.el3
-rw-r--r--lisp/nxml/rng-util.el3
-rw-r--r--lisp/nxml/rng-valid.el14
-rw-r--r--lisp/nxml/rng-xsd.el3
-rw-r--r--lisp/nxml/xmltok.el3
-rw-r--r--lisp/nxml/xsd-regexp.el3
-rw-r--r--lisp/obsolete/abbrevlist.el (renamed from lisp/abbrevlist.el)6
-rw-r--r--lisp/obsolete/awk-mode.el7
-rw-r--r--lisp/obsolete/cl-compat.el12
-rw-r--r--lisp/obsolete/complete.el (renamed from lisp/complete.el)8
-rw-r--r--lisp/obsolete/erc-hecomplete.el (renamed from lisp/erc/erc-hecomplete.el)20
-rw-r--r--lisp/obsolete/fast-lock.el10
-rw-r--r--lisp/obsolete/iso-acc.el7
-rw-r--r--lisp/obsolete/iso-insert.el7
-rw-r--r--lisp/obsolete/iso-swed.el7
-rw-r--r--lisp/obsolete/keyswap.el7
-rw-r--r--lisp/obsolete/lazy-lock.el36
-rw-r--r--lisp/obsolete/levents.el4
-rw-r--r--lisp/obsolete/lmenu.el3
-rw-r--r--lisp/obsolete/lucid.el12
-rw-r--r--lisp/obsolete/old-whitespace.el12
-rw-r--r--lisp/obsolete/options.el7
-rw-r--r--lisp/obsolete/pc-mode.el (renamed from lisp/emulation/pc-mode.el)5
-rw-r--r--lisp/obsolete/pc-select.el417
-rw-r--r--lisp/obsolete/pgg-def.el (renamed from lisp/pgg-def.el)6
-rw-r--r--lisp/obsolete/pgg-gpg.el (renamed from lisp/pgg-gpg.el)11
-rw-r--r--lisp/obsolete/pgg-parse.el (renamed from lisp/pgg-parse.el)11
-rw-r--r--lisp/obsolete/pgg-pgp.el (renamed from lisp/pgg-pgp.el)19
-rw-r--r--lisp/obsolete/pgg-pgp5.el (renamed from lisp/pgg-pgp5.el)19
-rw-r--r--lisp/obsolete/pgg.el (renamed from lisp/pgg.el)81
-rw-r--r--lisp/obsolete/resume.el7
-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)5
-rw-r--r--lisp/obsolete/sc.el19
-rw-r--r--lisp/obsolete/scribe.el7
-rw-r--r--lisp/obsolete/spell.el (renamed from lisp/textmodes/spell.el)41
-rw-r--r--lisp/obsolete/sregex.el (renamed from lisp/emacs-lisp/sregex.el)5
-rw-r--r--lisp/obsolete/swedish.el7
-rw-r--r--lisp/obsolete/sym-comp.el3
-rw-r--r--lisp/obsolete/vc-mcvs.el13
-rw-r--r--lisp/obsolete/x-menu.el153
-rw-r--r--lisp/org/ChangeLog7363
-rw-r--r--lisp/org/ob-C.el193
-rw-r--r--lisp/org/ob-R.el302
-rw-r--r--lisp/org/ob-asymptote.el163
-rw-r--r--lisp/org/ob-calc.el96
-rw-r--r--lisp/org/ob-clojure.el87
-rw-r--r--lisp/org/ob-comint.el162
-rw-r--r--lisp/org/ob-css.el48
-rw-r--r--lisp/org/ob-ditaa.el73
-rw-r--r--lisp/org/ob-dot.el89
-rw-r--r--lisp/org/ob-emacs-lisp.el70
-rw-r--r--lisp/org/ob-eval.el261
-rw-r--r--lisp/org/ob-exp.el327
-rw-r--r--lisp/org/ob-gnuplot.el234
-rw-r--r--lisp/org/ob-haskell.el216
-rw-r--r--lisp/org/ob-js.el164
-rw-r--r--lisp/org/ob-keys.el97
-rw-r--r--lisp/org/ob-latex.el179
-rw-r--r--lisp/org/ob-ledger.el71
-rw-r--r--lisp/org/ob-lisp.el112
-rw-r--r--lisp/org/ob-lob.el123
-rw-r--r--lisp/org/ob-matlab.el47
-rw-r--r--lisp/org/ob-mscgen.el85
-rw-r--r--lisp/org/ob-ocaml.el156
-rw-r--r--lisp/org/ob-octave.el263
-rw-r--r--lisp/org/ob-org.el61
-rw-r--r--lisp/org/ob-perl.el116
-rw-r--r--lisp/org/ob-plantuml.el82
-rw-r--r--lisp/org/ob-python.el281
-rw-r--r--lisp/org/ob-ref.el228
-rw-r--r--lisp/org/ob-ruby.el238
-rw-r--r--lisp/org/ob-sass.el68
-rw-r--r--lisp/org/ob-scheme.el138
-rw-r--r--lisp/org/ob-screen.el146
-rw-r--r--lisp/org/ob-sh.el170
-rw-r--r--lisp/org/ob-sql.el125
-rw-r--r--lisp/org/ob-sqlite.el148
-rw-r--r--lisp/org/ob-table.el124
-rw-r--r--lisp/org/ob-tangle.el453
-rw-r--r--lisp/org/ob.el1967
-rw-r--r--lisp/org/org-agenda.el1900
-rw-r--r--lisp/org/org-archive.el34
-rw-r--r--lisp/org/org-ascii.el164
-rw-r--r--lisp/org/org-attach.el27
-rw-r--r--lisp/org/org-bbdb.el15
-rw-r--r--lisp/org/org-beamer.el635
-rw-r--r--lisp/org/org-bibtex.el5
-rw-r--r--lisp/org/org-capture.el1389
-rw-r--r--lisp/org/org-clock.el1445
-rw-r--r--lisp/org/org-colview.el167
-rw-r--r--lisp/org/org-compat.el246
-rw-r--r--lisp/org/org-complete.el277
-rw-r--r--lisp/org/org-crypt.el125
-rw-r--r--lisp/org/org-ctags.el540
-rw-r--r--lisp/org/org-datetree.el12
-rw-r--r--lisp/org/org-docbook.el287
-rw-r--r--lisp/org/org-docview.el92
-rw-r--r--lisp/org/org-entities.el572
-rw-r--r--lisp/org/org-exp-blocks.el118
-rw-r--r--lisp/org/org-exp.el1246
-rw-r--r--lisp/org/org-faces.el132
-rw-r--r--lisp/org/org-feed.el116
-rw-r--r--lisp/org/org-footnote.el74
-rw-r--r--lisp/org/org-freemind.el361
-rw-r--r--lisp/org/org-gnus.el122
-rw-r--r--lisp/org/org-habit.el58
-rw-r--r--lisp/org/org-html.el982
-rw-r--r--lisp/org/org-icalendar.el119
-rw-r--r--lisp/org/org-id.el95
-rw-r--r--lisp/org/org-indent.el200
-rw-r--r--lisp/org/org-info.el6
-rw-r--r--lisp/org/org-inlinetask.el214
-rw-r--r--lisp/org/org-install.el4
-rw-r--r--lisp/org/org-irc.el5
-rw-r--r--lisp/org/org-jsinfo.el12
-rw-r--r--lisp/org/org-latex.el1056
-rw-r--r--lisp/org/org-list.el2835
-rw-r--r--lisp/org/org-mac-message.el17
-rw-r--r--lisp/org/org-macs.el71
-rw-r--r--lisp/org/org-mew.el17
-rw-r--r--lisp/org/org-mhe.el27
-rw-r--r--lisp/org/org-mks.el136
-rw-r--r--lisp/org/org-mobile.el296
-rw-r--r--lisp/org/org-mouse.el85
-rw-r--r--lisp/org/org-plot.el43
-rw-r--r--lisp/org/org-protocol.el165
-rw-r--r--lisp/org/org-publish.el702
-rw-r--r--lisp/org/org-remember.el175
-rw-r--r--lisp/org/org-rmail.el16
-rw-r--r--lisp/org/org-src.el420
-rw-r--r--lisp/org/org-table.el550
-rw-r--r--lisp/org/org-taskjuggler.el648
-rw-r--r--lisp/org/org-timer.el201
-rw-r--r--lisp/org/org-vm.el16
-rw-r--r--lisp/org/org-w3m.el20
-rw-r--r--lisp/org/org-wl.el306
-rw-r--r--lisp/org/org-xoxo.el12
-rw-r--r--lisp/org/org.el4707
-rw-r--r--lisp/outline.el24
-rw-r--r--lisp/paren.el7
-rw-r--r--lisp/password-cache.el24
-rw-r--r--lisp/patcomp.el1
-rw-r--r--lisp/paths.el5
-rw-r--r--lisp/pcmpl-cvs.el5
-rw-r--r--lisp/pcmpl-gnu.el6
-rw-r--r--lisp/pcmpl-linux.el6
-rw-r--r--lisp/pcmpl-rpm.el6
-rw-r--r--lisp/pcmpl-unix.el46
-rw-r--r--lisp/pcomplete.el172
-rw-r--r--lisp/play/5x5.el20
-rw-r--r--lisp/play/animate.el4
-rw-r--r--lisp/play/blackbox.el4
-rw-r--r--lisp/play/bruce.el4
-rw-r--r--lisp/play/bubbles.el69
-rw-r--r--lisp/play/cookie1.el4
-rw-r--r--lisp/play/decipher.el122
-rw-r--r--lisp/play/dissociate.el4
-rw-r--r--lisp/play/doctor.el1357
-rw-r--r--lisp/play/dunnet.el4
-rw-r--r--lisp/play/fortune.el5
-rw-r--r--lisp/play/gamegrid.el25
-rw-r--r--lisp/play/gametree.el73
-rw-r--r--lisp/play/gomoku.el184
-rw-r--r--lisp/play/handwrite.el114
-rw-r--r--lisp/play/hanoi.el2
-rw-r--r--lisp/play/landmark.el1527
-rw-r--r--lisp/play/life.el6
-rw-r--r--lisp/play/meese.el1
-rw-r--r--lisp/play/morse.el112
-rw-r--r--lisp/play/mpuz.el9
-rw-r--r--lisp/play/pong.el28
-rw-r--r--lisp/play/snake.el27
-rw-r--r--lisp/play/solitaire.el31
-rw-r--r--lisp/play/spook.el4
-rw-r--r--lisp/play/studly.el1
-rw-r--r--lisp/play/tetris.el311
-rw-r--r--lisp/play/yow.el4
-rw-r--r--lisp/play/zone.el65
-rw-r--r--lisp/printing.el28
-rw-r--r--lisp/proced.el7
-rw-r--r--lisp/progmodes/ada-mode.el741
-rw-r--r--lisp/progmodes/ada-prj.el61
-rw-r--r--lisp/progmodes/ada-stmt.el6
-rw-r--r--lisp/progmodes/ada-xref.el44
-rw-r--r--lisp/progmodes/antlr-mode.el166
-rw-r--r--lisp/progmodes/asm-mode.el43
-rw-r--r--lisp/progmodes/autoconf.el22
-rw-r--r--lisp/progmodes/bug-reference.el34
-rw-r--r--lisp/progmodes/cap-words.el4
-rw-r--r--lisp/progmodes/cc-align.el9
-rw-r--r--lisp/progmodes/cc-awk.el25
-rw-r--r--lisp/progmodes/cc-bytecomp.el8
-rw-r--r--lisp/progmodes/cc-cmds.el217
-rw-r--r--lisp/progmodes/cc-compat.el9
-rw-r--r--lisp/progmodes/cc-defs.el157
-rw-r--r--lisp/progmodes/cc-engine.el4749
-rw-r--r--lisp/progmodes/cc-fonts.el385
-rw-r--r--lisp/progmodes/cc-langs.el125
-rw-r--r--lisp/progmodes/cc-menus.el9
-rw-r--r--lisp/progmodes/cc-mode.el236
-rw-r--r--lisp/progmodes/cc-styles.el25
-rw-r--r--lisp/progmodes/cc-vars.el35
-rw-r--r--lisp/progmodes/cfengine.el25
-rw-r--r--lisp/progmodes/cmacexp.el4
-rw-r--r--lisp/progmodes/compile.el1134
-rw-r--r--lisp/progmodes/cperl-mode.el94
-rw-r--r--lisp/progmodes/cpp.el101
-rw-r--r--lisp/progmodes/cwarn.el6
-rw-r--r--lisp/progmodes/dcl-mode.el200
-rw-r--r--lisp/progmodes/delphi.el146
-rw-r--r--lisp/progmodes/ebnf-abn.el5
-rw-r--r--lisp/progmodes/ebnf-bnf.el5
-rw-r--r--lisp/progmodes/ebnf-dtd.el5
-rw-r--r--lisp/progmodes/ebnf-ebx.el5
-rw-r--r--lisp/progmodes/ebnf-iso.el5
-rw-r--r--lisp/progmodes/ebnf-otz.el5
-rw-r--r--lisp/progmodes/ebnf-yac.el5
-rw-r--r--lisp/progmodes/ebnf2ps.el22
-rw-r--r--lisp/progmodes/ebrowse.el289
-rw-r--r--lisp/progmodes/etags.el90
-rw-r--r--lisp/progmodes/executable.el8
-rw-r--r--lisp/progmodes/f90.el36
-rw-r--r--lisp/progmodes/flymake.el117
-rw-r--r--lisp/progmodes/fortran.el93
-rw-r--r--lisp/progmodes/gdb-mi.el4205
-rw-r--r--lisp/progmodes/gdb-ui.el4158
-rw-r--r--lisp/progmodes/glasses.el22
-rw-r--r--lisp/progmodes/grep.el114
-rw-r--r--lisp/progmodes/gud.el391
-rw-r--r--lisp/progmodes/hideif.el23
-rw-r--r--lisp/progmodes/hideshow.el23
-rw-r--r--lisp/progmodes/icon.el71
-rw-r--r--lisp/progmodes/idlw-complete-structtag.el16
-rw-r--r--lisp/progmodes/idlw-help.el87
-rw-r--r--lisp/progmodes/idlw-shell.el87
-rw-r--r--lisp/progmodes/idlw-toolbar.el21
-rw-r--r--lisp/progmodes/idlwave.el235
-rw-r--r--lisp/progmodes/inf-lisp.el41
-rw-r--r--lisp/progmodes/js.el170
-rw-r--r--lisp/progmodes/ld-script.el22
-rw-r--r--lisp/progmodes/m4-mode.el31
-rw-r--r--lisp/progmodes/make-mode.el168
-rw-r--r--lisp/progmodes/mantemp.el4
-rw-r--r--lisp/progmodes/meta-mode.el164
-rw-r--r--lisp/progmodes/mixal-mode.el43
-rw-r--r--lisp/progmodes/modula2.el608
-rw-r--r--lisp/progmodes/octave-inf.el102
-rw-r--r--lisp/progmodes/octave-mod.el1110
-rw-r--r--lisp/progmodes/pascal.el163
-rw-r--r--lisp/progmodes/perl-mode.el397
-rw-r--r--lisp/progmodes/prolog.el4357
-rw-r--r--lisp/progmodes/ps-mode.el74
-rw-r--r--lisp/progmodes/python.el257
-rw-r--r--lisp/progmodes/ruby-mode.el333
-rw-r--r--lisp/progmodes/scheme.el62
-rw-r--r--lisp/progmodes/sh-script.el382
-rw-r--r--lisp/progmodes/simula.el96
-rw-r--r--lisp/progmodes/sql.el3031
-rw-r--r--lisp/progmodes/subword.el5
-rw-r--r--lisp/progmodes/tcl.el41
-rw-r--r--lisp/progmodes/vera-mode.el29
-rw-r--r--lisp/progmodes/verilog-mode.el100
-rw-r--r--lisp/progmodes/vhdl-mode.el181
-rw-r--r--lisp/progmodes/which-func.el60
-rw-r--r--lisp/progmodes/xscheme.el60
-rw-r--r--lisp/ps-bdf.el10
-rw-r--r--lisp/ps-def.el82
-rw-r--r--lisp/ps-mule.el10
-rw-r--r--lisp/ps-print.el36
-rw-r--r--lisp/ps-samp.el11
-rw-r--r--lisp/recentf.el35
-rw-r--r--lisp/rect.el85
-rw-r--r--lisp/register.el9
-rw-r--r--lisp/repeat.el6
-rw-r--r--lisp/replace.el422
-rw-r--r--lisp/reposition.el6
-rw-r--r--lisp/reveal.el8
-rw-r--r--lisp/rfn-eshadow.el5
-rw-r--r--lisp/rot13.el4
-rw-r--r--lisp/ruler-mode.el39
-rw-r--r--lisp/savehist.el35
-rw-r--r--lisp/saveplace.el13
-rw-r--r--lisp/sb-image.el4
-rw-r--r--lisp/scroll-all.el8
-rw-r--r--lisp/scroll-bar.el31
-rw-r--r--lisp/scroll-lock.el3
-rw-r--r--lisp/select.el87
-rw-r--r--lisp/server.el486
-rw-r--r--lisp/ses.el4
-rw-r--r--lisp/sha1.el6
-rw-r--r--lisp/shadowfile.el35
-rw-r--r--lisp/shell.el336
-rw-r--r--lisp/simple.el1133
-rw-r--r--lisp/skeleton.el60
-rw-r--r--lisp/sort.el13
-rw-r--r--lisp/soundex.el4
-rw-r--r--lisp/speedbar.el328
-rw-r--r--lisp/startup.el574
-rw-r--r--lisp/strokes.el31
-rw-r--r--lisp/subr.el722
-rw-r--r--lisp/t-mouse.el4
-rw-r--r--lisp/tabify.el5
-rw-r--r--lisp/talk.el9
-rw-r--r--lisp/tar-mode.el55
-rw-r--r--lisp/tempo.el4
-rw-r--r--lisp/term.el132
-rw-r--r--lisp/term/AT386.el4
-rw-r--r--lisp/term/README3
-rw-r--r--lisp/term/apollo.el1
-rw-r--r--lisp/term/bobcat.el1
-rw-r--r--lisp/term/common-win.el464
-rw-r--r--lisp/term/cygwin.el1
-rw-r--r--lisp/term/internal.el5
-rw-r--r--lisp/term/iris-ansi.el4
-rw-r--r--lisp/term/linux.el1
-rw-r--r--lisp/term/lk201.el131
-rw-r--r--lisp/term/news.el4
-rw-r--r--lisp/term/ns-win.el485
-rw-r--r--lisp/term/pc-win.el51
-rw-r--r--lisp/term/rxvt.el4
-rw-r--r--lisp/term/screen.el11
-rw-r--r--lisp/term/sun.el4
-rw-r--r--lisp/term/sup-mouse.el11
-rw-r--r--lisp/term/tty-colors.el9
-rw-r--r--lisp/term/tvi970.el19
-rw-r--r--lisp/term/vt100.el20
-rw-r--r--lisp/term/vt102.el1
-rw-r--r--lisp/term/vt125.el1
-rw-r--r--lisp/term/vt200.el1
-rw-r--r--lisp/term/vt201.el1
-rw-r--r--lisp/term/vt220.el1
-rw-r--r--lisp/term/vt240.el1
-rw-r--r--lisp/term/vt300.el1
-rw-r--r--lisp/term/vt320.el1
-rw-r--r--lisp/term/vt400.el1
-rw-r--r--lisp/term/vt420.el1
-rw-r--r--lisp/term/w32-win.el36
-rw-r--r--lisp/term/w32console.el20
-rw-r--r--lisp/term/wyse50.el4
-rw-r--r--lisp/term/x-win.el226
-rw-r--r--lisp/term/xterm.el4
-rw-r--r--lisp/terminal.el9
-rw-r--r--lisp/textmodes/artist.el81
-rw-r--r--lisp/textmodes/bib-mode.el17
-rw-r--r--lisp/textmodes/bibtex-style.el9
-rw-r--r--lisp/textmodes/bibtex.el17
-rw-r--r--lisp/textmodes/conf-mode.el6
-rw-r--r--lisp/textmodes/css-mode.el17
-rw-r--r--lisp/textmodes/dns-mode.el11
-rw-r--r--lisp/textmodes/enriched.el54
-rw-r--r--lisp/textmodes/fill.el32
-rw-r--r--lisp/textmodes/flyspell.el117
-rw-r--r--lisp/textmodes/ispell.el694
-rw-r--r--lisp/textmodes/makeinfo.el8
-rw-r--r--lisp/textmodes/nroff-mode.el26
-rw-r--r--lisp/textmodes/page-ext.el23
-rw-r--r--lisp/textmodes/page.el5
-rw-r--r--lisp/textmodes/paragraphs.el5
-rw-r--r--lisp/textmodes/picture.el22
-rw-r--r--lisp/textmodes/po.el4
-rw-r--r--lisp/textmodes/refbib.el4
-rw-r--r--lisp/textmodes/refer.el10
-rw-r--r--lisp/textmodes/refill.el4
-rw-r--r--lisp/textmodes/reftex-auc.el7
-rw-r--r--lisp/textmodes/reftex-cite.el55
-rw-r--r--lisp/textmodes/reftex-dcr.el7
-rw-r--r--lisp/textmodes/reftex-global.el5
-rw-r--r--lisp/textmodes/reftex-index.el374
-rw-r--r--lisp/textmodes/reftex-parse.el20
-rw-r--r--lisp/textmodes/reftex-ref.el60
-rw-r--r--lisp/textmodes/reftex-sel.el273
-rw-r--r--lisp/textmodes/reftex-toc.el249
-rw-r--r--lisp/textmodes/reftex-vars.el5
-rw-r--r--lisp/textmodes/reftex.el52
-rw-r--r--lisp/textmodes/remember.el13
-rw-r--r--lisp/textmodes/rst.el400
-rw-r--r--lisp/textmodes/sgml-mode.el42
-rw-r--r--lisp/textmodes/table.el110
-rw-r--r--lisp/textmodes/tex-mode.el404
-rw-r--r--lisp/textmodes/texinfmt.el55
-rw-r--r--lisp/textmodes/texinfo.el187
-rw-r--r--lisp/textmodes/texnfo-upd.el63
-rw-r--r--lisp/textmodes/text-mode.el7
-rw-r--r--lisp/textmodes/tildify.el4
-rw-r--r--lisp/textmodes/two-column.el14
-rw-r--r--lisp/textmodes/underline.el4
-rw-r--r--lisp/thingatpt.el11
-rw-r--r--lisp/thumbs.el3
-rw-r--r--lisp/time-stamp.el9
-rw-r--r--lisp/time.el60
-rw-r--r--lisp/timezone.el5
-rw-r--r--lisp/tmm.el4
-rw-r--r--lisp/tool-bar.el197
-rw-r--r--lisp/tooltip.el11
-rw-r--r--lisp/tree-widget.el7
-rw-r--r--lisp/tutorial.el14
-rw-r--r--lisp/type-break.el49
-rw-r--r--lisp/uniquify.el9
-rw-r--r--lisp/url/ChangeLog237
-rw-r--r--lisp/url/url-about.el4
-rw-r--r--lisp/url/url-auth.el29
-rw-r--r--lisp/url/url-cache.el70
-rw-r--r--lisp/url/url-cid.el4
-rw-r--r--lisp/url/url-cookie.el254
-rw-r--r--lisp/url/url-dav.el4
-rw-r--r--lisp/url/url-dired.el43
-rw-r--r--lisp/url/url-expand.el4
-rw-r--r--lisp/url/url-file.el23
-rw-r--r--lisp/url/url-ftp.el4
-rw-r--r--lisp/url/url-gw.el62
-rw-r--r--lisp/url/url-handlers.el4
-rw-r--r--lisp/url/url-history.el10
-rw-r--r--lisp/url/url-http.el185
-rw-r--r--lisp/url/url-imap.el3
-rw-r--r--lisp/url/url-irc.el9
-rw-r--r--lisp/url/url-ldap.el3
-rw-r--r--lisp/url/url-mailto.el4
-rw-r--r--lisp/url/url-methods.el4
-rw-r--r--lisp/url/url-misc.el4
-rw-r--r--lisp/url/url-news.el4
-rw-r--r--lisp/url/url-nfs.el4
-rw-r--r--lisp/url/url-ns.el4
-rw-r--r--lisp/url/url-parse.el31
-rw-r--r--lisp/url/url-privacy.el4
-rw-r--r--lisp/url/url-proxy.el3
-rw-r--r--lisp/url/url-queue.el112
-rw-r--r--lisp/url/url-util.el27
-rw-r--r--lisp/url/url-vars.el51
-rw-r--r--lisp/url/url.el25
-rw-r--r--lisp/userlock.el4
-rw-r--r--lisp/vc/add-log.el (renamed from lisp/add-log.el)36
-rw-r--r--lisp/vc/compare-w.el (renamed from lisp/compare-w.el)7
-rw-r--r--lisp/vc/cvs-status.el (renamed from lisp/cvs-status.el)59
-rw-r--r--lisp/vc/diff-mode.el (renamed from lisp/diff-mode.el)99
-rw-r--r--lisp/vc/diff.el (renamed from lisp/diff.el)128
-rw-r--r--lisp/vc/ediff-diff.el (renamed from lisp/ediff-diff.el)15
-rw-r--r--lisp/vc/ediff-help.el (renamed from lisp/ediff-help.el)5
-rw-r--r--lisp/vc/ediff-hook.el (renamed from lisp/ediff-hook.el)5
-rw-r--r--lisp/vc/ediff-init.el (renamed from lisp/ediff-init.el)19
-rw-r--r--lisp/vc/ediff-merg.el (renamed from lisp/ediff-merg.el)5
-rw-r--r--lisp/vc/ediff-mult.el (renamed from lisp/ediff-mult.el)6
-rw-r--r--lisp/vc/ediff-ptch.el (renamed from lisp/ediff-ptch.el)7
-rw-r--r--lisp/vc/ediff-util.el (renamed from lisp/ediff-util.el)10
-rw-r--r--lisp/vc/ediff-vers.el (renamed from lisp/ediff-vers.el)5
-rw-r--r--lisp/vc/ediff-wind.el (renamed from lisp/ediff-wind.el)16
-rw-r--r--lisp/vc/ediff.el (renamed from lisp/ediff.el)7
-rw-r--r--lisp/vc/emerge.el (renamed from lisp/emerge.el)252
-rw-r--r--lisp/vc/log-edit.el (renamed from lisp/log-edit.el)36
-rw-r--r--lisp/vc/log-view.el (renamed from lisp/log-view.el)218
-rw-r--r--lisp/vc/pcvs-defs.el (renamed from lisp/pcvs-defs.el)6
-rw-r--r--lisp/vc/pcvs-info.el (renamed from lisp/pcvs-info.el)6
-rw-r--r--lisp/vc/pcvs-parse.el (renamed from lisp/pcvs-parse.el)5
-rw-r--r--lisp/vc/pcvs-util.el (renamed from lisp/pcvs-util.el)5
-rw-r--r--lisp/vc/pcvs.el (renamed from lisp/pcvs.el)6
-rw-r--r--lisp/vc/smerge-mode.el (renamed from lisp/smerge-mode.el)107
-rw-r--r--lisp/vc/vc-annotate.el (renamed from lisp/vc-annotate.el)42
-rw-r--r--lisp/vc/vc-arch.el (renamed from lisp/vc-arch.el)5
-rw-r--r--lisp/vc/vc-bzr.el (renamed from lisp/vc-bzr.el)326
-rw-r--r--lisp/vc/vc-cvs.el (renamed from lisp/vc-cvs.el)9
-rw-r--r--lisp/vc/vc-dav.el (renamed from lisp/vc-dav.el)4
-rw-r--r--lisp/vc/vc-dir.el (renamed from lisp/vc-dir.el)78
-rw-r--r--lisp/vc/vc-dispatcher.el (renamed from lisp/vc-dispatcher.el)73
-rw-r--r--lisp/vc/vc-git.el (renamed from lisp/vc-git.el)178
-rw-r--r--lisp/vc/vc-hg.el (renamed from lisp/vc-hg.el)157
-rw-r--r--lisp/vc/vc-hooks.el (renamed from lisp/vc-hooks.el)19
-rw-r--r--lisp/vc/vc-mtn.el (renamed from lisp/vc-mtn.el)8
-rw-r--r--lisp/vc/vc-rcs.el (renamed from lisp/vc-rcs.el)22
-rw-r--r--lisp/vc/vc-sccs.el (renamed from lisp/vc-sccs.el)9
-rw-r--r--lisp/vc/vc-svn.el (renamed from lisp/vc-svn.el)85
-rw-r--r--lisp/vc/vc.el (renamed from lisp/vc.el)367
-rw-r--r--lisp/vcursor.el6
-rw-r--r--lisp/version.el10
-rw-r--r--lisp/view.el53
-rw-r--r--lisp/vt-control.el4
-rw-r--r--lisp/vt100-led.el4
-rw-r--r--lisp/w32-fns.el89
-rw-r--r--lisp/w32-vars.el15
-rw-r--r--lisp/wdired.el44
-rw-r--r--lisp/whitespace.el49
-rw-r--r--lisp/wid-browse.el15
-rw-r--r--lisp/wid-edit.el315
-rw-r--r--lisp/widget.el7
-rw-r--r--lisp/windmove.el13
-rw-r--r--lisp/window.el197
-rw-r--r--lisp/winner.el4
-rw-r--r--lisp/woman.el212
-rw-r--r--lisp/x-dnd.el30
-rw-r--r--lisp/xml.el21
-rw-r--r--lisp/xt-mouse.el8
1444 files changed, 157046 insertions, 96354 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/.gitignore b/lisp/.gitignore
index d8ab5055b4a..6d5166e1349 100644
--- a/lisp/.gitignore
+++ b/lisp/.gitignore
@@ -4,5 +4,3 @@ loaddefs.el
subdirs.el
finder-inf.el
cus-load.el
-
-# arch-tag: ab6e8f91-fb95-4efe-9c1b-68e21561e68a
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index aef0246571f..d1348485002 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,12868 +1,2437 @@
-2011-05-09 Eli Zaretskii <eliz@gnu.org>
+2011-05-12 Eli Zaretskii <eliz@gnu.org>
* smerge-mode.el (smerge-resolve): Use null-device rather than a
literal "/dev/null".
-2011-05-09 Stefan Monnier <monnier@iro.umontreal.ca>
+2011-05-12 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/lisp.el (lisp-complete-symbol, lisp-completion-at-point):
Fix typo.
-2011-05-08 Ralph Schleicher <rs@ralph-schleicher.de>
+2011-05-12 Ralph Schleicher <rs@ralph-schleicher.de>
* progmodes/which-func.el (which-function):
Use add-log-current-defun instead of add-log-current-defun-function,
which might not be defined (Bug#8260).
-2011-04-25 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-process-actions): Add POS argument.
- Delete region between POS and (pos).
- (tramp-do-copy-or-rename-file-out-of-band): Use `nil' position in
- `tramp-process-actions' call.
- (tramp-maybe-open-connection): Call `tramp-process-actions' with pos.
-
- * net/tramp-smb.el (tramp-smb-maybe-open-connection): Use `nil'
- position in `tramp-process-actions' call.
-
-2011-04-24 Daniel Colascione <dan.colascione@gmail.com>
-
- * progmodes/cc-engine.el (c-forward-decl-or-cast-1):
- Use correct match group (bug#8438).
-
-2011-04-22 Juanma Barranquero <lekktu@gmail.com>
-
- * buff-menu.el (Buffer-menu--buffers): Fix typo in docstring (bug#8535).
-
-2011-04-21 Juanma Barranquero <lekktu@gmail.com>
-
- * play/mpuz.el (mpuz-silent): Doc fix.
- (mpuz-mode-map): Move initialization into declaration.
- (mpuz-put-number-on-board): Rename parameter L to COLUMNS.
- (mpuz-letter-to-digit, mpuz-check-all-solved, mpuz-create-buffer):
- Fix typos in docstrings.
-
- * play/doctor.el (doc$, doctor-$, doctor-read-print, doctor-read-token)
- (doctor-nounp, doctor-pronounp): Fix typos in docstrings.
-
-2011-04-15 Juanma Barranquero <lekktu@gmail.com>
-
- * mouse-drag.el (mouse-drag-throw): Fix typo in docstring.
-
-2011-04-10 Chong Yidong <cyd@stupidchicken.com>
-
- * minibuffer.el (completion--do-completion): Avoid the "Next char
- not unique" prompt if icomplete-mode is enabled (Bug#5849).
-
-2011-04-10 Stephen Berman <stephen.berman@gmx.net>
-
- * textmodes/page.el (what-page): Use line-number-at-pos to
- calculate line number (Bug#6825).
-
-2011-04-10 Chong Yidong <cyd@stupidchicken.com>
-
- * mouse.el (mouse-drag-mode-line-1): Make sure that if we push
- mouse-2 into unread-command-events, it is interpreted correctly.
-
-2011-04-09 Chong Yidong <cyd@stupidchicken.com>
-
- * image-mode.el (image-type, image-mode-map, image-minor-mode-map)
- (image-toggle-display): Doc fix.
-
-2011-04-06 Juanma Barranquero <lekktu@gmail.com>
-
- Backport revno:103823 and revno:103824 from trunk.
- * help-fns.el (describe-variable): Complete all variables having
- documentation, including keywords.
- http://lists.gnu.org/archive/html/emacs-devel/2011-04/msg00112.html
-
-2011-03-24 Juanma Barranquero <lekktu@gmail.com>
-
- * vc-annotate.el (vc-annotate-show-log-revision-at-line):
- Fix typo in docstring.
-
-2011-03-19 Eli Zaretskii <eliz@gnu.org>
-
- * emerge.el (emerge-metachars): Separate value for ms-dos and
- windows-nt systems.
- (emerge-protect-metachars): Quote correctly for ms-dos and
- windows-nt systems.
-
-2011-03-15 Ralph Schleicher <rs@ralph-schleicher.de> (tiny change)
-
- * info.el (info-initialize): Replace all uses of `:' with
- path-separator for compatibility with non-Unix systems.
- Cache quoting of path-separator. (Bug#8258)
-
-2011-03-12 Juanma Barranquero <lekktu@gmail.com>
-
- * avoid.el (mouse-avoidance-mode, mouse-avoidance-nudge-dist)
- (mouse-avoidance-threshold, mouse-avoidance-banish-destination)
- (mouse-avoidance-mode): Fix typos in docstrings.
-
-2011-03-12 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-progress-reporter-update):
- Use `tramp-compat-funcall'.
- (tramp-handle-start-file-process): Use `tramp-compat-process-get'.
- (tramp-handle-insert-file-contents): Make `file-remote-p' call
- compatible.
- (tramp-open-connection-setup-interactive-shell):
- Use `tramp-compat-process-put'.
-
- * net/tramp-compat.el (tramp-compat-process-get)
- (tramp-compat-process-put): New defuns.
-
- * net/trampver.el: Update release number.
-
-2011-03-12 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * ebuff-menu.el (electric-buffer-menu-mode-map): Move initialization
- into declaration. Remove redundant and harmful binding.
-
-2011-03-11 Juanma Barranquero <lekktu@gmail.com>
-
- Backport revno:103463 from trunk.
- * emacs-lisp/cl-macs.el (lexical-let*): Fix argument name in docstring.
-
- Backport revno:103622 from trunk.
- * help-fns.el (describe-variable): Don't complete keywords.
- Suggested by Teodor Zlatanov <tzz@lifelogs.com>.
-
-2011-03-11 Eli Zaretskii <eliz@gnu.org>
-
- * files.el (file-ownership-preserved-p): Pass `integer' as an
- explicit 2nd argument to `file-attributes'. If the file's owner
- is the Administrators group on Windows, and the current user is
- Administrator, consider that a match.
-
- * server.el (server-ensure-safe-dir): Consider server directory
- safe on MS-Windows if its owner is the Administrators group while
- the current Emacs user is Administrator. Use `=' to compare
- numerical UIDs, since they could be integers or floats.
-
-2011-03-07 Chong Yidong <cyd@stupidchicken.com>
-
- * Version 23.3 released.
-
-2011-03-07 Chong Yidong <cyd@stupidchicken.com>
-
- * progmodes/cc-cmds.el (c-beginning-of-statement): Fix 2011-01-31
- change; patch supplied by Alan Mackenzie was applied incorrectly.
-
-2011-02-26 Eli Zaretskii <eliz@gnu.org>
-
- * international/mule-cmds.el (set-default-coding-systems): Use the
- -unix variant of encoding in default-keyboard-coding-system.
- (Bug#8122)
-
-2011-02-23 Kenichi Handa <handa@m17n.org>
-
- * mail/rmailmm.el (rmail-mime-process-multipart): Do not signal an
- error when a multipart boundary in the nested multipart is found.
-
-2011-02-22 Kenichi Handa <handa@m17n.org>
-
- * mail/rmail.el (rmail-start-mail): Decode "encoded-words" of
- header components.
-
-2011-02-19 Kenichi Handa <handa@m17n.org>
-
- * mail/rmailmm.el (rmail-mime-find-header-encoding): Be sure to
- get the header copy into the temporary buffer.
- (rmail-mime-insert-decoded-text): Ignore us-ascii.
- (rmail-show-mime): When rmail-mime-coding-system is nil, set
- buffer-file-coding-system to undecided.
-
-2011-02-18 Eli Zaretskii <eliz@gnu.org>
-
- * image-mode.el (image-toggle-display-image):
- Disable require-final-newline in buffers visiting binary image files.
- (Bug#8047)
-
- * international/mule-cmds.el (read-char-by-name, ucs-insert):
- Document completion with asterisk and a substring.
-
-2011-02-18 Glenn Morris <rgm@gnu.org>
-
- * files.el (find-file-literally): Doc fix.
-
-2011-02-17 Glenn Morris <rgm@gnu.org>
-
- * simple.el (rfc822-goto-eoh): Give it a doc-string.
-
- * log-edit.el (log-edit-insert-changelog):
- Fix `log-edit-strip-single-file-name' functionality. (Bug#8057)
-
-2011-02-14 Chong Yidong <cyd@stupidchicken.com>
-
- * pgg-gpg.el (pgg-gpg-process-region):
- Bind delete-by-moving-to-trash to nil.
-
- * pgg-pgp.el (pgg-pgp-process-region, pgg-pgp-verify-region)
- (pgg-pgp-snarf-keys-region):
- * pgg-pgp5.el (pgg-pgp5-process-region, pgg-pgp5-verify-region)
- (pgg-pgp5-snarf-keys-region): Likewise.
-
-2011-02-12 Chong Yidong <cyd@stupidchicken.com>
-
- * files.el (copy-directory): Revert to pre-2011-01-29 version.
-
-2011-02-12 Chong Yidong <cyd@stupidchicken.com>
-
- * epg.el (epg-delete-output-file, epg-decrypt-string)
- (epg-verify-string, epg-sign-string, epg-encrypt-string):
- Bind delete-by-moving-to-trash to nil.
-
- * epa-file.el (epa-file-insert-file-contents): Likewise.
-
-2011-02-10 Glenn Morris <rgm@gnu.org>
-
- * emacs-lisp/cl-seq.el (union, nunion, intersection)
- (nintersection, set-difference, nset-difference)
- (set-exclusive-or, nset-exclusive-or): Doc fix.
-
- * ediff-ptch.el (ediff-fixup-patch-map): Doc fix.
-
-2011-02-08 Glenn Morris <rgm@gnu.org>
-
- * faces.el (face-attr-match-p): Handle the obsolete :bold and
- :italic props, so that frame-set-background-mode works. (Bug#7966)
-
-2011-02-07 Glenn Morris <rgm@gnu.org>
-
- * simple.el (next-error): Doc fix.
-
-2011-02-06 Chong Yidong <cyd@stupidchicken.com>
- Thierry Volpiatto <thierry.volpiatto@gmail.com>
-
- * files.el (copy-directory): New arg COPY-AS-SUBDIR. If nil,
- don't copy as a subdirectory.
-
-2011-02-05 Glenn Morris <rgm@gnu.org>
-
- * emacs-lisp/cl-macs.el (return-from): Fix doc typo.
-
-2011-02-04 Glenn Morris <rgm@gnu.org>
-
- * calendar/diary-lib.el (diary-font-lock-keywords):
- Tweak diary-time-regexp match. (Bug#7891)
-
- * progmodes/f90.el (f90-find-tag-default): New function. (Bug#7919)
- (f90-mode): Use it for mode's `find-tag-default-function' property.
-
-2011-02-03 Glenn Morris <rgm@gnu.org>
-
- * ibuf-ext.el (ibuffer-filter-disable): Make it work. (Bug#7969)
-
- * faces.el (set-face-attribute): Doc fix. (Bug#2659)
-
-2011-02-02 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * pcomplete.el (pcomplete-here*): Backport fix for mistaken change
- (bug#7959) and (bug#5935).
-
-2011-01-31 Deniz Dogan <deniz.a.m.dogan@gmail.com>
-
- * net/rcirc.el: Clean log filenames (Bug#7933).
- (rcirc-log-write): Use convert-standard-filename.
- (rcirc-log-filename-function): Documentation updates.
-
-2011-01-31 Alan Mackenzie <acm@muc.de>
-
- * progmodes/cc-cmds.el (c-forward-over-illiterals):
- Continue parsing if we encounter a naked # (Bug#7595).
- (c-beginning-of-statement): Avoid loop in locating the beginning
- of a macro.
-
-2011-01-31 Chong Yidong <cyd@stupidchicken.com>
-
- * files.el (copy-directory): Fix arguments to recursive call.
-
-2011-01-29 Daiki Ueno <ueno@unixuser.org>
-
- * epg.el (epg--status-KEYEXPIRED, epg--status-KEYREVOKED):
- Don't presume KEYEXPIRED and KEYREVOKED to be a fatal error status
- (Bug#7931).
-
-2011-01-29 Chong Yidong <cyd@stupidchicken.com>
-
- * files.el (copy-directory): If destination is an existing
- directory, copy into a subdirectory there.
-
-2011-01-29 Andreas Schwab <schwab@linux-m68k.org>
-
- * emacs-lisp/shadow.el (load-path-shadows-find): Ignore leim-list
- files.
-
-2011-01-28 Chong Yidong <cyd@stupidchicken.com>
-
- * image-dired.el (image-dired-mouse-display-image): No-op if no
- file is found (Bug#7817).
-
- * mouse.el (mouse-menu-non-singleton): Doc fix (Bug#7801).
-
-2011-01-28 Kenichi Handa <handa@m17n.org>
-
- * international/quail.el (quail-keyboard-layout-alist):
- Remove superfluous SPC for "pc105-uk" (bug#7927).
-
-2011-01-27 Glenn Morris <rgm@gnu.org>
-
- * msb.el (msb-menu-bar-update-buffers): Update for changed
- argument handling of menu-bar-select-frame. (Bug#7902)
-
-2011-01-27 Chong Yidong <cyd@stupidchicken.com>
-
- * progmodes/cc-engine.el (c-forward-<>-arglist-recur): Set a limit
- to the recursion depth (Bug#7722).
-
-2011-01-26 Roy Liu <carsomyr@gmail.com> (tiny change)
-
- * term/ns-win.el (ns-find-file): Expand ns-input-file with
- command-line-default-directory (Bug#7872).
-
-2011-01-25 Glenn Morris <rgm@gnu.org>
-
- * comint.el (comint-mode): Doc fix. (Bug#7897)
-
-2011-01-24 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * files.el (file-name-non-special): Only change buffer-file-name after
- insert-file-contents if it's `visit'ing the file (bug#7854).
-
-2011-01-23 Chong Yidong <cyd@stupidchicken.com>
-
- * dired.el (dired-revert): Doc fix (Bug#7758).
-
-2011-01-23 Nobuyoshi Nakada <nobu@ruby-lang.org>
-
- * progmodes/ruby-mode.el (ruby-here-doc-beg-match): Fix for
- here-doc which ends with an underscore.
- (ruby-mode-set-encoding): Skip shebang line always.
- (ruby-mode-map): Bind C-c C-c to comment-region.
- (ruby-font-lock-keywords): Highlight literal hash key labels as symbols.
- (ruby-forward-sexp): Stop after literal hash key labels.
- (ruby-font-lock-syntactic-keywords): Highlight regexp after open
- bracket.
-
-2011-01-22 Keitaro Miyazaki <keitaro.miyazaki@gmail.com> (tiny change)
-
- * emacs-lisp/re-builder.el (reb-mode-map): Set case-fold-search in
- the correct buffer (Bug#7650).
-
-2011-01-22 Glenn Morris <rgm@gnu.org>
-
- * simple.el (do-auto-fill): Give it a doc string.
-
- * button.el (make-text-button): Doc fix. (See bug#7881)
-
-2011-01-22 Chong Yidong <cyd@stupidchicken.com>
-
- * simple.el (line-move-visual): Doc fix (Bug#7594).
-
- * emacs-lisp/re-builder.el (reb-mode-map): Fix logic error in
- "Case sensitive" menu item.
-
-2011-01-21 Roland McGrath <roland@frob.com>
-
- * comint.el (comint-replace-by-expanded-history-before-point): Fix
- expansion of !$ and !!:N syntax to pick the indicated word (bug#7883).
-
-2011-01-21 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * progmodes/js.el (js--regexp-literal): Count backslashes (bug#7882).
-
-2011-01-21 Jari Aalto <jari.aalto@cante.net>
-
- * emacs-lisp/checkdoc.el (checkdoc-this-string-valid-engine):
- Assume foo(bar) is a manpage reference rather than some unquoted
- symbol (bug#7705).
-
-2011-01-21 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * subr.el (shell-quote-argument): Properly quote \n (bug#7687).
- Suggested by Flo <sensorflo@gmail.com>.
-
-2011-01-21 Glenn Morris <rgm@gnu.org>
-
- * progmodes/compile.el (compilation-error-regexp-alist):
- Fix custom type. (Bug#7812)
-
-2011-01-17 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * emacs-lisp/easy-mmode.el (define-minor-mode): Don't re-evaluate the
- keymap expression. Improve docstring.
-
-2011-01-15 Mark Diekhans <markd@soe.ucsc.edu>
-
- * files.el (backup-buffer): Make last-resort backup file in
- .emacs.d (Bug#6953).
-
- * subr.el (locate-user-emacs-file): If .emacs.d does not exist,
- make it with permission 700.
-
-2011-01-14 Kenichi Handa <handa@m17n.org>
-
- * mail/rmailmm.el (rmail-mime-insert-header):
- Set rmail-mime-coding-system to a cons whose car is the last coding
- system used to decode the header.
- (rmail-mime-find-header-encoding): New function.
- (rmail-mime-insert-decoded-text):
- Override rmail-mime-coding-system if it is a cons.
- (rmail-show-mime): If only a header part was decoded, find the
- coding system while ignoring mm-charset-override-alist.
-
-2011-01-13 Chong Yidong <cyd@stupidchicken.com>
-
- * subr.el (event-start, event-end): Doc fix (Bug#7826).
-
-2011-01-12 Kenichi Handa <handa@m17n.org>
-
- * mail/rmailmm.el (rmail-mime-next-item)
- (rmail-mime-previous-item): Delete them.
- (rmail-mime-shown-mode): Recursively call for children.
- (rmail-mime-hidden-mode): Delete the 2nd arg TOP.
- Callers changed.
- (rmail-mime-raw-mode): Recursively call for children.
- (rmail-mode-map): Change mapping of tab and backtab to
- forward-button and backward-button respectively.
- (rmail-mime-insert-tagline): Always insert "Hide" or "Show"
- button.
- (rmail-mime-update-tagline): New function.
- (rmail-mime-insert-text): Call rmail-mime-update-tagline if the
- body display is changed.
- (rmail-mime-toggle-button): Rename from rmail-mime-image.
- (rmail-mime-image): Delete this button type.
- (rmail-mime-toggle): New button type.
- (rmail-mime-insert-bulk): Call rmail-mime-update-tagline if the
- body display is changed. Change the save button label to "Save".
- Don't process show/hide button here.
- (rmail-mime-insert-multipart): Call rmail-mime-update-tagline if
- the body display is changed. Unconditionally call
- rmail-mime-insert for children.
- (rmail-mime-handle): Update `display' vector of the just inserted
- entity.
- (rmail-mime-process): If mail-header-parse-content-type returns
- nil, use "text/plain" as the fallback type.
- (rmail-mime-insert): For raw-mode, recursively call
- rmail-mim-insert for children.
- (rmail-mime): Handle the case that the current buffer is not rmail
- buffer (e.g. in summary buffer).
-
-2011-01-05 Kenichi Handa <handa@m17n.org>
-
- * mail/rmailmm.el (rmail-mime-next-item)
- (rmail-mime-previous-item): Skip the body of a non-multipart
- entity if a tagline is shown.
-
-2011-01-11 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * tmm.el (tmm-get-keymap): Skip bindings without labels (bug#7721).
- (tmm-prompt): Simplify.
- (tmm-add-prompt): Remove unused var `win'.
-
- * whitespace.el (global-whitespace-newline-mode): Fix call (bug#7810)
- to minor mode which used nil accidentally to mean "turn off".
-
-2011-01-10 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-find-inline-compress)
- (tramp-get-inline-coding): Quote command after pipe symbol for
- local calls under W32. (Bug#6784)
-
-2011-01-10 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-default-method): Initialize with pscp/plink
- only when running under W32.
-
-2011-01-09 Eli Zaretskii <eliz@gnu.org>
-
- * progmodes/grep.el (grep-compute-defaults): Quote the program
- file name after the pipe symbol in Grep templates. (Bug#6784)
- * jka-compr.el (jka-compr-partial-uncompress): Likewise.
-
-2011-01-08 Lennart Borgman <lennart.borgman@gmail.com>
-
- * buff-menu.el (Buffer-menu-buffer-list): New var.
- (Buffer-menu-revert-function, list-buffers-noselect): Use it, so a
- restricted buffer list is not lost on revert (Bug#7749).
-
-2011-01-08 Eric Hanchrow <eric.hanchrow@gmail.com>
-
- * net/ldap.el (ldap-search-internal): Discard stderr output.
-
-2011-01-07 Eli Zaretskii <eliz@gnu.org>
-
- * files.el (directory-abbrev-alist): Doc fix. (Bug#7777)
-
-2011-01-06 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * vc-bzr.el (vc-bzr-annotate-command, vc-bzr-annotate-time):
- Author names can have spaces (bug#7792).
-
-2011-01-04 Kenichi Handa <handa@m17n.org>
-
- * mail/rmailmm.el (rmail-mime-insert-bulk): Display an unknown
- part as a plain text.
- (rmail-mime-process-multipart): Set the default content-type to
- nil for unknown multipart subtypes (bug#7651).
-
-2011-01-03 Brent Goodrick <bgoodr@gmail.com> (tiny change)
-
- * abbrev.el (prepare-abbrev-list-buffer): If listing local abbrev
- table, get the value before switching to the output buffer. (Bug#7733)
-
-2011-01-03 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * progmodes/python.el (python-mode): Don't impose font-lock (bug#3628).
-
-2011-01-02 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * files.el (file-local-variables-alist):
- Make permanent-local (bug#7767).
-
-2011-01-02 Glenn Morris <rgm@gnu.org>
-
- * version.el (emacs-copyright): Set short copyright year to 2011.
-
-2011-01-02 Mark Lillibridge <mark.lillibridge@hp.com> (tiny change)
-
- * mail/mail-utils.el (mail-strip-quoted-names): Avoid clobbering
- an existing temp buffer. (Bug#7746)
-
-2011-01-02 Glenn Morris <rgm@gnu.org>
-
- * mail/mail-utils.el (mail-mbox-from): Handle From: headers with
- multiple addresses. (Bug#7760)
-
-2010-12-31 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-methods): Add recursive options to "scpc",
- "scpx", "pscp" and "psftp".
-
-2010-12-31 Eli Zaretskii <eliz@gnu.org>
-
- * term/w32-win.el (image-library-alist): Set up correctly for
- libpng versions both before and after 1.4.0. (Bug#7716)
-
-2010-12-25 Eli Zaretskii <eliz@gnu.org>
-
- * time.el (display-time-mode): Mention display-time-interval in
- the doc string. (Bug#7713)
-
- * simple.el (select-active-regions): Doc fix. (Bug#7702)
-
-2010-12-24 Kenichi Handa <handa@m17n.org>
-
- * mail/rmailmm.el (rmail-mime-parse): Perform parsing in
- condition-case and return an error message string if something
- goes wrong.
- (rmail-show-mime): Adjust for the above change. Insert the
- header by rmail-mime-insert-header.
-
-2010-12-24 Kenichi Handa <handa@m17n.org>
-
- * mail/rmailmm.el: New key bindings for rmail-mime-next-item,
- rmail-mime-previous-item, and rmail-mime-toggle-hidden.
- (rmail-mime-mbox-buffer)
- (rmail-mime-view-buffer, rmail-mime-coding-system): New variables.
- (rmail-mime-entity): Argument changed. All codes handling an
- entity object are changed.
- (rmail-mime-entity-header, rmail-mime-entity-body): Adjust for
- the above change.
- (rmail-mime-entity-children, rmail-mime-entity-handler)
- (rmail-mime-entity-tagline): New functions.
- (rmail-mime-message-p): New function.
- (rmail-mime-save): Bind rmail-mime-mbox-buffer.
- (rmail-mime-entity-segment, rmail-mime-next-item)
- (rmail-mime-previous-item, rmail-mime-shown-mode)
- (rmail-mime-hidden-mode, rmail-mime-raw-mode)
- (rmail-mime-toggle-raw, rmail-mime-toggle-hidden)
- (rmail-mime-insert-tagline, rmail-mime-insert-header):
- New functions.
- (rmail-mime-text-handler): Call rmail-mime-insert-text.
- (rmail-mime-insert-decoded-text): New function.
- (rmail-mime-insert-text): Call rmail-mime-insert-decoded-text.
- (rmail-mime-insert-image): Argument changed. Caller changed.
- (rmail-mime-image): Call rmail-mime-toggle-hidden.
- (rmail-mime-set-bulk-data): New function.
- (rmail-mime-insert-bulk): Argument changed.
- (rmail-mime-multipart-handler): Return t.
- (rmail-mime-process-multipart): Argument changed.
- Handle "multipart/alternative" here.
- (rmail-mime-process): Argument changed.
- (rmail-mime-parse): Bind rmail-mime-mbox-buffer.
- (rmail-mime-insert): Argument changed. Handle raw display mode.
- (rmail-mime): Argument changed. Handle toggling of raw display
- mode.
- (rmail-show-mime): Bind rmail-mime-mbox-buffer and
- rmail-mime-view-buffer.
- (rmail-insert-mime-forwarded-message): Likewise.
- (rmail-search-mime-message): Likewise. Don't bind rmail-buffer.
-
- * mail/rmail.el (rmail-show-message-1): If rmail-enable-mime is
- non-nil, handle the header in rmail-show-mime-function.
-
-2010-12-20 Leo <sdl.web@gmail.com>
-
- * help-fns.el (describe-variable): Fix 2010-12-17 change.
-
-2010-12-20 Juri Linkov <juri@jurta.org>
-
- * isearch.el (isearch-lazy-highlight-error): New variable.
- (isearch-lazy-highlight-new-loop): Compare `isearch-error' and
- `isearch-lazy-highlight-error'. Set `isearch-lazy-highlight-error'
- to the current value of `isearch-error' (Bug#7468).
-
-2010-12-17 Chong Yidong <cyd@stupidchicken.com>
-
- * help-fns.el (describe-variable): Don't emit trailing whitespace
- (Bug#7511).
-
-2010-12-17 Leo <sdl.web@gmail.com>
-
- * eshell/em-hist.el (eshell-previous-matching-input): Signal error
- if point is not behind eshell-last-output-end (Bug#7585).
-
-2010-12-16 Chong Yidong <cyd@stupidchicken.com>
-
- * textmodes/rst.el (rst-compile-pdf-preview)
- (rst-compile-slides-preview): Use make-temp-file (Bug#7646).
-
-2010-12-15 Kevin Gallagher <Kevin.Gallagher@boeing.com>
-
- * emulation/edt-mapper.el: Override mapping of function keys so
- that the later call to read-key-sequence works.
-
-2010-12-13 Eli Zaretskii <eliz@gnu.org>
-
- * mail/smtpmail.el (smtpmail-send-it): Write queued mail body with
- Unix EOLs. (Bug#7589)
-
-2010-12-12 Eli Zaretskii <eliz@gnu.org>
-
- * subr.el (posn-col-row): Evaluate header-line-format in the
- context of the POSITION window's buffer.
-
-2010-12-11 Glenn Morris <rgm@gnu.org>
-
- * subr.el (member-ignore-case, run-mode-hooks, insert-for-yank-1)
- (with-silent-modifications): Doc fixes.
-
-2010-12-10 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-action-password, tramp-process-actions):
- Revert patch from 2010-12-08. Use `save-restriction'.
-
-2010-12-09 Eli Zaretskii <eliz@gnu.org>
-
- * menu-bar.el (menu-bar-frame-for-menubar, menu-bar-positive-p):
- New functions.
- (menu-bar-showhide-menu) <menu-bar-mode, showhide-tool-bar>: Use
- them instead of `nil' and `>', respectively. (Bug#1077)
-
-2010-12-09 Stephen Berman <stephen.berman@gmx.net>
-
- * calendar/diary-lib.el (diary-list-sexp-entries):
- Handle case of no newline at end of file. (Bug#7536)
-
-2010-12-09 Glenn Morris <rgm@gnu.org>
-
- * mail/smtpmail.el (smtpmail-send-it): Revert previous change.
-
-2010-12-08 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-handle-start-file-process):
- Protect buffer-modified value. (Bug#7557)
- (tramp-action-password): Delete region, do not narrow.
- (tramp-process-actions): Do not widen.
-
-2010-12-08 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
-
- * log-edit.el (log-edit-changelog-entries):
- Regexp quote filename. (Bug#7505)
-
-2010-12-08 Tom Breton <tehom@panix.com>
-
- * cus-edit.el (custom-save-all):
- Bind print-length and print-level to nil. (Bug#7581)
-
-2010-12-08 Glenn Morris <rgm@gnu.org>
-
- * mouse.el (mouse-menu-major-mode-map, mouse-menu-bar-map):
- Run hooks to update menu contents. (Bug#7586)
-
- * mail/smtpmail.el (smtpmail-send-it): Avoid colons in the queued
- file names, for the sake of MS Windows. (Bug#7588)
-
-2010-12-07 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * diff-mode.el (diff-refine-hunk): Make it work when the hunk contains
- empty lines without a leading space.
-
-2010-12-06 Leo <sdl.web@gmail.com>
-
- * dired-aux.el (dired-do-redisplay): Postpone dired-after-readin-hook
- while mapping over marks (Bug#6810).
-
-2010-12-06 Chong Yidong <cyd@stupidchicken.com>
-
- * image-dired.el (image-dired-db-file)
- (image-dired-temp-image-file, image-dired-gallery-dir)
- (image-dired-temp-rotate-image-file): Set default values relative
- to image-dired-dir (Bug#7518).
-
-2010-12-06 Lawrence Mitchell <wence@gmx.li>
-
- * format.el (format-decode-run-method): Pass args FROM and TO, not
- point-min and point-max, to shell-command-on-region (Bug#7488).
-
-2010-12-06 Jan Djärv <jan.h.d@swipnet.se>
-
- * frame.el (blink-cursor-mode): Make default t for ns.
-
-2010-12-05 Bob Rogers <rogers-emacs@rgrjr.dyndns.org>
-
- * vc-dir.el (vc-dir-query-replace-regexp): Doc fix (Bug#7501).
-
-2010-12-05 Chong Yidong <cyd@stupidchicken.com>
-
- * comint.el (comint-dynamic-list-input-ring)
- (comint-dynamic-complete-filename)
- (comint-replace-by-expanded-filename)
- (comint-dynamic-simple-complete)
- (comint-dynamic-list-filename-completions)
- (comint-dynamic-list-completions): Doc fix (Bug#7499).
-
- * subr.el (posn-x-y, posn-object-x-y, posn-object-width-height):
- Doc fix (Bug#7471).
-
-2010-12-04 Martin Rudalics <rudalics@gmx.at>
-
- * dired.el (dired-pop-to-buffer): Bind pop-up-frames to nil
- (Bug#7533).
-
-2010-12-04 W. Martin Borgert <debacle@debian.org> (tiny change)
-
- * files.el (auto-mode-alist): Handle .dbk (DocBook) with xml-mode.
- (Bug#7491).
-
-2010-12-04 Chong Yidong <cyd@stupidchicken.com>
-
- * simple.el (transient-mark-mode): Doc fix (Bug#7465).
-
-2010-12-04 Eli Zaretskii <eliz@gnu.org>
-
- * files.el (file-relative-name): Handle UNC file names on
- DOS/Windows. (Bug#4674)
-
-2010-12-03 Daiki Ueno <ueno@unixuser.org>
-
- * epg.el (epg-digest-algorithm-alist): Replace "RMD160" with
- "RIPEMD160" (Bug#7490). Reported by Daniel Kahn Gillmor.
- (epg-context-set-passphrase-callback): Mention that the callback
- is not called when used with GnuPG 2.x.
-
-2010-12-02 Glenn Morris <rgm@gnu.org>
-
- * ps-print.el (ps-line-lengths-internal, ps-nb-pages):
- Ensure ps-footer-font-size-internal is initialized.
- Call ps-get-page-dimensions before trying to use ps-font-for-text.
-
-2010-12-01 Kenichi Handa <handa@m17n.org>
-
- * mail/rmailmm.el (rmail-mime-parse): Call rmail-mime-process
- within condition-case.
- (rmail-show-mime): Don't use condition-case.
- (rmail-search-mime-message): New function.
- (rmail-search-mime-message-function): Set to
- rmail-search-mime-message.
-
-2010-12-01 Leo <sdl.web@gmail.com>
-
- * ido.el (ido-common-initialization): New function. (bug#3274)
- (ido-mode): Use it.
- (ido-completing-read): Call it.
-
-2010-11-27 Chong Yidong <cyd@stupidchicken.com>
-
- * log-edit.el (log-edit-font-lock-keywords): Don't try matching
- stand-alone lines, since that is handled by log-edit-match-to-eoh
- (Bug#6465).
-
-2010-11-27 Eduard Wiebe <usenet@pusto.de>
-
- * dired.el (dired-get-filename): Replace backslashes with slashes
- in file names on MS-Windows, needed by `locate'. (Bug#7308)
- * locate.el (locate-default-make-command-line): Don't consider
- drive letter and root directory part of
- `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>
-
- * emacs-lisp/smie.el (smie-prec2->grammar): Simplify handling
- of :smie-open/close-alist.
- (smie-next-sexp): Make it accept a "start token" as argument.
- (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>
-
- * 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>
-
- * mail/rmailmm.el (rmail-mime-entity, rmail-mime-entity-type)
- (rmail-mime-entity-disposition)
- (rmail-mime-entity-transfer-encoding, rmail-mime-entity-header)
- (rmail-mime-entity-body, rmail-mime-entity-children): New functions.
- (rmail-mime-save): Handle the case that the button's `data' is a
- MIME entity.
- (rmail-mime-insert-text): New function.
- (rmail-mime-insert-image): Handle the case that DATA is a MIME entity.
- (rmail-mime-bulk-handler): Just call rmail-mime-insert-bulk.
- (rmail-mime-insert-bulk): New function mostly copied from the old
- rmail-mime-bulk-handler.
- (rmail-mime-multipart-handler): Just call rmail-mime-process-multipart.
- (rmail-mime-process-multipart): New function mostly copied from
- the old rmail-mime-multipart-handler.
- (rmail-mime-show): Just call rmail-mime-process.
- (rmail-mime-process): New function mostly copied from the old
- rmail-mime-show.
- (rmail-mime-insert-multipart, rmail-mime-parse)
- (rmail-mime-insert, rmail-show-mime)
- (rmail-insert-mime-forwarded-message)
- (rmail-insert-mime-resent-message): New functions.
- (rmail-insert-mime-forwarded-message-function): Set to
- rmail-insert-mime-forwarded-message.
- (rmail-insert-mime-resent-message-function): Set to
- rmail-insert-mime-resent-message.
-
- * mail/rmailsum.el: Require rfc2047.
- (rmail-header-summary): Handle multiline Subject: field.
- (rmail-summary-line-decoder): Change the default to
- rfc2047-decode-string.
-
- * mail/rmail.el (rmail-enable-mime): Change the default to t.
- (rmail-mime-feature): Change the default to `rmailmm'.
- (rmail-quit): Delete the specifal code for rmail-enable-mime.
- (rmail-display-labels): Likewise.
- (rmail-show-message-1): Check rmail-enable-mime, and use
- rmail-show-mime-function for a MIME message. Decode the headers
- according to RFC2047.
-
-2010-11-24 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>
-
- * 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>
-
- * 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-11-21 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>
-
- * lpr.el (lpr-buffer, print-buffer, lpr-region, print-region):
- Prompt user before actually printing.
-
-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>
-
- * emacs-lisp/smie.el (smie-bnf-classify): Signal errors for tokens
- that are both openers (resp. closers) and something else.
- (smie-grammar): Loosen definition of valid values.
- (smie-next-sexp, smie-down-list, smie-blink-matching-open)
- (smie-indent--parent, smie-rule-parent, smie-indent-keyword)
- (smie-indent-after-keyword): Adjust users.
- (smie-indent-keyword): Don't indent empty lines.
-
- * vc-hg.el (vc-hg-program): New var.
- 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>
-
- * 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>
-
- * server.el (server-force-stop): Ensure the server is stopped (Bug#7409).
-
-2010-11-13 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>
-
- * 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>
-
- * novice.el (disabled-command-function):
- Fix 2009-11-15 change. (Bug#7384)
-
-2010-11-12 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>
-
- * 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>
-
- * emacs-lisp/bytecomp.el (byte-compile-warnings): Simplify the
- safety predicate.
-
- * files.el (safe-local-variable-p): Gracefully handle errors.
-
- * emacs-lisp/smie.el (smie-rule-parent, smie-indent--rule):
- Use smie-indent-virtual when indenting relative to an opener.
- (smie-rule-separator): Use smie-rule-parent.
- (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>
-
- * ls-lisp.el (ls-lisp-dired-ignore-case): Make it an obsolete alias.
-
-2010-11-10 Glenn Morris <rgm@gnu.org>
-
- * printing.el (pr-menu-bind): Doc fix.
-
- * speedbar.el (speedbar-toggle-images): Doc fix.
-
- * progmodes/python.el (python-shell): Doc fix.
-
- * wid-edit.el (widget-field-use-before-change)
- (widget-use-overlay-change): Doc fixes.
-
-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>
-
- * minibuffer.el (minibuffer-completion-help): Specify the end of the
- completion field (bug#7211).
-
- * progmodes/python.el (python-font-lock-syntactic-keywords): (bug#7322)
- Fix handling of backslash escapes.
- (python-quote-syntax): Adjust accordingly.
-
-2010-11-08 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>
-
- * international/mule-cmds.el (princ-list): Mark as obsolete.
-
-2010-11-07 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * emacs-lisp/smie.el: New package.
-
-2010-11-06 Michael Albinus <michael.albinus@gmx.de>
-
- * files.el (backup-by-copying-when-mismatch):
- Set `permanent-local' property.
-
- * 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>
-
- * 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>
-
- * progmodes/verilog-mode.el (verilog-insert-one-definition)
- (verilog-read-decls, verilog-read-sub-decls-sig): Fix AUTOWIRE and
- AUTOINOUT for SV style multidimensional arrays, bug294.
- Reported by Eric Mastromarchi.
- (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>
-
- * locate.el (locate, locate-mode): Doc fixes.
-
-2010-11-01 Chong Yidong <cyd@stupidchicken.com>
-
- * server.el (server-start): New arg INHIBIT-PROMPT prevents asking
- user for confirmation.
- (server-force-stop): Use it.
- (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>
-
- * 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.
-
-2010-10-31 Eli Zaretskii <eliz@gnu.org>
-
- * vc/vc-hooks.el (vc-default-mode-line-string): Doc fix.
-
-2010-10-31 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-10-31 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-10-31 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc/log-view.el (log-view-mode-map): Bind revert-buffer.
-
- 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.
-
- 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.
-
- 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): 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.
-
- 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.
-
- * 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.
-
- 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.
-
-2010-05-19 Glenn Morris <rgm@gnu.org>
-
- * vc-dir.el (vc-dir): Don't pop-up-windows. (Bug#6204)
-
-2010-10-31 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * 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-git.el (vc-git-checkin): 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-bzr.el (vc-bzr-checkin): Use log-edit-extract-headers.
- (vc-bzr-conflicted-files): New function.
-
- * 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.
-
- * vc-dispatcher.el (vc-finish-logentry): Don't mess so badly with
- the windows/frames.
-
- * vc-bzr.el (vc-bzr-shelve-apply): Don't use *vc-bzr-shelve*.
-
- * 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.
-
- * vc-git.el (vc-git-revision-table): Include remote branches.
-
-2010-10-31 Dan Nicolaescu <dann@ics.uci.edu>
-
- 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.
-
- * 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.
-
- Fix default-directory for vc-root-diff.
- * vc.el (vc-root-diff): Bind default-directory to the root
- directory for the diff command.
-
-2010-10-31 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.
-
-2010-10-31 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-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.
-
-2010-10-31 Dan Nicolaescu <dann@ics.uci.edu>
-
- 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.
-
- * vc.el (vc-default-log-edit-mode): New function.
-
- * vc-dispatcher.el (vc-log-edit): Add a mode argument, pass it to
- log-edit.
-
- 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-30 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>
-
- * speedbar.el (speedbar-mode):
- * play/fortune.el (fortune-in-buffer, fortune):
- * play/gomoku.el (gomoku-mode):
- * play/landmark.el (lm-mode):
- * 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>
-
- * add-log.el (find-change-log): Use derived-mode-p rather than
- major-mode (bug#7284).
-
-2010-10-27 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>
-
- * progmodes/verilog-mode.el (verilog-directive-re): Make this variable
- auto-built for efficiency of execution and updating.
- (verilog-extended-complete-re): Support 'pure' fucntion & task
- declarations (these have no bodies).
- (verilog-beg-of-statement): General cleanup to enable support of
- 'pure' fucntion & task declarations (these have no bodies).
- These efforts together fix Verilog bug210 from veripool; which was also
- noticed by Steve Pearlmutter.
- (verilog-directive-re, verilog-directive-begin, verilog-indent-re)
- (verilog-directive-nest-re, verilog-set-auto-endcomments):
- Support `elsif. Reported by Shankar Giri.
- (verilog-forward-ws&directives, verilog-in-attribute-p): Fixes for
- attribute handling for lining up declarations and assignments.
- (verilog-beg-of-statement-1): Fix issue where continued declaration
- is indented differently if it is after a begin..end clock.
- (verilog-in-attribute-p, verilog-skip-backward-comments)
- (verilog-skip-forward-comment-p): Support proper treatment of
- attributes by indent code. Reported by Jeff Steele.
- (verilog-in-directive-p): Fix comment to correctly describe function.
- (verilog-backward-up-list, verilog-in-struct-region-p)
- (verilog-backward-token, verilog-in-struct-p)
- (verilog-in-coverage-p, verilog-do-indent)
- (verilog-pretty-declarations): Use verilog-backward-up-list as
- wrapper around backward-up-list inorder to properly skip comments.
- Reported by David Rogoff.
- (verilog-property-re, verilog-endcomment-reason-re)
- (verilog-beg-of-statement, verilog-set-auto-endcomments)
- (verilog-calc-1 ): Fix for assert a; else b; indentation (new form
- of if). Reported by Max Bjurling and
- (verilog-calc-1): Fix for clocking block in modport
- declaration. Reported by Brian Hunter.
-
-2010-10-23 Wilson Snyder <wsnyder@wsnyder.org>
-
- * progmodes/verilog-mode.el (verilog-auto-inst, verilog-gate-ios)
- (verilog-gate-keywords, verilog-read-sub-decls)
- (verilog-read-sub-decls-gate, verilog-read-sub-decls-gate-ios)
- (verilog-read-sub-decls-line, verilog-read-sub-decls-sig): Support
- AUTOINST for gate primitives, bug284. Reported by Mark Johnson.
- (verilog-read-decls): Fix spaces in V2K module parameters causing
- mis-identification as interfaces, bug287.
- (verilog-read-decls): Fix not treating "parameter string" as a
- parameter in AUTOINSTPARAM.
- (verilog-read-always-signals-recurse, verilog-read-decls): Fix not
- treating `elsif similar to `endif inside AUTOSENSE.
- (verilog-do-indent): Implement correct automatic or static task or
- function end comment highlight. Reported by Steve Pearlmutter.
- (verilog-font-lock-keywords-2): Fix highlighting of single
- character pins, bug264. Reported by Michael Laajanen.
- (verilog-auto-inst, verilog-read-decls, verilog-read-sub-decls)
- (verilog-read-sub-decls-in-interfaced, verilog-read-sub-decls-sig)
- (verilog-subdecls-get-interfaced, verilog-subdecls-new):
- Support interfaces with AUTOINST, bug270. Reported by Luis Gutierrez.
- (verilog-pretty-expr): Fix interactive arguments, bug272.
- Reported by Mark Johnson.
- (verilog-auto-tieoff, verilog-auto-tieoff-ignore-regexp):
- Add 'verilog-auto-tieoff-ignore-regexp' for AUTOTIEOFF,
- bug269. Suggested by Gary Delp.
- (verilog-mode-map, verilog-preprocess, verilog-preprocess-history)
- (verilog-preprocessor, verilog-set-compile-command):
- Create verilog-preprocess and verilog-preprocessor to show
- preprocessed output.
- (verilog-get-beg-of-line, verilog-get-end-of-line)
- (verilog-modi-file-or-buffer, verilog-modi-name)
- (verilog-modi-point, verilog-within-string): Move defmacro's
- before first use to avoid warning. Reported by Steve Pearlmutter.
- (verilog-colorize-buffer, verilog-colorize-include-files-buffer)
- (verilog-colorize-region, verilog-highlight-buffer)
- (verilog-highlight-includes, verilog-highlight-modules)
- (verilog-highlight-region, verilog-mode): Rename colorize to
- highlight to match other packages. Disable module highlighting,
- as received speed complaints, reenable for experimentation only
- using new verilog-highlight-modules.
- (verilog-read-decls): Fix regexp stack overflow in very large
- AUTO_TEMPLATEs, bug250.
- (verilog-auto, verilog-delete-auto, verilog-save-buffer-state)
- (verilog-scan): Create verilog-save-buffer-state to standardize
- making insignificant changes that shouldn't call hooks.
- (verilog-save-no-change-functions, verilog-save-scan-cache)
- (verilog-scan, verilog-scan-cache-ok-p, verilog-scan-region):
- Create verilog-save-no-change-functions to wrap verilog-scan
- preservation, and fix to work with nested preserved calls.
- (verilog-auto-inst, verilog-auto-inst-dot-name): Support .name
- port syntax for AUTOWIRE, and with new verilog-auto-inst-dot-name
- generate .name with AUTOINST, bug245. Suggested by David Rogoff.
- (verilog-submit-bug-report): Update variable list to be complete.
- (verilog-auto, verilog-colorize-region): Fix AUTO expansion
- breaking on-the-fly font-locking.
- (verilog-colorize-buffer, verilog-colorize-include-files)
- (verilog-colorize-include-files-buffer, verilog-colorize-region)
- (verilog-load-file-at-mouse, verilog-load-file-at-point)
- (verilog-mode, verilog-read-inst-module-matcher): With point on a
- AUTOINST cell instance name, middle mouse button now finds-file on
- it. Suggested by Brad Dobbie.
- (verilog-alw-get-temps, verilog-auto-reset)
- (verilog-auto-sense-sigs, verilog-read-always-signals)
- (verilog-read-always-signals-recurse): Fix loop indexes being
- AUTORESET. AUTORESET now assumes any variables in the
- initialization section of a for() should be ignored.
- Reported by Dan Dever.
- (verilog-error-font-lock-keywords)
- (verilog-error-regexp-emacs-alist)
- (verilog-error-regexp-xemacs-alist): Fix error detection of
- Cadence HAL, reported by David Asher. Repair drift between the
- three similar error variables.
- (verilog-modi-lookup, verilog-modi-lookup-cache)
- (verilog-modi-lookup-last-current, verilog-modi-lookup-last-mod)
- (verilog-modi-lookup-last-modi, verilog-modi-lookup-last-tick):
- Fix slow verilog-auto expansion on very large files.
- (verilog-read-sub-decls-expr, verilog-read-sub-decls-line):
- Fix AUTOOUTPUT treating "1*2" as a signal name in submodule connection
- "{1*2{...". Broke in last revision.
- (verilog-read-sub-decls-expr): Fix AUTOOUTPUT not detecting
- submodule connections with replications "{#{a},#{b}}".
-
-2010-10-23 Glenn Morris <rgm@gnu.org>
-
- * comint.el (comint-password-prompt-regexp):
- Match "enter the password". (Bug#7224)
-
-2010-10-22 Juanma Barranquero <lekktu@gmail.com>
-
- * progmodes/dcl-mode.el (dcl-electric-reindent-regexps):
- Fix typo in docstring.
-
-2010-10-21 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-get-inline-coding): Return `nil' in case of
- errors.
-
- * net/trampver.el: Update release number.
-
-2010-10-20 Kenichi Handa <handa@m17n.org>
-
- * face-remap.el (text-scale-adjust): Call read-event with a proper
- prompt.
-
-2010-10-19 Michael Albinus <michael.albinus@gmx.de>
-
- * 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>.
-
-2010-10-18 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * repeat.el (repeat): Use read-key (bug#6256).
-
-2010-10-18 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.
-
- * minibuffer.el (completion--replace): Move point where it belongs
- when there's a common suffix (bug#7215).
-
-2010-10-15 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.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
- base64-decode-region and just show an error message (bug#7165).
-
- * ps-mule.el (ps-mule-font-spec-list): Delete it. Not used anymore.
- (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>
-
- * mail/emacsbug.el (report-emacs-bug): Mention debbugs.gnu.org.
-
-2010-10-12 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>
-
- * term/ns-win.el (ns-right-alternate-modifier): New defvar.
- (ns-right-option-modifier): New alias for ns-right-alternate-modifier.
- (mac-right-option-modifier): New alias for ns-right-option-modifier.
-
- * 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>
-
- * 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>
-
- * hi-lock.el (hi-lock-font-lock-hook): Check font-lock-fontified
- instead of font-lock-mode before adding keywords.
- Remove hi-lock-mode off code. Remove inhibit hack.
- (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>
-
- * emacs-lisp/shadow.el (find-emacs-lisp-shadows): Rename it...
- (load-path-shadows-find): ... to this.
- (list-load-path-shadows): Update for above change.
-
- * mail/mail-utils.el (mail-mbox-from): Also try return-path.
-
-2010-10-08 Glenn Morris <rgm@gnu.org>
-
- * emacs-lisp/cl-compat.el, emacs-lisp/lmenu.el: Move to obsolete/.
-
- * emacs-lisp/shadow.el (lisp-shadow): Change prefix.
- (shadows-compare-text-p): Make it an obsolete alias for...
- (load-path-shadows-compare-text): ... new name.
- (find-emacs-lisp-shadows): Update for above name change.
- (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>
-
- * minibuffer.el (completion--some, completion--do-completion)
- (minibuffer-complete-and-exit, minibuffer-completion-help)
- (completion-basic-try-completion)
- (completion-basic-all-completions)
- (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)
-
- * vc-svn.el (vc-svn-merge-news): Use --non-interactive. (Bug#7152)
-
-2010-10-03 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>
-
- * minibuffer.el (completion--replace):
- Better preserve markers (bug#7138).
-
-2010-09-29 Juanma Barranquero <lekktu@gmail.com>
-
- * server.el (server-process-filter): Doc fix.
-
-2010-09-27 Drew Adams <drew.adams@oracle.com>
-
- * dired.el (dired-save-positions): Doc fix. (Bug#7119)
-
-2010-09-27 Andreas Schwab <schwab@linux-m68k.org>
-
- * Makefile.in (ELCFILES): Update.
-
- * emacs-lisp/byte-opt.el (byte-optimize-form-code-walker):
- Avoid infinite recursion on erroneous lambda form. (Bug#7114)
-
-2010-09-27 Kenichi Handa <handa@m17n.org>
-
- * tar-mode.el (tar-header-block-tokenize): Decode filenames in
- "ustar" format.
-
-2010-09-27 Kenichi Handa <handa@m17n.org>
-
- * international/mule.el (define-coding-system): Docstring fixed.
-
- * 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>
-
- * window.el (walk-windows): Doc fix (bug#7105).
-
-2010-09-23 Glenn Morris <rgm@gnu.org>
-
- * isearch.el (isearch-lazy-highlight-cleanup)
- (isearch-lazy-highlight-initial-delay)
- (isearch-lazy-highlight-interval)
- (isearch-lazy-highlight-max-at-a-time, isearch-lazy-highlight-face):
- * net/net-utils.el (ipconfig-program-options):
- Move aliases to options before the associated definitions.
-
-2010-09-21 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>
-
- * emacs-lisp/float-sup.el (float-pi): New name for `pi'.
- (float-e): New name for `e'.
- (degrees-to-radians, radians-to-degrees):
- * calendar/solar.el (solar-longitude):
- * calculator.el (calculator-registers, calculator-funcall):
- * 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>
-
- Update to CEDET 1.0's version of EIEIO.
-
- * emacs-lisp/eieio.el (eieio-specialized-key-to-generic-key):
- New function.
- (eieio-defmethod, eieio-generic-form, eieio-generic-call): Use it.
- (eieio-default-eval-maybe): Eval val instead of unquoting only.
- (class-precedence-list): If class is nil, return nil.
- (eieio-generic-call): If class of first input arg is nil, don't
- look up static methods, and do check for primary methods.
- (initialize-instance): See if the default needs to be evaluated
- during the constructor.
- (eieio-perform-slot-validation-for-default): Don't do the check
- for values that will eventually be evaluated.
- (eieio-eval-default-p): New function.
- (eieio-default-eval-maybe): Use it.
-
-2010-07-03 Jan Moringen <jan.moringen@uni-bielefeld.de>
-
- * emacs-lisp/eieio.el (eieio-defclass): Allow :c3
- method-invocation-order.
- (eieio-c3-candidate, eieio-c3-merge-lists): New functions.
- (eieio-class-precedence-dfs): Compute class precedence list using
- dfs algorithm.
- (eieio-class-precedence-bfs): Compute class precedence list using
- bfs algorithm.
- (eieio-class-precedence-c3): Compute class precedence list using
- c3 algorithm.
- (class-precedence-list): New function.
- (eieiomt-method-list, eieiomt-sym-optimize): Use it.
- (inconsistent-class-hierarchy): New error symbol.
- (call-next-method): Stow the replacement argument list for future
- call-next-method invocations.
-
-2010-09-15 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.
- (appt-make-list): Sort diary-list-entries, if we cannot guarantee
- that it is in day order. (Bug#7019)
-
- * calendar/appt.el (appt-check): Rather than showing the diary,
- just turn off invisible display, and only if needed.
-
- * calendar/diary-lib.el (diary-list-entries): Doc fix. (Bug#7019)
-
-2010-09-14 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * emacs-lisp/byte-run.el (set-advertised-calling-convention):
- Add `when' argument. Update callers.
-
- * subr.el (unintern): Declare the obarray arg mandatory.
-
-2010-09-14 Glenn Morris <rgm@gnu.org>
-
- * calendar/diary-lib.el (diary-list-entries-hook, diary-sort-entries):
- Doc fixes.
-
- * calendar/diary-lib.el (diary-included-files): New variable.
- (diary-list-entries): Maybe initialize diary-included-files.
- (diary-include-other-diary-files): Append to diary-included-files.
- * calendar/appt.el (appt-update-list): Also check the members of
- diary-included-files. (Bug#6999)
- (appt-check): Doc fix.
-
-2010-09-12 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>
-
- * 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>
-
- * 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>
-
- * font-lock.el (font-lock-beginning-of-syntax-function):
- Mark as obsolete.
-
-2010-09-10 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>
-
- * progmodes/antlr-mode.el (antlr-font-lock-additional-keywords):
- Fix typo. (Bug#6976)
-
-2010-09-06 Vinicius Jose Latorre <viniciusjl@ig.com.br>
-
- * 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): Add 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.
-
-2010-09-05 Alexander Klimov <alserkli@inbox.ru> (tiny change)
-
- * files.el (directory-abbrev-alist): Use \` as default regexp.
-
- * emacs-lisp/rx.el (rx-any): Don't explode ranges that end in special
- chars like - or ] (bug#6984).
- (rx-any-condense-range): Explode 2-char ranges.
-
-2010-09-02 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>
-
- * desktop.el (desktop-path): Bump :version after 2009-09-15 change.
-
-2010-08-31 Kenichi Handa <handa@m17n.org>
-
- * international/mule-cmds.el (standard-display-european-internal):
- Setup standard-display-table for 8-bit characters by storing 8-bit
- characters in the element vector.
-
- * disp-table.el (standard-display-8bit):
- Setup standard-display-table for 8-bit characters by storing 8-bit
- characters in the element vector.
- (standard-display-european): Likewise.
-
-2010-08-26 Michael Albinus <michael.albinus@gmx.de>
-
- Sync with Tramp 2.1.19.
-
- * net/tramp-cmds.el (tramp-cleanup-all-connections)
- (tramp-reporter-dump-variable, tramp-load-report-modules)
- (tramp-append-tramp-buffers): Use `tramp-compat-funcall'.
- (tramp-bug): Recommend setting of `tramp-verbose' to 9.
-
- * 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.
- (byte-compile-not-obsolete-vars): Define if not bound.
- (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):
- Use it.
- (tramp-advice-file-expand-wildcards): Do not use
- `tramp-handle-file-remote-p'.
- (tramp-compat-make-temp-file): Simplify fallback implementation.
- (tramp-compat-copy-file): Add PRESERVE-SELINUX-CONTEXT.
- (tramp-compat-copy-tree): Remove function.
- (tramp-compat-delete-file): New defun.
- (tramp-compat-delete-directory): Provide implementation for older
- Emacsen.
- (tramp-compat-file-attributes): Handle only
- `wrong-number-of-arguments' error.
-
- * net/tramp-fish.el (tramp-fish-handle-copy-file):
- Add PRESERVE_SELINUX_CONTEXT.
- (tramp-fish-handle-delete-file): Add TRASH arg.
- (tramp-fish-handle-directory-files-and-attributes):
- Do not use `tramp-fish-handle-file-attributes.
- (tramp-fish-handle-file-local-copy)
- (tramp-fish-handle-insert-file-contents)
- (tramp-fish-maybe-open-connection): Use `with-progress-reporter'.
-
- * net/tramp-gvfs.el (top): Require url-util.
- (tramp-gvfs-mount-point): Remove.
- (tramp-gvfs-file-name-handler-alist): Add `file-selinux-context'
- and `set-file-selinux-context'.
- (tramp-gvfs-stringify-dbus-message, tramp-gvfs-send-command)
- (tramp-gvfs-handle-file-selinux-context)
- (tramp-gvfs-handle-set-file-selinux-context): New defuns.
- (with-tramp-dbus-call-method): Format trace message.
- (tramp-gvfs-handle-copy-file): Handle PRESERVE-SELINUX-CONTEXT.
- (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-delete-file): Add TRASH arg.
- Use `tramp-compat-delete-file'.
- (tramp-gvfs-handle-expand-file-name): Expand "~/".
- (tramp-gvfs-handle-make-directory): Make more traces.
- (tramp-gvfs-handle-write-region): Protect deleting tmpfile.
- (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): Preserve current message, in
- order to let progress reporter continue afterwards. (Bug#6257)
- 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.
- Handle default-location.
- (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).
- Use `tramp-compat-funcall'.
-
- * net/tramp-imap.el (top): Autoload `epg-make-context'.
- (tramp-imap-handle-copy-file): Add PRESERVE-SELINUX-CONTEXT.
- (tramp-imap-do-copy-or-rename-file)
- (tramp-imap-handle-insert-file-contents)
- (tramp-imap-handle-file-local-copy): Use `with-progress-reporter'.
- (tramp-imap-handle-delete-file): Add TRASH arg.
-
- * net/tramp-smb.el (tramp-smb-handle-copy-file):
- Add PRESERVE-SELINUX-CONTEXT.
- (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'.
- (tramp-smb-handle-delete-file): Add TRASH arg.
-
- * net/tramp.el (tramp-methods): Move hostname to the end in all
- ssh `tramp-login-args'. Add `tramp-async-args' attribute where
- appropriate.
- (tramp-verbose): Describe verbose level 9.
- (tramp-completion-function-alist)
- (tramp-file-name-regexp, tramp-chunksize)
- (tramp-local-coding-commands, tramp-remote-coding-commands)
- (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.
- (tramp-remote-process-environment): Use `format' instead of
- `concat'. Protect version string by apostroph.
- (tramp-shell-prompt-pattern): Do not use a shy group in case of
- XEmacs.
- (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)
- (tramp-perl-file-attributes)
- (tramp-perl-directory-files-and-attributes): Don't pass "$3".
- (tramp-vc-registered-read-file-names): Read input as
- here-document, otherwise the command could exceed maximum length
- of command line.
- (tramp-file-name-handler-alist): Add `file-selinux-context' and
- `set-file-selinux-context'.
- (tramp-debug-message): Add `tramp-compat-funcall' to ignored
- backtrace functions.
- (tramp-error-with-buffer): Don't show the connection buffer when
- we are in completion mode.
- (tramp-progress-reporter-update, tramp-remote-selinux-p)
- (tramp-handle-file-selinux-context)
- (tramp-handle-set-file-selinux-context, tramp-process-sentinel)
- (tramp-connectable-p, tramp-open-shell, tramp-get-remote-trash):
- New defuns.
- (with-progress-reporter): New defmacro.
- (tramp-debug-outline-regexp): New defconst.
- (top, 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):
- Use `tramp-compat-funcall'.
- (tramp-handle-make-symbolic-link): Flush file properties.
- (tramp-handle-load, tramp-handle-file-local-copy)
- (tramp-handle-insert-file-contents, tramp-handle-write-region)
- (tramp-handle-vc-registered, tramp-maybe-send-script)
- (tramp-find-shell): Use `with-progress-reporter'.
- (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.
- (tramp-handle-directory-files-and-attributes)
- (tramp-get-remote-path): Use `copy-tree'.
- (tramp-completion-handle-file-name-all-completions): Ensure, that
- non remote files are still checked. Oops.
- (tramp-handle-copy-file, tramp-do-copy-or-rename-file):
- Handle PRESERVE-SELINUX-CONTEXT.
- (tramp-do-copy-or-rename-file): Add progress reporter.
- (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-handle-delete-file): Add TRASH arg.
- (tramp-handle-dired-uncache): Flush directory cache, not only file
- cache.
- (tramp-handle-expand-file-name)
- (tramp-completion-handle-file-name-all-completions)
- (tramp-completion-handle-file-name-completion):
- Use `tramp-connectable-p'.
- (tramp-handle-start-file-process): Set connection property "vec".
- Use it, in order to invalidate file caches. Check only for
- `remote-tty' process property.
- Implement tty setting. (Bug#4604, Bug#6360)
- (tramp-file-name-for-operation): Add `call-process-region' and
- `set-file-selinux-context'.
- (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-file-name-handler): Trace 'quit. 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.
- (tramp-completion-mode-p): Use `non-essential'.
- (tramp-handle-file-name-all-completions): Backward/ XEmacs
- compatibility: Use `completion-ignore-case' if
- `read-file-name-completion-ignore-case' does not exist.
- (tramp-get-debug-buffer): Use `tramp-debug-outline-regexp'.
- (tramp-find-shell, tramp-open-connection-setup-interactive-shell):
- `tramp-open-shell'.
- (tramp-action-password): Hide password prompt before next run.
- (tramp-process-actions): Widen connection buffer for the trace.
- (tramp-open-connection-setup-interactive-shell): Set `remote-tty'
- process property. Trace stty settings if `tramp-verbose' >= 9.
- Apply workaround for IRIX64 bug. Move argument of last
- `tramp-send-command' where it belongs to.
- (tramp-maybe-open-connection): Use `async-args' and `gw-args' in
- front of `login-args'.
- (tramp-get-ls-command, tramp-get-ls-command-with-dired): Run tests
- on "/dev/null" instead of "/".
- (tramp-get-ls-command-with-dired): Make test for "--dired"
- stronger.
- (tramp-set-auto-save-file-modes): Adapt version check.
- (tramp-set-process-query-on-exit-flag): Fix wrong parentheses.
- (tramp-handle-process-file): Call the program in a subshell, in
- order to preserve working directory.
- (tramp-handle-shell-command): Don't use hard-wired "/bin/sh" but
- `tramp-remote-sh' from `tramp-methods'.
- (tramp-get-ls-command): Make test for "--color=never" stronger.
- (tramp-check-for-regexp): Use (forward-line 1).
-
- * net/trampver.el: Update release number.
-
-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-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-22 Leo <sdl.web@gmail.com>
-
- * net/rcirc.el (rcirc-add-or-remove): Accept a list of elements.
- (ignore, bright, dim, keyword): Split list of nicknames before
- passing to rcirc-add-or-remove (Bug#6894).
-
-2010-08-22 Chong Yidong <cyd@stupidchicken.com>
-
- * 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>
-
- Fix buffer-list rename&refresh after killing a buffer in ido.
- * 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.
- * iswitchb.el (iswitchb-kill-buffer): Re-make the list.
-
-2010-08-21 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>
-
- * subr.el (read-key): Don't echo keystrokes (bug#6883).
-
-2010-08-21 Glenn Morris <rgm@gnu.org>
-
- * menu-bar.el (menu-bar-games-menu): Add landmark.
-
-2010-08-20 Glenn Morris <rgm@gnu.org>
-
- * align.el (align-regexp): Make group and spacing arguments
- use the interactive defaults when non-interactive. (Bug#6698)
-
- * mail/rmail.el (rmail-forward): Replace mail-text-start with its
- expansion, so as not to need sendmail.
- (mail-text-start): Remove declaration.
- (rmail-retry-failure): Require sendmail.
-
-2010-08-19 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * subr.el (read-key): Don't hide the menu-bar entries (bug#6881).
-
-2010-08-18 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>
-
- * files.el: Add `word-wrap' as safe local variable.
-
-2010-08-18 Glenn Morris <rgm@gnu.org>
-
- * woman.el (woman-translate): Case matters. (Bug#6849)
-
-2010-08-14 Chong Yidong <cyd@stupidchicken.com>
-
- * simple.el (kill-region): Doc fix (Bug#6787).
-
-2010-08-14 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>
-
- * subr.el (ignore-errors): Add debug declaration.
-
-2010-08-09 Geoff Gole <geoffgole@gmail.com> (tiny change)
-
- * whitespace.el (whitespace-color-off): Remove post-command-hook
- locally.
-
-2010-08-08 Johan Bockgård <bojohan@gnu.org>
-
- * replace.el (replace-highlight): Bind isearch-forward and
- isearch-error, ensuring that highlighting is updated if the user
- switches the search direction (Bug#6808).
-
- * isearch.el (isearch-lazy-highlight-forward): New var.
- (isearch-lazy-highlight-new-loop, isearch-lazy-highlight-search):
- (isearch-lazy-highlight-update): Use it.
-
-2010-08-06 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.
-
-2010-08-05 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>
+2011-05-12 Glenn Morris <rgm@gnu.org>
- * language/cyrillic.el: Don't add "microsoft-cp1251" to
- ctext-non-standard-encodings-alist here.
+ * emacs-lisp/bytecomp.el (byte-compile-file-form-defmumble):
+ Let byte-compile-initial-macro-environment always take precedence.
- * international/mule.el (ctext-non-standard-encodings-alist):
- Add "koi8-r" and "microsoft-cp1251".
- (ctext-standard-encodings): New variable.
- (ctext-non-standard-encodings-table): List only elements for
- non-standard encodings.
- (ctext-pre-write-conversion): Adjust for the above change.
- Check ctext-standard-encodings.
+2011-05-12 Stefan Monnier <monnier@iro.umontreal.ca>
- * international/mule-conf.el (compound-text): Doc fix.
- (ctext-no-compositions): Doc fix.
- (compound-text-with-extensions): Doc fix.
+ * net/rcirc.el: Add support for SSL/TLS connections.
+ (rcirc-server-alist): New field `encryption'.
+ (rcirc): Check `encryption' settings.
+ (rcirc-connect): New arg `encryption'. Use open-network-stream.
+ Merge make-local-variable into `set'.
+ (rcirc--connection-open-p): New function.
+ (rcirc-send-string, rcirc-clean-up-buffer): Use it to handle case where
+ the process is not a network process (e.g. running gnutls-cli).
+ (set-rcirc-decode-coding-system, set-rcirc-encode-coding-system):
+ Make rcirc-(en|de)code-coding-system local here.
+ (rcirc-mode): Merge make-local-variable into `set'.
+ (rcirc-parent-buffer): Make permanent buffer-local.
+ (rcirc-multiline-minor-mode): Don't do it here.
+ (rcirc-switch-to-server-buffer): Don't switch to a random buffer if
+ there's no server buffer.
-2010-08-04 Stefan Monnier <monnier@iro.umontreal.ca>
+2011-05-11 Glenn Morris <rgm@gnu.org>
- * simple.el (exchange-dot-and-mark): Mark obsolete, finally.
+ * newcomment.el (comment-kill): Prefix "unused" local.
-2010-08-03 Juanma Barranquero <lekktu@gmail.com>
+ * term/w32console.el (get-screen-color): Declare.
- * progmodes/which-func.el (which-func-format): Split help-echo text
- into lines, like other mode-line tooltips.
+ * emacs-lisp/bytecomp.el (byte-compile-arglist-warn):
+ Handle symbol elements of byte-compile-initial-macro-environment.
- * server.el (server-start): When using TCP sockets, force IPv4
- and use a literal 127.0.0.1 for localhost. (Related to bug#6781.)
+2011-05-10 Leo Liu <sdl.web@gmail.com>
-2010-08-02 Stefan Monnier <monnier@iro.umontreal.ca>
+ * bookmark.el (bookmark-bmenu-mode-map):
+ Bind bookmark-bmenu-search to `/'.
- * bindings.el (complete-symbol): Run completion-at-point as a fallback.
+ * mail/footnote.el: Convert to utf-8 encoding.
+ (footnote-unicode-string, footnote-unicode-regexp): New variable.
+ (Footnote-unicode): New function.
+ (footnote-style-alist): Add unicode style to the list.
+ (footnote-style): Doc fix.
-2010-08-02 Juanma Barranquero <lekktu@gmail.com>
+2011-05-10 Glenn Morris <rgm@gnu.org>
+ Stefan Monnier <monnier@iro.umontreal.ca>
- * 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>
-
- * bindings.el (function-key-map): Add a S-tab => backtab fallback.
-
-2010-08-01 Juanma Barranquero <lekktu@gmail.com>
-
- * dabbrev.el (dabbrev-completion): Fix typo in docstring.
-
-2010-08-01 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>
-
- * eshell/esh-io.el (eshell-get-target): Better detection of
- read-only file (Bug#6762).
-
-2010-07-30 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>
-
- * help-fns.el (find-lisp-object-file-name): Doc fix (bug#6494).
-
-2010-07-19 Juanma Barranquero <lekktu@gmail.com>
-
- * 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)
-
- * 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>
-
- * dired.el (dired-buffers-for-dir): Handle list values of
- dired-directory (Bug#6636).
-
-2010-07-16 Reiner Steib <Reiner.Steib@gmx.de>
-
- * 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)
-
-2010-07-16 Eli Zaretskii <eliz@gnu.org>
-
- * mail/rmailmm.el (rmail-mime-save): Make the temp buffer
- unibyte, so compressed attachments are not compressed again.
-
-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).
-
-2010-07-14 Chong Yidong <cyd@stupidchicken.com>
-
- * simple.el (push-mark-command): Set the selection if
- select-active-regions is non-nil.
-
-2010-07-10 Glenn Morris <rgm@gnu.org>
-
- * calendar/calendar.el (calendar-week-end-day): New function.
- * calendar/cal-tex.el (cal-tex-cursor-month): Remove unused vars.
- Respect calendar-week-start-day. (Bug#6606)
- (cal-tex-insert-day-names, cal-tex-insert-blank-days)
- (cal-tex-insert-blank-days-at-end): Respect calendar-week-start-day.
- (cal-tex-first-blank-p, cal-tex-last-blank-p): Simplify, and
- respect calendar-week-start-day.
-
-2010-07-10 Chong Yidong <cyd@stupidchicken.com>
-
- * simple.el (use-region-p): Doc fix (Bug#6607).
-
-2010-07-07 Christoph Scholtes <cschol2112@gmail.com>
-
- * progmodes/python.el (python-font-lock-keywords): Add Python 2.7
- builtins (BufferError, BytesWarning, WindowsError; callables
- bin, bytearray, bytes, format, memoryview, next, print; __package__).
-
-2010-07-07 Glenn Morris <rgm@gnu.org>
-
- * play/zone.el (zone-fall-through-ws): Fix next-line ->
- forward-line fallout.
-
-2010-07-06 Chong Yidong <cyd@stupidchicken.com>
-
- * mouse.el (mouse-appearance-menu): Add docstring.
-
- * help.el (describe-key): Print up-event using key-description.
-
-2010-07-03 Michael Albinus <michael.albinus@gmx.de>
-
- * net/zeroconf.el (zeroconf-resolve-service)
- (zeroconf-service-resolver-handler): Use `dbus-byte-array-to-string'.
- (zeroconf-publish-service): Use `dbus-string-to-byte-array'.
-
-2010-07-03 Jan Moringen <jan.moringen@uni-bielefeld.de>
-
- * net/zeroconf.el (zeroconf-service-remove-hook): New defun.
-
-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
- cases that cause insertion.
- (vc-dir-resynch-file): Tell vc-dir-update to avoid inserting files
- with a nil state.
-
-2010-06-30 Chong Yidong <cyd@stupidchicken.com>
-
- * xml.el (xml-parse-region): Avoid infloop (Bug#5281).
-
-2010-06-29 Leo <sdl.web@gmail.com>
-
- * emacs-lisp/rx.el (rx): Doc fix. (Bug#6537)
-
-2010-06-27 Oleksandr Gavenko <gavenkoa@gmail.com> (tiny change)
-
- * generic-x.el (bat-generic-mode): Fix regexp for command line
- switches (Bug#5719).
-
-2010-06-27 Masatake YAMATO <yamato@redhat.com>
-
- * htmlfontify.el (hfy-face-attr-for-class): Use append instead
- of nconc to avoid pure storage error (Bug#6239).
-
-2010-06-27 Christoph <cschol2112@googlemail.com> (tiny change)
-
- * bookmark.el (bookmark-bmenu-2-window, bookmark-bmenu-other-window)
- (bookmark-bmenu-other-window-with-mouse): Remove unnecessary
- bindings of bookmark-automatically-show-annotations (Bug#6515).
-
-2010-06-25 Eli Zaretskii <eliz@gnu.org>
-
- * arc-mode.el (archive-zip-extract): Don't quote the file name on
- MS-Windows and MS-DOS. (Bug#6467, Bug#6144)
-
-2010-06-24 Štěpán Němec <stepnem@gmail.com> (tiny change)
-
- * comint.el (make-comint, make-comint-in-buffer): Mention return
- value in the docstrings. (Bug#6498)
-
-2010-06-24 Yoni Rabkin <yoni@rabkins.net>
-
- * bs.el (bs-mode-font-lock-keywords): Remove "by" from Dired pattern,
- since it is not present when using some non-default switches.
-
-2010-06-23 Karl Fogel <kfogel@red-bean.com>
-
- * simple.el (compose-mail): Fix doc string to refer to
- `compose-mail-user-agent-warnings', instead of to the
- nonexistent `compose-mail-check-user-agent'.
-
-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
- 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
- ambiguity with the revision.
- (vc-git-previous-revision): Pass a relative file name.
-
-2010-06-22 Glenn Morris <rgm@gnu.org>
-
- * progmodes/js.el (js-mode-map): Use standard capitalization and
- ellipses for menu entries.
-
- * wid-edit.el (widget-complete): Doc fix.
-
-2010-06-22 Jürgen Hötzel <juergen@hoetzel.info> (tiny change)
-
- * wid-edit.el (widget-complete): Fix typo in 2009-12-02 change.
-
-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 backend. Use it when non-nil.
- (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):
- 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
- the VC backend. Use it when non-nil.
- * 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):
- Remove trailing whitespace. Suggested by Eric Hanchrow. (Bug#6481)
-
-2010-06-20 Alan Mackenzie <acm@muc.de>
-
- * progmodes/cc-mode.el (c-before-hack-hook): When the mode is set
- in file local variables, set it first.
-
-2010-06-19 Glenn Morris <rgm@gnu.org>
-
- * descr-text.el (describe-char-unicode-data): Insert separating
- space when needed. (Bug#6422)
-
- * progmodes/idlwave.el (idlwave-action-and-binding):
- Fix typo in 2009-12-03 change. (Bug#6450)
-
-2010-06-17 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * subr.el (read-quoted-char): Fix up last change (bug#6290).
-
-2010-06-16 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * 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).
- (font-lock-set-defaults):
- * 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>
-
- * vc-annotate.el (vc-annotate): Use vc-read-revision.
-
-2010-06-15 Glenn Morris <rgm@gnu.org>
-
- * calendar/appt.el (appt-time-msg-list): Doc fix.
- (appt-check): Let-bind appt-warn-time.
- (appt-add): Make the 3rd argument optional.
- 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>
-
- * 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)
-
- * 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>
-
- * emacs-lisp/cl-macs.el (destructuring-bind): Bind `bind-enquote',
- used by cl-do-arglist. (Bug#6408)
-
-2010-06-09 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * emacs-lisp/advice.el (ad-compile-function):
- Define warning-suppress-types before we let-bind it (bug#6275).
-
- * vc-dispatcher.el: Rename mode-line-hook to vc-mode-line-hook;
- declare it, make it buffer-local and permanent-local (bug#6324).
- (vc-resynch-window): Adjust name.
- * vc-hooks.el (vc-find-file-hook): Adjust name.
-
-2010-06-07 Jonathan Rockway <jon@jrock.us>
-
- * 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-05 Juanma Barranquero <lekktu@gmail.com>
-
- * net/dbus.el (dbus-register-method): Declare function.
- (dbus-handle-event, dbus-property-handler): Fix typos in docstrings.
- (dbus-introspect): Doc fix.
- (dbus-event-bus-name, dbus-introspect-get-interface)
- (dbus-introspect-get-argument): Reflow docstrings.
-
-2010-06-04 Chong Yidong <cyd@stupidchicken.com>
-
- * term/common-win.el (x-colors): Add "dark green" and "dark
- turquoise" (Bug#6332).
-
-2010-06-03 Glenn Morris <rgm@gnu.org>
-
- * desktop.el (desktop-clear-preserve-buffers):
- Add "*Warnings*" buffer. (Bug#6336)
-
-2010-06-02 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc-dir.el (vc-dir-update): Remove entries with a nil state (bug#5539).
-
-2010-06-01 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * vc-bzr.el (vc-bzr-revision-completion-table): Apply
- `file-directory-p' to the filename part rather than to the whole text.
-
-2010-05-31 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * man.el (Man-completion-table): Let the user type "-k " (bug#6319).
-
-2010-05-31 Drew Adams <drew.adams@oracle.com>
-
- * files.el (directory-files-no-dot-files-regexp): Doc fix (bug#6298).
-
-2010-05-31 Juanma Barranquero <lekktu@gmail.com>
-
- * subr.el (momentary-string-display): Just use read-event to read
- the exit event (Bug#6238).
-
-2010-05-29 Chong Yidong <cyd@stupidchicken.com>
-
- * ansi-color.el: Delete unused escape sequences (Bug#6085).
- (ansi-color-drop-regexp): New constant.
- (ansi-color-apply, ansi-color-filter-region)
- (ansi-color-apply-on-region): Delete unrecognized control sequences.
- (ansi-color-apply): Build string list before calling concat.
-
-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 Masatake YAMATO <yamato@redhat.com>
-
- * htmlfontify.el (hfy-face-resolve-face): New function.
- (hfy-face-to-style): Use it (Bug#6279).
-
-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)
-
- * textmodes/fill.el (fill-region): Don't fill past the end (bug#6201).
-
-2010-05-18 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * subr.el (read-quoted-char): Resolve modifiers after key
- remapping (bug#6212).
-
-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).
-
-2010-05-10 Glenn Morris <rgm@gnu.org>
-
- * desktop.el (desktop-save-buffer-p): Don't mistakenly include
- all dired buffers, even tramp ones. (Bug#5755) [Backport from trunk]
-
-2010-05-07 Chong Yidong <cyd@stupidchicken.com>
-
- * Version 23.2 released.
-
-2010-05-03 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>
-
- * 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>
-
- * composite.el (compose-region, reference-point-alist): Fix typos
- in the doc strings.
-
-2010-04-28 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>
-
- * abbrev.el (last-abbrev-text): Doc fix.
- (abbrev-prefix-mark): Don't escape parenthesis.
-
-2010-04-24 Andreas Schwab <schwab@linux-m68k.org>
-
- * composite.el (find-composition): Doc fix.
-
-2010-04-24 Juanma Barranquero <lekktu@gmail.com>
-
- * progmodes/sql.el (sql-electric-stuff): Fix typo in tag.
- (sql-oracle-program, sql-sqlite-options)
- (sql-query-placeholders-and-send): Doc fixes.
- (sql-set-product, sql-interactive-mode): Reflow docstrings.
- (sql-imenu-generic-expression, sql-buffer)
- (sql-mode-ansi-font-lock-keywords, 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-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-ingres, sql-ms, sql-postgres, sql-interbase, sql-db2, sql-linter):
- Fix typos in docstrings.
-
-2010-04-23 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>
-
- * image-mode.el (image-mode-as-text): Fix typo in docstring.
+ * files.el (hack-one-local-variable-eval-safep):
+ Consider "eval: (foo-mode)" to be safe. (Bug#8613)
-2010-04-23 Juanma Barranquero <lekktu@gmail.com>
+2011-05-10 Glenn Morris <rgm@gnu.org>
- * filecache.el (file-cache-add-directory-list)
- (file-cache-add-directory-recursively): Fix typos in docstrings.
+ * calendar/diary-lib.el (diary-list-entries-hook)
+ (diary-mark-entries-hook, diary-nongregorian-listing-hook)
+ (diary-nongregorian-marking-hook, diary-list-entries)
+ (diary-include-other-diary-files, diary-mark-entries)
+ (diary-mark-included-diary-files): Doc fixes.
-2010-04-22 Kenichi Handa <handa@m17n.org>
+2011-05-09 Juanma Barranquero <lekktu@gmail.com>
- * language/indian.el (gurmukhi-composable-pattern): Fix typo.
- (gujarati-composable-pattern): Fix typo.
+ * misc.el: Require tabulated-list.el during compilation.
-2010-04-20 Kenichi Handa <handa@m17n.org>
+2011-05-09 Chong Yidong <cyd@stupidchicken.com>
- * language/indian.el (oriya-composable-pattern)
- (tamil-composable-pattern, malayalam-composable-pattern):
- Add two-part vowels to "v" (vowel sign).
+ * progmodes/compile.el (compilation-start):
+ Run compilation-filter-hook for the async case too.
+ (compilation-filter-hook): Doc fix.
-2010-04-20 Chong Yidong <cyd@stupidchicken.com>
+2011-05-09 Deniz Dogan <deniz@dogan.se>
- * files.el (copy-directory): Handle symlinks (Bug#5982).
+ * wdired.el: Remove outdated installation comment. Fix usage
+ comment.
- * progmodes/compile.el (compilation-next-error-function):
- Revert 2009-10-12 change (Bug#5983).
+2011-05-09 Juanma Barranquero <lekktu@gmail.com>
-2010-04-20 Dan Nicolaescu <dann@ics.uci.edu>
+ * misc.el: Implement new command `list-dynamic-libraries'.
+ (list-dynamic-libraries--loaded-only-p): New variable.
+ (list-dynamic-libraries--refresh): New function.
+ (list-dynamic-libraries): New command.
- * 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>
-
- * 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>
-
- 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>
-
- * htmlfontify.el (htmlfontify-buffer)
- (htmlfontify-copy-and-link-dir): Autoload entry points.
-
-2010-04-17 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>
-
- * vc-git.el (vc-git-print-log): Doc fix.
-
-2010-04-14 Óscar Fuentes <ofv@wanadoo.es>
-
- * ido.el (ido-file-internal): Fix 2009-12-02 change.
-
-2010-04-14 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>
-
- * 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>
-
- * language/indian.el (malayalam-composable-pattern): Fix previous
- change (add U+0D4D "SIGN VIRAMA").
- (oriya-composable-pattern): Add U+0B30 and fix typo in the regexp.
- (tamil-composable-pattern): Fix typo in the regexp.
- (telugu-composable-pattern): Fix U+0C4D and typo in the regexp.
- (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>
-
- * textmodes/tex-mode.el (latex-mode): Revert 2008-03-03 change to
- paragraph-separate (Bug#5821).
-
-2010-04-05 Juri Linkov <juri@jurta.org>
-
- Put breadcrumbs on overlay instead of inserting to buffer (bug#5809).
-
- * info.el (Info-find-node-2): Comment out code that skips
- breadcrumbs line.
- (Info-mouse-follow-link): New command.
- (Info-link-keymap): New keymap.
- (Info-breadcrumbs): Rename from `Info-insert-breadcrumbs'.
- Return a string with links instead of inserting breadcrumbs
- to the Info buffer.
- (Info-fontify-node): Comment out code that inserts breadcrumbs.
- Instead of putting the `invisible' text property over the Info
- header, make an overlay over the Info header with the `invisible'
- property and `after-string' set to the string returned by
- `Info-breadcrumbs'.
-
-2010-04-03 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>
-
- * 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>
-
- * language/sinhala.el (composition-function-table): Fix regexp for
- the new Unicode specification.
-
- * language/indian.el (devanagari-composable-pattern)
- (tamil-composable-pattern, kannada-composable-pattern)
- (malayalam-composable-pattern): Adjust for the new Unicode
- specification.
- (bengali-composable-pattern, gurmukhi-composable-pattern)
- (gujarati-composable-pattern, oriya-composable-pattern)
- (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>
-
- 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>
-
- * progmodes/js.el (js-auto-indent-flag, js-mode-map)
- (js-insert-and-indent): Revert 2009-08-15 change, restoring
- electric punctuation for "{}();,:" (Bug#5586).
-
- * mail/sendmail.el (mail-default-directory): Doc fix.
-
-2010-03-27 Chong Yidong <cyd@stupidchicken.com>
-
- * mail/sendmail.el (mail-default-directory): Doc fix.
-
-2010-03-27 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>
-
- * vc.el (vc-root-diff): Doc fix.
-
-2010-03-25 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>
-
- * simple.el (append-to-buffer): Ensure that point is preserved if
- BUFFER is the current buffer. Suggested by YAMAMOTO Mitsuharu.
- (Bug#5749)
-
-2010-03-24 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * 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.
-
-2010-03-24 Juanma Barranquero <lekktu@gmail.com>
-
- * faces.el (set-face-attribute): Fix typo in docstring.
- (face-valid-attribute-values): Reflow docstring.
-
-2010-03-23 Glenn Morris <rgm@gnu.org>
-
- * textmodes/flyspell.el (sgml-lexical-context): Autoload it (Bug#5752).
-
-2010-03-21 Chong Yidong <cyd@stupidchicken.com>
-
- * indent.el (indent-for-tab-command): Doc fix.
-
-2010-03-22 Juanma Barranquero <lekktu@gmail.com>
-
- * image-dired.el (image-dired-display-thumbs): Fix typo in docstring.
- (image-dired-read-comment): Doc fix.
-
- * json.el (json-object-type, json-array-type, json-key-type)
- (json-false, json-null, json-read-number):
- * minibuffer.el (completion-in-region-functions):
- * calendar/cal-tex.el (cal-tex-daily-end, cal-tex-number-weeks)
- (cal-tex-cursor-week):
- * emacs-lisp/trace.el (trace-function):
- * eshell/em-basic.el (eshell/printnl):
- * eshell/em-dirs.el (eshell-last-dir-ring, eshell-parse-drive-letter)
- (eshell-read-last-dir-ring, eshell-write-last-dir-ring):
- * obsolete/levents.el (allocate-event, event-key, event-object)
- (event-point, event-process, event-timestamp, event-to-character)
- (event-window, event-x, event-x-pixel, event-y, event-y-pixel):
- * textmodes/reftex-vars.el (reftex-index-macros-builtin)
- (reftex-section-levels, reftex-auto-recenter-toc, reftex-toc-mode-hook)
- (reftex-cite-punctuation, reftex-search-unrecursed-path-first)
- (reftex-highlight-selection): Fix typos in docstrings.
-
-2010-03-19 Juanma Barranquero <lekktu@gmail.com>
-
- * minibuffer.el (completion-in-region-functions): Fix docstring typos.
-
-2010-03-18 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>
-
- * 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>
-
- * language/indian.el (devanagari-composable-pattern): Add more
- consonants.
-
-2010-03-14 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>
-
- * net/tramp.el (tramp-find-executable):
- Use `tramp-get-connection-buffer'. Make the regexp for checking
- output of "wc -l" more robust.
- (tramp-find-shell): Use another shell but /bin/sh on OpenSolaris.
- (tramp-open-connection-setup-interactive-shell): Remove workaround
- for OpenSolaris bug, it is not needed anymore.
-
-2010-03-12 Glenn Morris <rgm@gnu.org>
-
- * emacs-lisp/cl-macs.el (defsubst*): Add autoload cookie. (Bug#4427)
-
-2010-03-11 Wilson Snyder <wsnyder@wsnyder.org>
-
- * files.el (auto-mode-alist): Accept more verilog file patterns.
-
-2010-03-09 Miles Bader <miles@gnu.org>
-
- * vc-git.el (vc-git-print-log): Use "tformat:" for shortlog,
- instead of "format:"; this ensures that the output is
- newline-terminated.
-
-2010-03-08 Chong Yidong <cyd@stupidchicken.com>
-
- * mail/rfc822.el (rfc822-addresses): Use nested catches to ensure
- that all errors are caught, and that the return value is always a
- list (Bug#5692).
-
-2010-03-08 Kenichi Handa <handa@m17n.org>
-
- * language/misc-lang.el (windows-1256): New coding system.
- (cp1256): New alias of windows-1256 (bug#5690).
-
-2010-03-07 Andreas Schwab <schwab@linux-m68k.org>
-
- * mail/rfc822.el (rfc822-addresses): Move catch clause down around
- call to rfc822-bad-address. (Bug#5692)
-
-2010-03-07 Štěpán Němec <stepnem@gmail.com> (tiny change)
-
- * vc-git.el (vc-git-annotate-extract-revision-at-line):
- Use vc-git-root as default directory for revision path (Bug#5657).
-
-2010-03-06 Chong Yidong <cyd@stupidchicken.com>
-
- * calculator.el (calculator): Don't bind split-window-keep-point
- (Bug#5674).
-
-2010-03-06 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * vc-git.el: Re-flow to fit into 80 columns.
- (vc-git-after-dir-status-stage, vc-git-dir-status-goto-stage):
- Remove spurious `quote' element in each case alternative.
- (vc-git-show-log-entry): Use prog1.
- (vc-git-after-dir-status-stage): Remove unused var `remaining'.
-
-2010-03-05 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * man.el (Man-files-regexp): Tighten up the regexp (bug#5686).
-
-2010-03-03 Chong Yidong <cyd@stupidchicken.com>
-
- * macros.el (insert-kbd-macro): Look up keyboard macro using the
- definition, not the name (Bug#5481).
-
-2010-03-03 Štěpán Němec <stepnem@gmail.com> (tiny change)
-
- * subr.el (momentary-string-display): Don't overwrite the MESSAGE
- argument with a local variable. (Bug#5670)
-
-2010-03-02 Juri Linkov <juri@jurta.org>
-
- * info.el (Info-index-next): Decrement line number by 2. (Bug#5652)
-
-2010-03-02 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-do-copy-or-rename-file-out-of-band): Fix an
- error when FILENAME and NEWNAME are existing remote directories.
-
- * net/tramp-compat.el (tramp-compat-make-temp-file): Add optional
- parameter DIR-FLAG.
-
-2010-03-02 Glenn Morris <rgm@gnu.org>
-
- * calendar/cal-hebrew.el (holiday-hebrew-passover): Fix date
- of Yom HaAtzma'ut when it falls on a Monday (rule changed in 2004).
-
-2010-03-01 Kenichi Handa <handa@m17n.org>
-
- * language/burmese.el (burmese-composable-pattern): Rename from
- myanmar-composable-pattern.
-
- * international/characters.el (script-list):
- * international/fontset.el (script-representative-chars):
- Change myanmar to burmese.
- (otf-script-alist): Likewise.
- (setup-default-fontset): Likewise. Re-fix :otf spec.
-
-2010-02-28 Katsumi Yamaoka <yamaoka@jpl.org>
-
- * menu-bar.el (menu-bar-manuals-menu): Fix typo.
-
-2010-02-28 Jan Djärv <jan.h.d@swipnet.se>
-
- * scroll-bar.el (scroll-bar-drag-1): Add save-excursion, bug #5654.
-
-2010-02-28 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-handle-write-region): START can be a string.
- Take care in the checks. Reported by Dan Davison
- <davison@stats.ox.ac.uk>.
-
-2010-02-28 Michael Albinus <michael.albinus@gmx.de>
-
- * net/dbus.el (dbus-introspect, dbus-get-property)
- (dbus-set-property, dbus-get-all-properties):
- Use `dbus-call-method' when noninteractive. (Bug#5645)
-
-2010-02-28 Chong Yidong <cyd@stupidchicken.com>
-
- * textmodes/reftex-toc.el (reftex-toc-promote-prepare):
- * emacs-lisp/elint.el (elint-add-required-env):
- * calendar/icalendar.el (icalendar--add-diary-entry):
- * calc/calcalg2.el (math-tracing-integral):
- * files.el (recover-session-finish): Use with-current-buffer
- instead of save-excursion.
-
-2010-02-27 Stefan Monnier <monnier@iro.umontreal.ca>
-
- Fix in-buffer completion when after-change-functions modify the buffer.
- * minibuffer.el (completion--replace): New function.
- (completion--do-completion): Use it and use relative movement.
-
-2010-02-27 Chong Yidong <cyd@stupidchicken.com>
-
- * international/fontset.el (setup-default-fontset): Fix :otf spec.
-
-2010-02-27 Jeremy Whitlock <jcscoobyrs@gmail.com> (tiny change)
-
- * progmodes/python.el (python-pdbtrack-stack-entry-regexp):
- Allow the characters _<> in the stack entry (Bug#5653).
-
-2010-02-26 Kenichi Handa <handa@m17n.org>
-
- * language/burmese.el: Fix entries in composition-function-table.
- (myanmar-composable-pattern): New variable.
-
- * international/fontset.el (setup-default-fontset): Add an entry
- for myanmar.
-
- * international/characters.el (script-list): Add Myanmar
- Extended-A.
-
-2010-02-26 Glenn Morris <rgm@gnu.org>
-
- * custom.el (custom-initialize-delay): Doc fix.
-
- * mail/sendmail.el (send-mail-function): Autoload the call
- to custom-initialize-delay, not otherwise preserved in loaddefs.el.
-
-2010-02-24 Chong Yidong <cyd@stupidchicken.com>
-
- * 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
- setting the modes by `ignore-errors'. It might fail, for example
- if the file is not owned by the user but the group.
- (tramp-handle-write-region): Ensure, that `tmpfile' is always readable.
-
-2010-02-21 Chong Yidong <cyd@stupidchicken.com>
-
- * files.el (directory-listing-before-filename-regexp):
- Use stricter matching for iso-style dates, to avoid false matches with
- date-like filenames (Bug#5597).
-
- * htmlfontify.el (htmlfontify): Doc fix.
-
- * eshell/eshell.el (eshell): Doc fix.
-
- * startup.el (fancy-about-screen): In mode-line, apply
- mode-line-buffer-id face only to the buffer name (Bug#5613).
-
-2010-02-20 Kevin Ryde <user42@zip.com.au>
+2011-05-09 Chong Yidong <cyd@stupidchicken.com>
* progmodes/compile.el (compilation-error-regexp-alist-alist):
- In `watcom' anchor regexp to start of line, to avoid slowness
- (Bug#5599).
-
-2010-02-20 Eli Zaretskii <eliz@gnu.org>
-
- * subr.el (remove-yank-excluded-properties): Explain in a comment
- why `category' property is removed.
-
-2010-02-19 Chong Yidong <cyd@stupidchicken.com>
-
- * isearch.el (isearch-update-post-hook, isearch-update):
- Revert 2010-02-17 change.
-
-2010-02-19 Ulf Jasper <ulf.jasper@web.de>
-
- * calendar/icalendar.el (icalendar--convert-ordinary-to-ical)
- (icalendar--convert-weekly-to-ical)
- (icalendar--convert-yearly-to-ical)
- (icalendar--convert-block-to-ical)
- (icalendar--convert-cyclic-to-ical)
- (icalendar--convert-anniversary-to-ical): Take care of time
- specifications where hour has 1-digit only (Bug#5549).
-
-2010-02-19 Nick Roberts <nickrob@snap.net.nz>
-
- * progmodes/gdb-ui.el (gdb-assembler-handler): Accommodate change
- of disassemble output in GDB 7.1.
-
-2010-02-19 Glenn Morris <rgm@gnu.org>
-
- * progmodes/f90.el (f90-electric-insert): Give it a delete-selection
- property. (Bug#5593)
-
-2010-02-18 Sam Steingold <sds@gnu.org>
-
- * vc-cvs.el (vc-cvs-merge-news): Yet another fix of message parsing.
-
-2010-02-18 Stefan Monnier <monnier@iro.umontreal.ca>
-
- Use abbreviated file names in bookmarks (bug#5591).
- * bookmark.el (bookmark-maybe-load-default-file): Remove redundant
- calls to expand-file-name.
- (bookmark-relocate): Use abbreviated file names in bookmarks.
- (bookmark-load): Use abbreviated file names in messages.
-
-2010-02-18 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-handle-directory-files): When FULL, do not
- expand "." and "..". Reported by Thierry Volpiatto
- <thierry.volpiatto@gmail.com>.
-
-2010-02-18 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-handle-insert-file-contents): Set always the
- permissions of the temporary file to "0600". In case the remote
- file has no read permissions for the owner, there might be
- problems otherwise. Reported by Ole Laursen <olau@iola.dk>.
-
-22010-02-18 Glenn Morris <rgm@gnu.org>
-
- * emacs-lisp/authors.el (authors-renamed-files-alist):
- Add entries for INSTALL.CVS.
-
-2010-02-17 Mark A. Hershberger <mah@everybody.org>
-
- * vc-bzr.el: Fix typo in Known Bugs section.
-
- * isearch.el (isearch-update-post-hook): New hook.
- (isearch-update): Use the new hook.
-
-2010-02-16 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-do-copy-or-rename-file-out-of-band):
- Fix errors in copying directories.
- (tramp-handle-add-name-to-file, tramp-handle-copy-directory)
- (tramp-do-copy-or-rename-file, tramp-handle-delete-directory)
- (tramp-handle-delete-file)
- (tramp-handle-dired-recursive-delete-directory)
- (tramp-handle-write-region): Flush also the cache for the upper
- directory.
-
-2010-02-16 Chong Yidong <cyd@stupidchicken.com>
-
- * simple.el (save-interprogram-paste-before-kill): Doc fix.
-
- * cus-edit.el (hardware): Doc fix.
-
- * man.el (man): Add to external custom group.
-
- * delim-col.el (columns): Move to wp custom group.
-
- * doc-view.el (doc-view): Add to data custom group.
-
- * nxml/nxml-mode.el (nxml-faces): Remove from font-lock-faces group.
-
- * textmodes/flyspell.el (flyspell-word): Obey the offset specified
- by ispell-parse-output (Bug#5575).
-
-2010-02-16 Kenichi Handa <handa@m17n.org>
-
- * international/ja-dic-cnv.el (iso-2022-7bit-short): Delete it.
- (skkdic-convert-okuri-ari): Ignore lines starting with '>'.
- (skkdic-convert): Use `euc-japan' coding system for writing.
-
-2010-02-16 Glenn Morris <rgm@gnu.org>
-
- * textmodes/tex-mode.el (tex-bibtex-file): Expand the result of
- tex-main-file before using it. (Bug#5562)
-
-2010-02-15 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * emacs-lisp/advice.el (ad-compile-function): Suppress byte-compiler
- warnings, since it is annoying for the user to see them each time he
- runs the code.
-
-2010-02-15 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-process-actions, tramp-read-passwd):
- * net/tramp-gvfs.el (tramp-gvfs-maybe-open-connection): Use VEC
- instead of PROC for caching "first-password-request". Otherwise,
- new processes would not profit from passwords already entered.
-
- * net/tramp-cache.el (tramp-dump-connection-properties):
- Don't save "first-password-request" property.
-
-2010-02-14 Juanma Barranquero <lekktu@gmail.com>
-
- * outline.el (outline-head-from-level):
- * simple.el (with-wrapper-hook):
- * emacs-lisp/elint.el (elint-extra-errors, elint-current-buffer)
- (elint-defun, elint-buffer-env, elint-top-form-logged)
- (elint-unbound-variable):
- * textmodes/reftex-toc.el (reftex-toc-newhead-from-alist):
- Fix typos in docstrings.
-
-2010-02-14 Michael Albinus <michael.albinus@gmx.de>
-
- * files.el (insert-directory): When WILDCARD-REGEXP and
- FULL-DIRECTORY-P are nil, insert the file entry instead of the
- whole directory. (Bug#5551)
-
- * net/ange-ftp.el (ange-ftp-insert-directory): Insert " " for
- dired's alignment sanity. (Bug#5516)
-
-2010-02-14 Juri Linkov <juri@jurta.org>
-
- * man.el (Man-fontify-manpage, Man-cleanup-manpage):
- Remove remaining ^H with their preceding chars. (Bug#5566)
-
-2010-02-13 Glenn Morris <rgm@gnu.org>
-
- * simple.el (transpose-subr): Give it a doc-string.
-
- * textmodes/paragraphs.el (transpose-paragraphs, transpose-sentences):
- Doc fixes.
-
-2010-02-12 Juri Linkov <juri@jurta.org>
-
- * arc-mode.el (archive-unique-fname): Make directories for nested
- archives. (Bug#5540)
-
-2010-02-12 Juri Linkov <juri@jurta.org>
-
- * ffap.el (dired-at-point): Fix docstring. (Bug#5565)
-
-2010-02-11 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * subr.el (copy-overlay): Handle deleted overlays.
-
- * man.el (Man-completion-table): Don't signal an error if we can't run
- manual-program (bug#4056).
-
-2010-02-10 Juanma Barranquero <lekktu@gmail.com>
-
- * textmodes/artist.el (artist-mt): Fix typos in docstring.
-
-2010-02-10 Thierry Volpiatto <thierry.volpiatto@gmail.com>
-
- * info.el (Info-bookmark-jump): Simplify.
-
- * bookmark.el (bookmark-handle-bookmark): Catch the right error.
- (bookmark-default-handler): Accept new bookmark field `buffer'.
-
-2010-02-10 Chong Yidong <cyd@stupidchicken.com>
-
- * iswitchb.el (iswitchb-completions): Revert last change.
-
-2010-02-10 Michael Albinus <michael.albinus@gmx.de>
-
- * ls-lisp.el (ls-lisp-insert-directory): When WILDCARD-REGEXP and
- FULL-DIRECTORY-P are nil, and FILE is absolute, expand it.
- This prevents file names like "~/" being listed literally.
-
-2010-02-10 Dan Nicolaescu <dann@ics.uci.edu>
-
- * term/xterm.el (xterm-maybe-set-dark-background-mode):
- Remove dead code. (Bug#5546)
-
-2010-02-09 Chong Yidong <cyd@stupidchicken.com>
-
- * eshell/em-ls.el (eshell-ls-applicable): Frob file attributes
- correctly (Bug#5548).
-
-2010-02-08 Jose E. Marchesi <jemarch@gnu.org>
-
- * progmodes/ada-mode.el (ada-in-numeric-literal-p): New function.
- (ada-adjust-case): Don't adjust case in hexadecimal number literals.
-
-2010-02-08 Kenichi Handa <handa@m17n.org>
-
- * international/mule-util.el (with-coding-priority): Add autoload
- cookie for putting `lisp-indent-function'.
-
-2010-02-07 Glenn Morris <rgm@gnu.org>
-
- * progmodes/f90.el (f90-font-lock-keywords-1, f90-font-lock-keywords-2):
- Move F2003 named interfaces from keywords-2 to keywords-1, and
- use function-name-face rather than constant-face.
- Simplify "abstract interface" regexp.
-
-2010-02-07 Chong Yidong <cyd@stupidchicken.com>
-
- * eshell/esh-util.el (eshell-file-attributes): New optional arg
- ID-FORMAT. Pass it to `file-attributes'.
-
- * eshell/em-ls.el (eshell-do-ls): Use it (Bug#5528).
-
-2010-02-07 sj <prime.wizard+emacs@gmail.com> (tiny change)
-
- * faces.el (set-face-attribute): Allow calling
- internal-set-lisp-face-attribute with 'unspecified family and
- foundry argument (Bug#5536).
-
-2010-02-07 Glenn Morris <rgm@gnu.org>
-
- * progmodes/f90.el (f90-font-lock-keywords-2)
- (f90-looking-at-type-like, f90-looking-at-program-block-end):
- Handle F2003 named interfaces.
-
-2010-02-06 Chong Yidong <cyd@stupidchicken.com>
-
- * progmodes/cc-mode.el (c-common-init): Bind temporary variables
- beg and end before calling c-get-state-before-change-functions.
-
-2010-02-06 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc-bzr.el (vc-bzr-dir-extra-headers):
- Disable the pending merges header.
-
-2010-02-05 Juri Linkov <juri@jurta.org>
-
- * doc-view.el (doc-view-mode):
- * image-mode.el (image-mode): Put property mode-class=special.
- (Bug#4896)
-
-2010-02-05 Mark A. Hershberger <mah@everybody.org>
-
- * vc-svn.el (vc-svn-revision-table): New function.
-
-2010-02-05 Michael Albinus <michael.albinus@gmx.de>
-
- * net/ange-ftp.el (ange-ftp-insert-directory):
- * net/tramp-imap.el (tramp-imap-handle-insert-directory):
- * net/tramp-smb.el (tramp-smb-handle-insert-directory):
- Handle also directories. (Bug#5478)
-
-2010-02-05 Glenn Morris <rgm@gnu.org>
-
- * progmodes/f90.el (f90-font-lock-keywords-2): Fix `enum'.
-
-2010-02-05 Chong Yidong <cyd@stupidchicken.com>
-
- * startup.el (command-line-1): Convert options beginning with a
- single dash as well (Bug#5519).
-
-2010-02-05 Stefan Monnier <monnier@iro.umontreal.ca>
-
- Make `initials' completion work for /hh -> /home/horn again (bug#5524).
- * minibuffer.el (completion-initials-expand): Only check the presence
- of delims *within* the boundaries, since otherwise the / delim is
- always found for files.
-
- Fix up various corner case problems.
- * doc-view.el (doc-view-last-page-number): New function.
- (doc-view-mode, doc-view-last-page, doc-view-goto-page): Use it.
- (doc-view-goto-page): Avoid inf-loops when the conversion fails.
- (doc-view-kill-proc): Avoid inf-loop in freak cases.
- (doc-view-reconvert-doc): Use the new recursive delete-directory.
- (doc-view-convert-current-doc): Don't create the resolution.el file
- here any more.
- (doc-view-pdf/ps->png): Do it here instead.
- (doc-view-already-converted-p): Check that resolution.el is present.
- (doc-view-pdf->png): Don't rely on doc-view-pdf/ps->png for the few
- windows that are not yet showing images.
-
-2010-02-04 Michael Albinus <michael.albinus@gmx.de>
-
- * dired.el (dired-revert): If DIRED-DIRECTORY is a cons cell, call
- `dired-uncache' for every elemnt which is an absolute file name.
-
- * net/tramp.el (tramp-handle-dired-uncache): When DIR is not a
- directory, handle its directory component.
- (tramp-handle-file-remote-p): Let-bind `tramp-verbose' to 3; this
- function is called permanently and creates noise, otherwise.
-
- * net/tramp-imap.el (tramp-imap-handle-insert-directory):
- * net/tramp-smb.el (tramp-smb-handle-insert-directory):
- Handle the case, FILENAME is not in `default-directory'. (Bug#5478)
-
-2010-02-04 David Burger <dburger@google.com> (tiny change)
-
- * macros.el (apply-macro-to-region-lines):
- Minor simplification. (Bug#5485)
-
-2010-02-04 Glenn Morris <rgm@gnu.org>
-
- * mail/rmail.el (rmail-show-message-1): Handle malformed
- quoted-printable text. (Bug#5441)
-
- * mail/mail-utils.el (mail-unquote-printable-region): Doc fix.
-
- * simple.el (visual-line-mode): Capitalize lighter.
-
-2010-02-03 John Wiegley <jwiegley@gmail.com>
-
- * iswitchb.el (iswitchb-completions): Add bookmark files to the
- list of files considered for "virtual buffer" completions.
-
-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,
- when dired is called with a list of files, which are not in
- `default-directory'. (Bug#5478)
-
-2010-02-03 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * vc-hooks.el (vc-path): Make it an obsolete var, rather than function.
-
-2010-02-02 Juri Linkov <juri@jurta.org>
-
- * textmodes/ispell.el (ispell-message-text-end): Remove final newline
- from unidiff to allow function-line after @@.
-
-2010-02-02 Juri Linkov <juri@jurta.org>
-
- * ediff-util.el (ediff-file-checked-in-p): Replace '(nil CVS) by
- '(RCS SCCS) with inverted condition.
-
-2010-02-02 Michael Albinus <michael.albinus@gmx.de>
-
- * net/ange-ftp.el (ange-ftp-skip-msgs): Ignore all ""^500 .*AUTH"
- messages.
-
-2010-02-01 Juri Linkov <juri@jurta.org>
-
- * arc-mode.el (archive-zip-extract): Use `member-ignore-case' to
- compare with "pkunzip" and "pkzip" instead of only "pkzip".
- In the `archive-extract-by-stdout' branch use `shell-quote-argument'
- only when (car archive-zip-extract) is "unzip". (Bug#5475)
-
-2010-02-01 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * doc-view.el (doc-view-new-window-function): Be a bit more defensive.
- (doc-view-revert-buffer): New command.
- (doc-view-mode-map): Use it.
-
-2010-02-01 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc-bzr.el (vc-bzr-dir-extra-headers): Add a header when a
- pending merge is detected.
-
-2010-01-31 Juri Linkov <juri@jurta.org>
-
- * progmodes/grep.el (zrgrep): Call `grep-compute-defaults' at the
- beginning of interactive spec like all other grep commands do.
- Put "all" in front of "gz". (Bug#5260)
-
-2010-01-29 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc-bzr.el (vc-bzr-after-dir-status): Match another renaming indicator.
-
-2010-01-29 Chong Yidong <cyd@stupidchicken.com>
-
- * dirtrack.el (dirtrack): Warn instead of signalling error if the
- regexp is incorrect (Bug#5476).
-
-2010-01-29 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-handle-insert-directory): Handle also
- symlinks, when FILENAME is not in `default-directory'.
-
-2010-01-28 Michael Albinus <michael.albinus@gmx.de>
-
- * net/ange-ftp.el (ange-ftp-insert-directory): Handle the case,
- FILE is not in `default-directory'. (Bug#5478)
-
- * net/tramp.el (tramp-handle-insert-directory): Simplify handling
- of SWITCHES. Handle the case, FILENAME is not in
- `default-directory'. (Bug#5478)
- (tramp-register-file-name-handlers): Add safe-magic property.
-
-2010-01-28 Chong Yidong <cyd@stupidchicken.com>
-
- * arc-mode.el (archive-zip-extract): Quote the argument passed to
- unzip (Bug#5475).
-
-2010-01-28 Nil Geisweiller <ngeiswei@googlemail.com> (tiny change)
-
- * progmodes/flymake.el (flymake-allowed-file-name-masks)
- (flymake-master-make-header-init): Add other C++ filename masks.
- (flymake-find-possible-master-files)
- (flymake-check-patch-master-file-buffer): Doc fixes (Bug#5488).
-
-2010-01-28 Michael Albinus <michael.albinus@gmx.de>
-
- Fix some busybox annoyances.
-
- * net/tramp.el (tramp-wrong-passwd-regexp): Add "Timeout, server
- not responding." string.
- (tramp-open-connection-setup-interactive-shell): Dump stty
- settings. Enable "neveropen" arg for all `tramp-send-command'
- calls. Handle "=" in variable values properly.
- (tramp-find-inline-encoding): Raise an error, when no encoding is
- found.
- (tramp-wait-for-output): Check, whether PROC buffer is available.
- Remove spurious " ^H" sequences, sent by busybox.
- (tramp-get-ls-command): Suppress coloring, if possible.
-
-2010-01-28 Glenn Morris <rgm@gnu.org>
-
- * vc-svn.el (vc-svn-update): Use "svn --non-interactive". (Bug#4280)
-
- * log-edit.el (log-edit-strip-single-file-name): Add missing
- :safe, :group, and :version tags.
-
-2010-01-27 Stephen Berman <stephen.berman@gmx.net>
-
- * calendar/diary-lib.el (diary-unhide-everything): Handle narrowed
- buffers. (Bug#5477)
-
-2010-01-27 David De La Harpe Golden <david@harpegolden.net>
-
- * files.el (delete-directory): Handle moving to trash without
- first doing recursion (Bug#5436).
-
-2010-01-26 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc-hooks.el (vc-path): Mark as obsolete.
-
-2010-01-25 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc-annotate.el (vc-annotate-revision-at-line): Compare file
- names too.
-
- * vc-bzr.el (vc-bzr-print-log): Use the more compact --line option
- for the short log.
- (vc-bzr-log-view-mode): Adjust regexp for the above change.
-
-2010-01-25 Mark A. Hershberger <mah@everybody.org>
-
- * progmodes/python.el: Replace reference to obsolete c-subword-mode.
-
- * vc-bzr.el (vc-bzr-revision-table): New function.
-
-2010-01-25 Eric Hanchrow <eric.hanchrow@gmail.com> (tiny change)
-
- * 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).
-
-2010-01-24 Dan Nicolaescu <dann@ics.uci.edu>
-
- Remove support for adding --signoff on commit.
- Future support will use an incompatible generic mechanism.
- * vc-git.el (vc-git-add-signoff): Remove variable.
- (vc-git-toggle-signoff): Remove function.
- (vc-git-extra-menu-map): Do not bind vc-git-toggle-signoff.
-
- * term/xterm.el (xterm-maybe-set-dark-background-mode):
- Rename from xterm-set-background-mode. Return t if the background mode
- was set.
- (terminal-init-xterm): Move tty-set-up-initial-frame-faces
- earlier, call it again in case the background mode has changed.
-
-2010-01-23 Dmitri Paduchikh <dpaduch@k66.ru> (tiny change)
-
- * emacs-lisp/advice.el (ad-set-orig-definition): Fix typo
- (Bug#3541).
-
-2010-01-23 Chong Yidong <cyd@stupidchicken.com>
-
- * emacs-lisp/assoc.el (aelement): Doc fix.
- (aput, adelete, amake): Use lexical-let (Bug#5450).
-
-2010-01-23 Stephen Leake <stephen_leake@member.fsf.org>
-
- * progmodes/ada-mode.el (ada-in-paramlist-p): Pragma syntax
- is the same as subprogram call, not declaration. (Bug#5435).
-
-2010-01-23 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp-smb.el (tramp-smb-conf): New defcustom.
- (tramp-smb-maybe-open-connection): Use it.
-
-2010-01-22 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp-imap.el (top): Autoload needed packages. (Bug#5448)
-
-2010-01-22 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * mail/rmailmm.el (rmail-mime-handle): Don't set the buffer to unibyte
- just because we see "encoding: 8bit".
- * mail/rmail.el (rmail-show-message-1): Decode the body's QP into bytes.
-
-2010-01-22 Chong Yidong <cyd@stupidchicken.com>
-
- * isearch.el (isearch-allow-scroll): Doc fix (Bug#5446).
-
-2010-01-22 Eli Zaretskii <eliz@gnu.org>
-
- * jka-compr.el (jka-compr-load): If load-file is not in
- load-history, try its file-truename version. (bug#5447)
-
-2010-01-21 Alan Mackenzie <acm@muc.de>
-
- Fix a situation where deletion of a cpp construct throws an error.
- * progmodes/cc-engine.el (c-invalidate-state-cache):
- Before invoking c-with-all-but-one-cpps-commented-out, check that the
- special cpp construct is still in the buffer.
- (c-parse-state): Record the special cpp with markers, not numbers.
-
-2010-01-21 Kenichi Handa <handa@m17n.org>
-
- * textmodes/sgml-mode.el (sgml-maybe-name-self): No need to
- process last-command-event, as it is now decoded first (Bug#5380).
-
-2010-01-20 Chong Yidong <cyd@stupidchicken.com>
-
- * term.el (term-send-raw-meta): Revert 2009-12-04 change (Bug#5330).
-
-2010-01-20 Glenn Morris <rgm@gnu.org>
-
- * indent.el (tab-always-indent): Fix custom-type.
-
-2010-01-19 Alan Mackenzie <acm@muc.de>
-
- * progmodes/cc-defs.el: Fix bug#5395: typing '#' in an empty
- buffer throws "args out of range".
- (c-set-cpp-delimiters, c-clear-cpp-delimiters): Check for EOB
- playing the role of delimiter.
-
-2010-01-18 Stephen Leake <stephen_leake@member.fsf.org>
-
- * progmodes/ada-mode.el: Fix bug#5400.
- (ada-matching-decl-start-re): Move into ada-goto-decl-start.
- (ada-goto-decl-start): Rename from ada-goto-matching-decl-start; callers
- changed. Delete RECURSIVE parameter; never used. Improve doc string.
- Improve comments in "is" portion. Handle null procedure declaration.
- (ada-move-to-end): Improve doc string.
-
-2010-01-18 Óscar Fuentes <ofv@wanadoo.es>
-
- * ido.el (ido-cur-list): Initialize to nil.
- Remove obsolete information from commentary.
- (ido-choice-list): Initialize to nil.
- (ido-get-bufname): Reject minibuffers.
- (ido-make-buffer-list): If "default" is a nonexistent
- buffer, ignore it, as per the function's comment.
- (ido-kill-buffer-internal): New function.
- (ido-kill-buffer-at-head): Use it.
- (ido-visit-buffer): Likewise.
-
-2010-01-18 Chong Yidong <cyd@stupidchicken.com>
-
- * calendar/time-date.el (date-to-time): Doc fix (Bug#5408).
-
-2010-01-18 Juanma Barranquero <lekktu@gmail.com>
-
- * emacs-lisp/chart.el (chart-file-count, chart-rmail-from):
- Fix typos in chart titles.
-
- * whitespace.el (whitespace-style, global-whitespace-newline-mode):
- * emacs-lisp/eieio.el (eieio-error-unsupported-class-tags)
- (eieio-generic-form, eieio-help-mode-augmentation-maybee, eieio-browse)
- (describe-class, eieio-describe-generic, describe-generic):
- * emacs-lisp/eieio-speedbar.el (eieio-speedbar-handle-click)
- (eieio-speedbar-expand):
- * emulation/viper-cmd.el (viper-exec-form-in-vi)
- (viper-exec-form-in-emacs, viper-harness-minor-mode, viper-ESC)
- (viper-repeat, viper-replace-state-exit-cmd, viper-toggle-search-style)
- (viper-del-backward-char-in-replace, viper-backward-indent)
- (viper-brac-function, viper-register-to-point, viper-submit-report):
- * net/tramp.el (tramp-remote-coding-commands):
- * term/x-win.el (emacs-session-save, x-menu-bar-open, icon-map-list):
- Fix typos in docstrings.
-
-2010-01-17 Chong Yidong <cyd@stupidchicken.com>
-
- * mail/sendmail.el (mail-yank-original): Set the mark if the
- specified function for yanking does not do it.
-
-2010-01-17 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc.el (with-vc-properties): Deal with directory arguments. (Bug#5298)
-
- * vc-dir.el (vc-dir-resynch-file): Update the vc-dir header when
- resyncing a directory.
-
-2010-01-17 Stephen Leake <stephen_leake@member.fsf.org>
-
- * progmodes/ada-mode.el: Fix bug#1920.
- (ada-ident-re): Delete ., allow multibyte characters.
- (ada-goto-label-re): New; matches goto labels.
- (ada-block-label-re): New; matches block labels.
- (ada-label-re): New; matches both.
- (ada-named-block-re): Delete; callers changed to use
- `ada-block-label-re' instead.
- (ada-get-current-indent, ada-get-indent-noindent, ada-get-indent-loop):
- Use `ada-block-label-re'.
- (ada-indent-on-previous-lines): Improve handling of goto labels.
- (ada-get-indent-block-start): Special-case block label.
- (ada-get-indent-label): Split into `ada-indent-block-label' and
- `ada-indent-goto-label'.
- (ada-goto-stmt-start, ada-goto-next-non-ws):
- Optionally ignore goto labels.
- (ada-goto-next-word): Simplify.
- (ada-indent-newline-indent-conditional): Insert newline before
- trying to fix indentation; doc fix.
-
-2010-01-17 Jay Belanger <jay.p.belanger@gmail.com>
-
- * calc/calc.el (calc-command-flags): Give it an initial value.
-
-2010-01-17 Juanma Barranquero <lekktu@gmail.com>
-
- * files.el (minibuffer-with-setup-hook):
- * textmodes/artist.el (artist-mt, artist-key-undraw-continously)
- (artist-key-draw-continously, artist-key-do-continously-continously)
- (artist-key-set-point-continously, artist-mouse-draw-continously):
- Fix typos in docstrings.
-
-2010-01-16 Lennart Borgman <lennart.borgman@gmail.com>
-
- * nxml/nxml-mode.el (nxml-extend-after-change-region):
- Never return t (Bug#3898).
-
-2010-01-16 Frédéric Perrin <frederic.perrin@resel.fr> (tiny change)
-
- * vc-dispatcher.el (vc-do-command): Set LC_MESSAGES, so that we
- can parse the output of the external commands (Bug#5279).
-
-2010-01-16 Jari Aalto <jari.aalto@cante.net>
-
- * pcmpl-unix.el (pcmpl-unix-read-passwd-file): Doc fix.
-
-2010-01-16 Chong Yidong <cyd@stupidchicken.com>
-
- * emacs-lisp/advice.el (ad-add-advice): Doc fix (Bug#5274)
-
- * emacs-lisp/cl-macs.el (defstruct): Doc fix (Bug#5267).
-
- * startup.el (command-line): Remove unused --icon-type arg.
- Handle --display arg, passing it to command-line-1 (Bug#5392).
-
-2010-01-16 Mario Lang <mlang@delysid.org>
-
- * emacs-lisp/chart.el (chart-translate-namezone):
- * textmodes/artist.el (artist-compute-popup-menu-table):
- Remove duplicated words in doc-strings.
-
-2010-01-15 David Abrahams <dave@boostpro.com> (tiny change)
-
- * net/mairix.el (mairix-widget-send-query): Send -1 instead of nil
- to mairix-search to suppress threading (Bug#5342).
-
-2010-01-15 Kenichi Handa <handa@m17n.org>
-
- * international/mule-cmds.el (canonicalize-coding-system-name):
- Convert "msXXX", "ibmXXX", "windows-XXX" to "cpXXX" (Bug#5387).
-
-2010-01-15 Glenn Morris <rgm@gnu.org>
-
- * log-view.el (top-level): Require 'wid-edit. (Bug#5311)
-
- * wid-edit.el (widget-keymap): Doc fix.
-
- * vc-svn.el (vc-svn-print-log): Use --limit rather than -l since the
- former seems to be more widely accepted by various svn versions.
-
-2010-01-14 Juanma Barranquero <lekktu@gmail.com>
-
- * find-cmd.el (find-constituents):
- * vc-arch.el (vc-arch-root):
- * window.el (window-body-height, pop-up-frames):
- * emacs-lisp/eieio-base.el (eieio-singleton, slot-missing):
- * progmodes/ada-stmt.el (ada-if):
- * progmodes/gdb-ui.el (gdb-jsonify-buffer):
- * textmodes/ispell.el (ispell-grep-options, ispell-dictionary-alist)
- (ispell-encoding8-command, ispell-aspell-supports-utf8)
- (ispell-last-program-name, ispell-help): Fix typos in docstrings.
-
- * progmodes/flymake.el (flymake-post-syntax-check):
- Fix typo in error message.
-
-2010-01-14 Juanma Barranquero <lekktu@gmail.com>
-
- * hexl.el (hexl-printable-character): Fix check of `hexl-iso',
- which is always a string. (Bug#5313)
-
-2010-01-14 Juanma Barranquero <lekktu@gmail.com>
-
- * progmodes/ada-xref.el (ada-default-prj-properties):
- Simplify previous change.
-
-2010-01-14 Stephen Leake <stephen_leake@member.fsf.org>
-
- * progmodes/ada-xref.el (ada-default-prj-properties):
- Default ada_project_path to $ADA_PROJECT_PATH.
-
-2010-01-14 Stephen Leake <stephen_leake@member.fsf.org>
-
- * progmodes/ada-mode.el (ada-create-keymap):
- Override `narrow-to-defun' with `ada-narrow-to-defun'.
-
-2010-01-14 Stephen Leake <stephen_leake@member.fsf.org>
-
- * progmodes/ada-mode.el: Deal with Ada 2005 "overriding" keyword.
- (ada-subprog-start-re, ada-imenu-subprogram-menu-re): Add keyword.
- (ada-get-current-indent, ada-imenu-generic-expression)
- (ada-which-function): Check for it.
-
-2010-01-14 Stephen Leake <stephen_leake@member.fsf.org>
-
- * progmodes/ada-mode.el (ada-clean-buffer-before-saving): Make obsolete.
- (ada-mode): Don't obey `ada-clean-buffer-before-saving' anymore.
-
-2010-01-14 Glenn Morris <rgm@gnu.org>
-
- * frame.el (show-trailing-whitespace): Safe if boolean. (Bug#5312)
-
-2010-01-14 Kenichi Handa <handa@m17n.org>
-
- * composite.el (auto-composition-mode): Make it a buffer local
- variable (permanent-local).
- (auto-composition-function): Set the default value to
- auto-compose-chars.
- (auto-composition-mode): Make it a simple function, not a minor mode.
- (global-auto-composition-mode): Likewise.
- (turn-on-auto-composition-if-enabled): Delete it.
-
-2010-01-13 Karl Fogel <kfogel@red-bean.com>
-
- * bookmark.el (bookmark-bmenu-execute-deletions): Doc fix (Bug#5276).
-
-2010-01-12 Michael Albinus <michael.albinus@gmx.de>
-
- * files.el (copy-directory): Compute target for recursive
- directories with identical names. (Bug#5343)
-
-2010-01-12 Glenn Morris <rgm@gnu.org>
-
- * mail/emacsbug.el (report-emacs-bug-pretest-address):
- Set it to bug-gnu-emacs rather than emacs-pretest-bug.
-
-2010-01-11 Sam Steingold <sds@gnu.org>
-
- * imenu.el (imenu-default-create-index-function): Detect infinite
- loops caused by imenu-prev-index-position-function.
-
-2010-01-11 Juanma Barranquero <lekktu@gmail.com>
-
- * htmlfontify.el (htmlfontify-load-rgb-file)
- (htmlfontify-unload-rgb-file, hfy-fallback-colour-values)
- (htmlfontify-manual, htmlfontify, hfy-page-header, hfy-page-footer)
- (hfy-src-doc-link-style, hfy-src-doc-link-unstyle, hfy-link-extn)
- (hfy-link-style-fun, hfy-index-file, hfy-instance-file)
- (hfy-html-quote-regex, hfy-init-kludge-hook, hfy-post-html-hooks)
- (hfy-default-face-def, hfy-etag-regex, hfy-html-quote-map)
- (hfy-etags-cmd-alist-default, hfy-etags-bin, hfy-ignored-properties)
- (hfy-which-etags, hfy-etags-cmd, hfy-istext-command, hfy-display-class)
- (hfy-optimisations, hfy-tags-cache, hfy-tags-sortl, hfy-tags-rmap)
- (hfy-style-assoc, hfy-sheet-assoc, hfy-facemap-assoc, hfy-interq)
- (hfy-colour-vals, hfy-default-header, hfy-link-style-string)
- (hfy-triplet, hfy-slant, hfy-weight, hfy-combined-face-spec)
- (hfy-face-attr-for-class, hfy-face-to-style-i, hfy-size-to-int)
- (hfy-flatten-style, hfy-face-to-style, hfy-face-or-def-to-name)
- (hfy-face-to-css, hfy-p-to-face, hfy-p-to-face-lennart, hfy-face-at)
- (hfy-fontified-p, hfy-merge-adjacent-spans, hfy-buffer)
- (hfy-html-enkludge-buffer, hfy-html-quote, hfy-html-dekludge-buffer)
- (hfy-force-fontification, htmlfontify-buffer, hfy-dirname)
- (hfy-make-directory, hfy-text-p, hfy-mark-tag-names, hfy-relstub)
- (hfy-href-stub, hfy-href, hfy-mark-tag-hrefs, hfy-prepare-index-i)
- (hfy-prepare-index, hfy-prepare-tag-map, hfy-subtract-maps)
- (htmlfontify-run-etags): Fix typos in docstrings and remove superfluous
- backslash-quoting from parentheses, etc.
-
-2010-01-11 Chong Yidong <cyd@stupidchicken.com>
-
- * progmodes/js.el: Autoload javascript-mode alias.
-
-2010-01-11 Juanma Barranquero <lekktu@gmail.com>
-
- * ffap.el (ffap-shell-prompt-regexp, ffap-all-subdirs, ffap-url-p)
- (ffap-alist, ffap-tex-path, ffap-url-at-point, ffap-gopher-regexp)
- (ffap-gopher-at-point, ffap-file-at-point, ffap-read-file-or-url)
- (ffap-read-url-internal, ffap-menu, ffap-at-mouse):
- Fix typos in docstrings.
- (ffap-url-regexp): Doc fix.
- (ffap-at-mouse): Fix typo in message.
-
-2010-01-11 Glenn Morris <rgm@gnu.org>
-
- * version.el (emacs-copyright): Set copyright year to 2010.
-
-2010-01-10 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * format.el (format-annotate-function): Only set
- write-region-post-annotation-function after running to-fn so as not to
- affect nested write-region calls (bug#5273).
-
-2010-01-10 Chong Yidong <cyd@stupidchicken.com>
-
- * Makefile.in (ELCFILES): Add wisent/python-wy.el and
- wisent/python.el.
-
-2010-01-09 Chong Yidong <cyd@stupidchicken.com>
-
- * man.el (Man-goto-section): Signal error if the section is not
- found (Bug#5317).
-
-2010-01-09 Juanma Barranquero <lekktu@gmail.com>
-
- * vc-bzr.el (vc-bzr-working-revision): On Windows and MS-DOS, accept
- URLs with a leading triple slash in the file: scheme. (Bug#5345)
-
-2010-01-09 Chong Yidong <cyd@stupidchicken.com>
-
- * progmodes/compile.el: Don't treat compile-command as safe if
- compilation-read-command might be nil (Bug#4218).
-
-2010-01-09 Jan Djärv <jan.h.d@swipnet.se>
-
- * startup.el (command-line-1): Use orig-argi to check for ignored X and
- NS options.
-
-2010-01-08 Kenichi Handa <handa@m17n.org>
-
- * international/fontset.el (build-default-fontset-data):
- Exclude characters in scripts kana, hangul, han, or cjk-misc.
-
-2010-01-07 Juanma Barranquero <lekktu@gmail.com>
-
- * vc-dir.el (vc-dir-prepare-status-buffer): Pass a (fake) filename
- to `create-file-buffer' as it expects, not just a buffer name.
- (vc-dir-mode): Include the buffer name in `list-buffers-directory',
- to help uniquify. (Bug#3224)
-
-2010-01-06 Jan Djärv <jan.h.d@swipnet.se>
-
- * font-setting.el (font-setting-change-default-font): Use user-spec
- instead of name.
-
-2010-01-06 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc-bzr.el (vc-bzr-after-dir-status): Ignore pending merges.
-
-2010-01-05 Tom Tromey <tromey@redhat.com>
-
- * progmodes/python.el (python-font-lock-keywords):
- Handle qualified decorators (Bug#881).
-
-2010-01-05 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc-bzr.el (vc-bzr-working-revision): Fix looking for a revision
- in a lightweight checkout.
-
-2010-01-05 Kenichi Handa <handa@m17n.org>
-
- * language/indian.el (malayalam-composable-pattern): Fix ZWNJ and ZWJ.
-
-2010-01-05 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc-bzr.el (vc-bzr-diff): Obey vc-disable-async-diff.
-
-2010-01-04 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc-bzr.el (vc-bzr-state-heuristic): Make it work for lightweight
- checkouts. (Bug#618)
- (vc-bzr-log-view-mode): Also highlight the author.
- (vc-bzr-shelve-map): Change binding for vc-bzr-shelve-apply-at-point.
- (vc-bzr-shelve-menu-map):
- (vc-bzr-dir-extra-headers): Improve menu and tooltip text.
- (vc-bzr-shelve-apply): Make prompt more explicit.
-
-2010-01-02 Chong Yidong <cyd@stupidchicken.com>
-
- * net/browse-url.el (browse-url-encode-url): Don't escape commas.
- They are valid characters in URL paths (rfc3986), and at least
- Firefox does not understand the encoded version (Bug#3166).
-
-2010-01-02 Daniel Elliott <danelliottster@gmail.com> (tiny change)
-
- * progmodes/octave-mod.el (octave-end-keywords)
- (octave-block-begin-or-end-regexp, octave-block-match-alist):
- Add "end" keyword (Bug#3061).
- (octave-end-as-array-index-p): New function.
- (calculate-octave-indent): Use it.
-
-2010-01-02 Karl Fogel <kfogel@red-bean.com>
-
- * bookmark.el: Consistently put the text property on the bookmark name.
- (bookmark-bmenu-marks-width): Bump back to 2, to include
- annotation marks.
- (bookmark-bmenu-hide-filenames): Adjust for above, and put the text
- property on the bookmark name, instead of not putting it at all.
- (bookmark-bmenu-list): Fix where we put the text property.
-
-2010-01-02 Karl Fogel <kfogel@red-bean.com>
-
- * bookmark.el (bookmark-bmenu-save): Just depend on the new logic
- for showing buffer modified state (as added in the previous change).
-
-2010-01-02 Karl Fogel <kfogel@red-bean.com>
-
- * bookmark.el: Show modified state of bookmark buffer more accurately.
- (bookmark-bmenu-list): Initialize buffer-modified-p properly.
- (bookmark-send-edited-annotation): Mark bookmark-alist as modified.
- (with-buffer-modified-unmodified): New macro.
- (bookmark-bmenu-show-filenames, bookmark-bmenu-hide-filenames)
- (bookmark-bmenu-mark, bookmark-bmenu-unmark, bookmark-bmenu-delete):
- Use new macro to preserve the buffer modified state.
-
-2010-01-02 Karl Fogel <kfogel@red-bean.com>
-
- * bookmark.el (bookmark-bmenu-select, bookmark-bmenu-1-window)
- (bookmark-bmenu-2-window, bookmark-bmenu-this-window)
- (bookmark-bmenu-other-window, bookmark-bmenu-switch-other-window)
- (bookmark-bmenu-show-annotation, bookmark-bmenu-edit-annotation)
- (bookmark-bmenu-rename, bookmark-bmenu-locate)
- (bookmark-bmenu-relocate, bookmark-bmenu-goto-bookmark):
- Remove unnecessary calls to `bookmark-bmenu-ensure-position'.
-
-2010-01-02 Eli Zaretskii <eliz@gnu.org>
-
- * emacs-lisp/easy-mmode.el (define-globalized-minor-mode):
- Make the lines in the generated doc string shorter. (Bug#4668)
-
-2010-01-02 Ryan Yeske <rcyeske@gmail.com>
-
- * net/rcirc.el: Add follow-link binding (Bug#4738).
+ Fix the ant regexp to handle end-line and end-column info from jikes.
+ Re-introduce maven regexp. Give the ruby-Test::Unit regexp a
+ higher priority to avoid clobbering by gnu.
-2010-01-02 Eli Zaretskii <eliz@gnu.org>
+2011-05-08 Chong Yidong <cyd@stupidchicken.com>
- * Makefile.in (bzr-update): Rename from cvs-update.
- (cvs-update): New target for backward compatibility.
+ * cus-face.el (custom-declare-face): Call custom-theme-recalc-face
+ if the face has existing theme settings (Bug#8454).
- * makefile.w32-in (bzr-update): Rename from cvs-update.
- (cvs-update): New target for backward compatibility.
-
-2010-01-02 Karl Fogel <kfogel@red-bean.com>
-
- * bookmark.el: Remove gratuitous gratitude.
-
-2010-01-02 Karl Fogel <kfogel@red-bean.com>
-
- * 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>
-
- * bookmark.el (bookmark-bmenu-marks-width): Define to 1, not 2.
- (bookmark-bmenu-list, bookmark-bmenu-bookmark): Calculate property
- positions by using `bookmark-bmenu-marks-width', instead of hardcoding.
- This fixes the `bookmark-bmenu-execute-deletions' bug reported here:
-
- http://lists.gnu.org/archive/html/emacs-devel/2009-12/msg00819.html
- From: Sun Yijiang <sunyijiang {_AT_} gmail.com>
- To: emacs-devel {_AT_} gnu.org
- Subject: bookmark.el bug report
- Date: Mon, 28 Dec 2009 14:19:16 +0800
- Message-ID: 5065e2900912272219y3734fc9fsdaee41167ef99ad7@mail.gmail.com
-
-2010-01-02 Karl Fogel <kfogel@red-bean.com>
-
- * bookmark.el: Improvements suggested by Drew Adams:
- (bookmark-bmenu-ensure-position): New name for
- `bookmark-bmenu-check-position'. Just ensure the position,
- don't return any meaningful value.
- (bookmark-bmenu-header-height, bookmark-bmenu-marks-width):
- New constants.
-
-2010-01-02 Juanma Barranquero <lekktu@gmail.com>
-
- * bookmark.el (bookmarks-already-loaded): Doc fix (don't use `iff').
- (bookmark-yank-point, bookmark-bmenu-check-position):
- Fix typos in docstrings.
- (bookmark-save-flag, bookmark-bmenu-toggle-filenames)
- (bookmark-name-from-full-record, bookmark-get-position)
- (bookmark-set-position, bookmark-set, bookmark-handle-bookmark)
- (bookmark-delete, bookmark-save, bookmark-save, bookmark-bmenu-mode):
- Remove useless quoting of parenthesis, etc. in docstrings.
-
- * ediff-mult.el (ediff-prepare-meta-buffer): Fix typo in help message.
- (ediff-append-custom-diff): Fix typo in error message.
- (ediff-meta-mark-equal-files): Fix typos in messages.
-
- * mpc.el (mpc-playlist-delete): Fix typo in error messages.
-
- * net/imap-hash.el (imap-hash-make): Doc fix.
- (imap-hash-test): Fix typo in error message; reflow docstring.
- (imap-hash-p, imap-hash-get, imap-hash-put, imap-hash-make-message)
- (imap-hash-count, imap-hash-server, imap-hash-port, imap-hash-ssl)
- (imap-hash-mailbox, imap-hash-user, imap-hash-password):
- Fix typos in docstrings.
- (imap-hash-open-connection): Fix typo in error message.
-
- * play/gomoku.el (gomoku): Fix typos in docstring.
-
- * progmodes/gdb-ui.el (gdb-location-alist): Reflow docstring.
- (gdb-jsonify-buffer): Fix typos in docstring.
- (gdb-goto-breakpoint): Fix typo in error message.
- ("Display Other Windows"): Fix typo in help message.
- (gdb-speedbar-expand-node): Fix typo in question.
-
- * progmodes/idlw-help.el (idlwave-help-browse-url-available)
- (idlwave-html-system-help-location, idlwave-html-help-location)
- (idlwave-help-browser-function, idlwave-help-browser-generic-program)
- (idlwave-help-browser-generic-args, idlwave-help-directory)
- (idlwave-html-help-is-available, idlwave-help-mode-line-indicator)
- (idlwave-help-mode-map, idlwave-help-mode, idlwave-do-context-help)
- (idlwave-online-help, idlwave-help-html-link)
- (idlwave-help-show-help-frame, idlwave-help-assistant-command):
- Fix typos in docstrings.
- (idlwave-help-with-source, idlwave-help-find-routine-definition):
- Reflow docstrings.
- (idlwave-help-assistant-start): Fix typo in error message.
-
- * progmodes/octave-mod.el (octave-mode, octave-electric-semi)
- (octave-electric-space): Fix typos in docstrings.
-
-2010-01-01 Chong Yidong <cyd@stupidchicken.com>
-
- * files.el (minibuffer-with-setup-hook): Doc fix (Bug#5149).
-
-2010-01-01 Juri Linkov <juri@jurta.org>
-
- * comint.el (comint-input-ring-size): Make it a defcustom and
- increase the default to 500 (Bug#5148).
-
-2009-12-31 Nick Roberts <nickrob@snap.net.nz>
-
- Further changes from EMACS_23_1_RC branch (2009-12-29 contd).
- * term/x-win.el (x-gtk-stock-map): Map some GUD buttons.
- * progmodes/gud.el (gud-menu-map): Add reverse-execution commands.
-
-2009-12-30 Nick Roberts <nickrob@snap.net.nz>
-
- Show working revision correctly for mercurial.
- * vc-hg.el (vc-hg-working-revision): Use hg parent instead of
- hg log as suggested by Alex Harsanyi <alexharsanyi@gmail.com>.
-
-2009-12-29 Juanma Barranquero <lekktu@gmail.com>
-
- Declare some functions for the byte-compiler.
- * progmodes/gdb-ui.el (speedbar-change-initial-expansion-list)
- (speedbar-timer-fn, speedbar-change-expand-button-char)
- (speedbar-delete-subblock, speedbar-center-buffer-smartly): Declare.
-
-2009-12-29 Nick Roberts <nickrob@snap.net.nz>
-
- This changeset reverts GDB Graphical Interface to use annotations.
- * progmodes/gdb-ui.el, progmodes/gud.el: Import from EMACS_23_1_RC.
-
-2009-12-29 Dan Nicolaescu <dann@ics.uci.edu>
-
- Make vc-dir work on subdirectories of the bzr root.
- * vc-bzr.el (vc-bzr-after-dir-status): Add new argument.
- Return file names relative to it.
- (vc-bzr-dir-status, vc-bzr-dir-status-files): Pass the bzr root
- relative directory to vc-bzr-after-dir-status.
-
-2009-12-28 Tassilo Horn <tassilo@member.fsf.org>
-
- * font-lock.el (font-lock-refresh-defaults): New function, which
- can be used to let font-lock react to external changes in
- variables like font-lock-defaults and keywords.
- See http://thread.gmane.org/gmane.emacs.devel/118777/focus=118802
-
-2009-12-28 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc-rcs.el (vc-rcs-register): Fix registering a specific version.
-
- * vc-bzr.el (vc-bzr-log-view-mode): Fix short log regexp.
-
-2009-12-28 Juanma Barranquero <lekktu@gmail.com>
-
- Supersede color.diff settings in git log (bug#5211).
-
- * vc-git.el (vc-git-print-log): Pass "--no-color" to log to avoid
- escape chars in its output when the user has color.diff set to `always'.
- This fix works on git 1.4.2 and newer (released on 2006-08-13).
-
-2009-12-26 Kevin Ryde <user42@zip.com.au>
-
- * info-look.el (sh-mode): Look for coreutils new "Concept Index"
- node. Keep previous "Index" name to work with past coreutils too.
-
- * man.el (man): Revise docstring a bit to show -a and -l as
- examples. Add -k description since support for it has otherwise
- been a secret. (Further to bug#3717.)
- (Man-bgproc-sentinel): When "-k foo" produces no output show error
- "no matches" rather than "Can't find manpage", as the latter reads
- like -k was interpreted as a page name, which is not so. (Bug#5431)
-
-2009-12-26 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-handle-insert-directory): Quote "'" in the
- switches. Check also for //SUBDIRED// line.
-
-2009-12-25 Kenichi Handa <handa@m17n.org>
-
- * language/indian.el (devanagari-composable-pattern): Fix to
- handle ZWNJ and ZWJ. Use it in composition-function-table for
- Devanagari.
- (malayalam-composable-pattern): Fix previous change.
-
-2009-12-23 Vinicius Jose Latorre <viniciusjl@ig.com.br>
-
- * ps-print.el (ps-face-attributes): It was not returning the
- attribute face for faces specified as string. Reported by harven
- <harven@free.fr>. (Bug#5254)
- (ps-print-version): New version 7.3.5.
-
-2009-12-18 Ulf Jasper <ulf.jasper@web.de>
-
- * calendar/icalendar.el (icalendar--convert-tz-offset):
- Fix timezone names.
- (icalendar--convert-tz-offset): Fix the "last-day-problem".
- (icalendar--add-diary-entry): Remove the trailing blank that
- diary-make-entry inserts.
-
-2009-12-17 Michael Albinus <michael.albinus@gmx.de>
-
- Make `file-expand-wildcards' work for remote files.
-
- * files.el (file-expand-wildcards): In case of remote files, check
- only local file name part for wildcards. Provide feature 'files
- and subfeature 'remote-wildcards. (Bug#5198)
-
- * net/tramp.el (tramp-handle-file-remote-p): Expand file name only
- if there is already an established connection.
- (tramp-advice-file-expand-wildcards): Remove it.
-
- * net/tramp-compat.el (top): Autoload `tramp-handle-file-remote-p'.
- (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>
-
- Some doc fixes (more needed).
-
- * find-cmd.el (find-constituents): Reflow docstring.
- (find-cmd, find-prune, find-command): Fix typos in docstrings.
- (find-generic): Doc fix.
-
-2009-12-17 Juri Linkov <juri@jurta.org>
-
- Fix regression from 23.1 to allow multiple modes in Local Variables.
-
- * files.el (hack-local-variables-filter): While ignoring duplicates,
- don't take `mode' into account.
- (hack-local-variables-filter, hack-dir-local-variables):
- Don't remove duplicate `mode' from local-variables-alist (like `eval').
-
-2009-12-17 Juri Linkov <juri@jurta.org>
-
- Make `dired-diff' more safe. (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.
-
-2009-12-17 Andreas Schwab <schwab@linux-m68k.org>
-
- * emacs-lisp/autoload.el (batch-update-autoloads): Only exclude
- unconditionally preloaded files.
-
-2009-12-16 Juri Linkov <juri@jurta.org>
-
- Revert to old 23.1 logic of using the file at the mark as default.
- * dired-aux.el (dired-diff): Use the file at the mark as default
- if it's not the same as the current file, and the target dir is
- the current dir or the mark is active. Add the current file
- as the arg of `dired-dwim-target-defaults'. Use the default file
- in the prompt. (Bug#5225)
-
-2009-12-15 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-echo-mark-marker-length): New defconst.
- (tramp-echo-mark, tramp-echoed-echo-mark-regexp): Use it.
- (tramp-check-for-regexp): Check also, when an echoing shell stops
- to echo sent commands.
-
-2009-12-14 Chong Yidong <cyd@stupidchicken.com>
-
- * Makefile.in: Revert last change (Bug#5191).
-
-2009-12-14 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc-hg.el (vc-hg-print-log): Fix argument order.
- (vc-hg-working-revision): Make sure the command is executed in a
- known environment so that we can parse the output. (Bug#4417)
-
-2009-12-14 Chong Yidong <cyd@stupidchicken.com>
-
- * progmodes/python.el (python-symbol-completions): Remove text
- properties from symbol string before calling python-send-receive.
-
-2009-12-14 Nick Roberts <nickrob@snap.net.nz>
-
- * progmodes/gdb-mi.el (gdb-frame-handler): Only set gud-lat-frame
- when there are values for both file and line. (Bug#5060)
-
-2009-12-14 Juri Linkov <juri@jurta.org>
-
- * ediff-ptch.el (ediff-context-diff-label-regexp): Don't match
- whitespace after the file name of the first line of unified format,
- because git-diff doesn't output whitespace and file modification time
- after the file name.
-
-2009-12-14 David Kastrup <dak@gnu.org>
-
- * info.el (Info-hide-cookies-node): Before hiding a cookie,
- check if it already has the `display' property added by
- `Info-display-images-node', and not put the `invisible' property
- in this case.
-
-2009-12-13 Glenn Morris <rgm@gnu.org>
-
- * mail/emacsbug.el (message-sort-headers): Define for compiler.
- (report-emacs-bug): In message-mode, sort manually before storing
- original report text. (Bug#5178)
- Remove superfluous save-excursion.
-
-2009-12-12 Michael Albinus <michael.albinus@gmx.de>
-
- * net/dbus.el (dbus-property-handler): Filter lambda forms out
- when responding to "GetAll" properties.
-
-2009-12-12 Chong Yidong <cyd@stupidchicken.com>
-
- * simple.el (compose-mail): Remove mail-setup-with-from from
- customization checks.
-
-2009-12-12 Eli Zaretskii <eliz@gnu.org>
-
- * arc-mode.el (archive-rar-summarize): Support Attribute fields in
- RAR archives created on Unix systems.
-
-2009-12-12 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * minibuffer.el (minibuffer-local-must-match-filename-map): Re-instate
- the varalias that was accidentally removed by the 2009-11-19 change
- (bug#5186).
-
-2009-12-12 Kenichi Handa <handa@m17n.org>
-
- * language/indian.el (indian-compose-regexp): New function.
- (malayalam-composable-pattern): Fix the pattern.
- (composition-function-table): Set malayalam-composable-pattern for
- Malayalam characters.
-
-2009-12-11 Chong Yidong <cyd@stupidchicken.com>
-
- * progmodes/bug-reference.el (bug-reference-map): Bind mouse-2
- rather than down-mouse-1, based on follow-link conventions.
-
- * makefile.w32-in: Ensure that Lisp files in CEDET subdirectories
- are compiled.
-
-2009-12-11 Michael McNamara <mac@mail.brushroad.com>
-
- * progmodes/verilog-mode.el (verilog-vmm-begin-re, verilog-vmm-end-re)
- (verilog-vmm-statement-re, verilog-ovm-statement-re)
- (verilog-defun-level-not-generate-re, verilog-calculate-indent)
- (verilog-leap-to-head, verilog-backward-token):
- Fix indenting VMM macros. Reported by Jonathan Ashbrook.
-
-2009-12-11 Wilson Snyder <wsnyder@wsnyder.org>
-
- * progmodes/verilog-mode.el (verilog-auto-lineup)
- (verilog-nameable-item-re): Cleanup user-visible spelling and
- documentation errors. One reported by Gary Delp.
- (verilog-submit-bug-report): Mention bug tracking and CC co-author.
- (verilog-read-decls): Fix AUTOWIRE with types declared in a
- package, bug195. Reported by Pierre-David Pfister.
-
-2009-12-11 Glenn Morris <rgm@gnu.org>
-
- * progmodes/cc-engine.el (safe-pos-list): Define for compiler.
-
- * mail/emacsbug.el: No longer require sendmail.
- Replace sendmail's `mail-text' by `rfc822-goto-eoh'. (Bug#5174)
- (report-emacs-bug-orig-text): Doc fix.
- (report-emacs-bug-send-command, report-emacs-bug-send-hook):
- New local variables, to adapt to different mail-user-agents.
- (report-emacs-bug): Fix test for a gnu.org address.
- Use overlays for emphasis, since font-lock defeats 'face property.
- Pretest bugs also end up at the newsgroup these days.
- Stop message-mode stripping text properties.
- Set and use the new buffer-local variables.
- (report-emacs-bug-hook): Add doc-string.
- Remove some unnecessary save-excursions and simplify.
- Use the appropriate hook and send-command.
-
- * emacs-lisp/lisp-mode.el (emacs-lisp-mode-map): Standardize the
- capitalization of some menu entries.
-
-2009-12-10 Vinicius Jose Latorre <viniciusjl@ig.com.br>
-
- * whitespace.el (whitespace-display-char-on):
- Ensure `buffer-display-table' is unique when two or more windows are
- visible. Reported by Martin Pohlack <mp26@os.inf.tu-dresden.de>.
- New version 12.1.
-
-2009-12-10 Eli Zaretskii <eliz@gnu.org>
-
- * arc-mode.el (archive-rar-summarize): Allow between 6 and 7
- characters in the Attribute field.
-
-2009-12-10 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc-svn.el (vc-svn-after-dir-status): Fix regexp. (Bug#4741)
-
-2009-12-10 Stefan Monnier <monnier@iro.umontreal.ca>
-
- Let loaddefs.el adjust to changes in autoload-excludes (bug#5162).
- * emacs-lisp/autoload.el (autoload-generate-file-autoloads):
- Disregard autoload-excludes.
- (update-directory-autoloads): Obey autoload-excludes here instead.
- But don't store its contents in no-autoloads and remove entries that
- refer to excludes files.
-
-2009-12-10 Glenn Morris <rgm@gnu.org>
-
- * mail/feedmail.el (top-level): Move require 'mail-utils to start.
- (expand-mail-aliases): Define for compiler.
-
- * vc-annotate.el (log-view-vc-backend, log-view-vc-fileset):
- Define for compiler.
-
- * mail/emacsbug.el (report-emacs-bug): Use whichever send command is
- appropriate for the mail-user-agent in use.
-
-2009-12-09 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-handle-insert-directory): Suppress error messages.
-
-2009-12-09 Dan Nicolaescu <dann@ics.uci.edu>
-
- Fix short log parsing and fontification.
- * vc-bzr.el (vc-bzr-log-view-mode): Match dot in revision number.
- Fix fontification for the [merge] label.
-
-2009-12-09 Vivek Dasmohapatra <vivek@etla.org>
-
- Drop some properties to avoid surprises.
- * htmlfontify.el (hfy-ignored-properties): New defcustom.
- (hfy-fontify-buffer): Use it.
-
-2009-12-09 Stefan Monnier <monnier@iro.umontreal.ca>
-
- Minor cleanup.
- * ffap.el (ffap-symbol-value): Replace ffap-soft-value.
- Adjust all callers.
- (ffap-locate-file): Remove unused arg `dir-ok' and make other
- args compulsory. Adjust callers.
- (ffap-gopher-at-point): Remove unused var `name'.
-
- Get rid of the ELCFILES abomination.
- * Makefile.in (update-elclist, ELCFILES, compile-last): Remove.
- (compile-elcfiles): New phony target.
- (compile-main): Compute ELCFILES dynamically.
- (compile-clean): New target to remove left-over elc files.
- (compile, all): Use it.
-
-2009-12-09 Kenichi Handa <handa@etlken>
-
- * international/mule-diag.el: Require help-mode instead of help-fns.
-
-2009-12-09 Kenichi Handa <handa@m17n.org>
-
- * international/mule-cmds.el (ucs-names): Supply sufficiently
- fine ranges instead of pre-calculating accurate ranges.
- Iterate with bigger gc-cons-threshold.
-
-2009-12-08 Dan Nicolaescu <dann@ics.uci.edu>
-
- Add support for stashing a snapshot of the current tree.
- * vc-git.el (vc-git-stash-snapshot): New function.
- (vc-git-stash-map, vc-git-extra-menu-map): Add a mapping for it.
-
-2009-12-08 Jose E. Marchesi <jemarch@gnu.org>
-
- * play/gomoku.el (gomoku-mode-map): Remap `move-(beginning|end)-of-line'
- instead of `(beginning|end)-of-line'.
-
-2009-12-08 Glenn Morris <rgm@gnu.org>
-
- * vc-mtn.el (vc-mtn-print-log): Fix typo in previous.
-
- * Makefile.in (ELCFILES): Regenerate.
-
-2009-12-07 Juri Linkov <juri@jurta.org>
-
- Don't lazy-highlight the comint output in history Isearch mode.
-
- * comint.el (comint-history-isearch-search): Instead of
- `comint-line-beginning-position', use `comint-after-pmark-p'
- to check if point if before the process mark, and go to
- `process-mark' in this case.
-
-2009-12-07 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * textmodes/tex-mode.el (latex-complete)
- (latex-indent-or-complete): Remove.
- (latex-mode): Set completion-at-point-functions instead.
-
- Provide a standard completion command and hook it into TAB.
- * minibuffer.el (completion-at-point-functions): New var.
- (completion-at-point): New command.
- * indent.el (indent-for-tab-command): Handle the `complete' behavior.
- * progmodes/python.el (python-mode-map): Use completion-at-point.
- (python-completion-at-point): Rename from python-partial-symbol and
- adjust for use in completion-at-point-functions.
- (python-mode): Setup completion-at-point for Python completion.
- * emacs-lisp/lisp.el (lisp-completion-at-point): New function
- extracted from lisp-complete-symbol.
- (lisp-complete-symbol): Use it.
- * emacs-lisp/lisp-mode.el (emacs-lisp-mode): Use define-derived-mode,
- setup completion-at-point for Elisp completion.
- (emacs-lisp-mode-map, lisp-interaction-mode-map):
- Use completion-at-point.
- * ielm.el (ielm-map): Use completion-at-point.
- (inferior-emacs-lisp-mode): Setup completion-at-point-functions.
- * progmodes/sym-comp.el: Move to...
- * obsolete/sym-comp.el: Move from progmodes.
-
-2009-12-07 Eli Zaretskii <eliz@gnu.org>
-
- Prevent save-buffer in Rmail buffers from using the coding-system
- of the current message, and from clobbering the encoding mnemonics
- in the mode line (Bug#4623).
-
- * mail/rmail.el (rmail-swap-buffers): Swap encoding and modified
- flag, too.
- (rmail-message-encoding): New variable.
- (rmail-write-region-annotate): Record the encoding of the current
- message in rmail-message-encoding.
- (rmail-after-save-hook): New function, restores the encoding of
- the current message after the message collection is saved.
-
-2009-12-07 Juri Linkov <juri@jurta.org>
-
- * progmodes/grep.el (grep-read-files): Use `completing-read'
- instead of `read-string'. Set its `collection' arg to
- `read-file-name-internal'. (Bug#4301)
-
-2009-12-07 Juri Linkov <juri@jurta.org>
-
- Correctly restore original Isearch point. (Bug#4994)
-
- * isearch.el (isearch-mode): Move `isearch-push-state' after
- `(run-hooks 'isearch-mode-hook)'.
- (isearch-cancel): When `isearch-push-state-function' is defined,
- let-bind `isearch-cmds' to the first state (the last element of
- `isearch-cmds') and call `isearch-top-state' (it calls pop-state
- function and restores the original point). Otherwise, move point
- to `isearch-opoint'.
-
-2009-12-07 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * international/mule-cmds.el (ucs-names): Weed out at compile-time the
- chars that don't have names, so the table can be built much faster at
- run-time.
-
-2009-12-07 Chong Yidong <cyd@stupidchicken.com>
-
- * vc-bzr.el (vc-bzr-annotate-command): More elegant form for last
- change. Suggested by David Kastrup.
-
- * simple.el (compose-mail): Check for incompatibilities and warn.
- (compose-mail-user-agent-warnings): New option.
-
-2009-12-07 Dan Nicolaescu <dann@ics.uci.edu>
-
- Support showing a single log entry from vc-annotate.
- * vc.el (print-log): Add a new argument: START-REVISION.
- (vc-print-log-internal): Add a new optional argument and
- pass it to the backend.
- (vc-print-log, vc-print-root-log): Adjust callers.
- * vc-annotate.el (vc-annotate-show-log-revision-at-line): If a
- buffer already displays the requested log entry, use it.
- Otherwise display only the log entry in question.
- * vc-svn.el (vc-svn-print-log):
- * vc-mtn.el (vc-mtn-print-log):
- * vc-hg.el (vc-hg-state):
- * vc-git.el (vc-git-print-log): Add support for new argument START-REVISION.
- (vc-git-show-log-entry): Return t on success.
- * vc-bzr.el (vc-bzr-print-log): Add support new argument START-REVISION.
- (vc-bzr-show-log-entry): Return t on success.
- * vc-rcs.el (vc-rcs-print-log):
- * vc-sccs.el (vc-sccs-print-log):
- * vc-cvs.el (vc-cvs-print-log): Add new argument, ignore it.
-
-2009-12-07 Dan Nicolaescu <dann@ics.uci.edu>
-
- * ediff-mult.el (ediff-setup-meta-map, ediff-prepare-meta-buffer):
- Add menus to the meta mode. (Bug#5043)
-
-2009-12-07 Michael Kifer <kifer@cs.stonybrook.edu>
-
- * ediff-init.el (ediff-event-key): Use event-to-character instead of
- event-key.
-
- * ediff.el (ediff-buffers-internal): Add unwind-protect.
-
-2009-12-07 Michael Albinus <michael.albinus@gmx.de>
-
- Handle prompt rules of ksh in OpenBSD 4.5. Reported by Raphaël
- Berbain <raphael.berbain@gmail.com>.
-
- * net/tramp.el (tramp-end-of-output): Move up. Use `#' and `$'
- characters.
- (tramp-initial-end-of-output): New defconst.
- (tramp-methods, tramp-find-shell)
- (tramp-open-connection-setup-interactive-shell)
- (tramp-maybe-open-connection): Use it.
- (tramp-shell-prompt-pattern, tramp-wait-for-output):
- Handle existence of `#' and `$'.
-
- * net/tramp-fish.el (tramp-fish-maybe-open-connection):
- Use `tramp-initial-end-of-output'.
-
-2009-12-07 Dan Nicolaescu <dann@ics.uci.edu>
-
- Get the background mode from the terminal for xterm, and set
- faces accordingly.
- * term/xterm.el (xterm-set-background-mode): New function.
- (terminal-init-xterm): Use it in case xterm supports background
- color queries. Recompute faces after getting the background
- color.
-
-2009-12-07 Ulrich Mueller <ulm@gentoo.org>
-
- * emacs-lisp/bytecomp.el (byte-compile-insert-header): Put the version
- number comment back on its own line, for easier parsing.
-
-2009-12-07 Stefan Monnier <monnier@iro.umontreal.ca>
-
- Make it work for non-file buffers (bug#5102).
- * doc-view.el (doc-view-current-cache-dir):
- Use doc-view-buffer-file-name rather than buffer-file-name.
- (doc-view-mode): Use buffer-name when buffer-file-name is nil.
-
-2009-12-06 Óscar Fuentes <ofv@wanadoo.es>
-
- * vc-bzr.el (vc-bzr-annotate-command): Handle the case where the
- author field is too short.
-
-2009-12-06 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc-git.el (vc-git-print-log): Handle a limit argument.
- Display the short log in graph form and with labels.
- (vc-git-log-view-mode): Handle labels.
-
- Make vc-revert change VC state from 'added to 'unregistered.
- * vc-git.el (vc-git-revert): Call git reset first.
-
-2009-12-06 Ulf Jasper <ulf.jasper@web.de>
-
- * net/newst-backend.el, net/newst-plainview.el:
- * net/newst-reader.el, net/newst-ticker.el:
- * net/newst-treeview.el, net/newsticker.el:
- Require/provide newst-... (instead of newsticker-...). (Bug#5096)
-
-2009-12-06 Chong Yidong <cyd@stupidchicken.com>
-
- * log-view.el (log-view-mode-map): Bind "=" to log-view-diff too.
-
- * vc-bzr.el (vc-bzr-annotate-command): Show author in annotation.
- Handle empty author field (Bug#4144). Suggested by Óscar Fuentes.
- (vc-bzr-annotate-time, vc-bzr-annotate-extract-revision-at-line):
- Update annotation regexp.
-
- * simple.el (beginning-of-visual-line): Constrain to field
- boundaries (Bug#5106).
-
-2009-12-06 Ulf Jasper <ulf.jasper@web.de>
-
- * xml.el (xml-substitute-numeric-entities):
- Move newsticker--decode-numeric-entities in newst-backend.el to
- xml-substitute-numeric-entities in xml.el. (Bug#5008)
- * net/newst-backend.el (newsticker--parse-generic-feed)
- (newsticker--parse-generic-items)
- (newsticker--decode-numeric-entities):
- Move newsticker--decode-numeric-entities in newst-backend.el to
- xml-substitute-numeric-entities in xml.el. (Bug#5008)
-
-2009-12-06 Daniel Colascione <dan.colascione@gmail.com>
-
- * progmodes/js.el (js--js-not): Add null to the list of values.
-
-2009-12-06 Chong Yidong <cyd@stupidchicken.com>
-
- * ansi-color.el (ansi-color-for-comint-mode): Add :version keyword.
-
-2009-12-06 Roland Winkler <Roland.Winkler@physik.uni-erlangen.de>
-
- * textmodes/bibtex.el (bibtex-enclosing-field): Exclude entry
- delimiter if it is at the end of the current line.
- (bibtex-generate-url-list): Fix docstring.
-
-2009-12-06 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * minibuffer.el (minibuffer-complete-and-exit): Don't replace the
- minibuffer's content with itself.
- Fold the confirm-after-completion case into the `confirm' case.
- (completion-pcm-word-delimiters): Add : and / to the delimiters.
-
-2009-12-06 Kevin Ryde <user42@zip.com.au>
-
- * ffap.el (ffap-rfc-path): Make this a defcustom since
- `ffap-rfc-directories' is also a defcustom. (Bug#4514.)
-
- * info-look.el: Add setup for apropos-mode to use emacs-lisp-mode
- manuals, similar to existing setup for help-mode. (Bug#3913.)
-
-2009-12-05 Juri Linkov <juri@jurta.org>
-
- Save and restore dired buffer's point positions too. (Bug#4880)
-
- * dired.el (dired-save-positions): Return in the first element
- buffer's position in format (BUFFER DIRED-FILENAME BUFFER-POINT).
- Doc fix.
- (dired-restore-positions): First restore buffer's position.
- While restoring window's positions, check if window still displays
- the original buffer.
-
-2009-12-05 Chong Yidong <cyd@stupidchicken.com>
-
- * bindings.el (complete-symbol): Call semantic-ia-complete-symbol
- if possible.
-
- * shell.el (shell): Require ansi-color (Bug#5113).
-
- * ansi-color.el (ansi-color-for-comint-mode): Default to t.
-
- * hl-line.el (global-hl-line-highlight): Minor doc fix (Bug#4925).
-
-2009-12-05 Alan Mackenzie <acm@muc.de>
-
- * progmodes/cc-mode.el (c-before-hack-hook)
- (c-postprocess-file-styles): Revert change 2009-07-18T21:03:43Z!acm@muc.de to permit
- `c-file-style' to work again. This reversion restores the current
- software to its state in Emacs 23.1. (Bug#4146)
-
-2009-12-05 Kevin Ryde <user42@zip.com.au>
-
- * textmodes/sgml-mode.el (sgml-lexical-context):
- Recognise comment-start-skip to comment-end-skip as comment (Bug#4781).
-
-2009-12-05 Juri Linkov <juri@jurta.org>
-
- * info.el (Info-find-node-2): Set `Info-current-subfile' to nil
- for virtual nodes. (Bug#4147)
- (Info-find-node-2): Set `Info-current-node-virtual' to nil
- when moving from a virtual node.
- (Info-mode-menu): Add `Info-virtual-index' to the menu.
- (Info-mode): Add `Info-virtual-index' to the docstring.
-
-2009-12-05 Roland Winkler <Roland.Winkler@physik.uni-erlangen.de>
-
- * textmodes/bibtex.el (bibtex-map-entries): Use marker to keep
- track of the buffer position of the end of a BibTeX entry as this
- position may change during reformatting.
- (bibtex-format-entry): Remove whitespace before processing
- numerical fields so that we recognize the latter properly.
- (bibtex-reformat): Do not use push which changes the global value
- of bibtex-entry-format.
- (bibtex-field-braces-alist, bibtex-field-strings-alist)
- (bibtex-field-re-init): Replace only space characters by regexp
- for whitespace.
- (bibtex-generate-url-list, bibtex-cite-matcher-alist): Fix docstring.
- (bibtex-initialize): Also update bibtex-strings.
- (bibtex-kill-field): Preserve white space at end of entry.
- (bibtex-kill-entry, bibtex-yank-pop, bibtex-insert-kill):
- Update bibtex-reference-keys.
-
-2009-12-05 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * minibuffer.el (completion-pcm--merge-try): Also consider placing
- point after a star, if that's the only place where modifications can
- make progress.
-
-2009-12-05 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc-dir.el (vc-dir): Use the correct markup for showing keymaps
- in docstrings.
-
-2009-12-04 Juri Linkov <juri@jurta.org>
-
- * proced.el (proced): Call `(proced-update t)' to update process
- information instead of only running proced-post-display-hook.
- (proced-send-signal): Add a leading space to the buffer name
- " *Marked Processes*" to make this buffer ephemeral.
-
-2009-12-04 Juri Linkov <juri@jurta.org>
-
- * dired.el (dired-auto-revert-buffer): New defcustom.
- (dired-internal-noselect): Use it.
-
-2009-12-04 Juri Linkov <juri@jurta.org>
-
- Change roles of modes and functions in image-mode.el (Bug#5062).
-
- * image-mode.el: Replace `image-mode-maybe' with `image-mode'
- in `auto-mode-alist'.
- (image-mode-previous-major-mode): New variable.
- (image-minor-mode-map): Rename from `image-mode-text-map'.
- (image-mode): Move graceful error-handling code from
- `image-minor-mode' to here. On errors call `image-mode-as-text'.
- (image-minor-mode): Remove all image-handling code.
- Replace `image-mode-text-map' with `image-minor-mode-map'.
- Check for `image-type' in mode-line format string.
- (image-mode-maybe): Make obsolete with an alias to `image-mode'.
- (image-mode-as-text): New function with most code from
- `image-mode-maybe'.
- (image-toggle-display-text): Move code that removes image
- properties from `image-toggle-display' to here.
- (image-toggle-display-image): New function with code that adds
- image properties copied from `image-toggle-display'.
- (image-toggle-display): Remove most code with leaving only code
- that toggles between `image-mode-as-text' and `image-mode'.
-
-2009-12-04 Ulf Jasper <ulf.jasper@web.de>
-
- * net/newst-treeview.el
- (newsticker--treeview-list-highlight-start): Restored call to
- save-excursion: Selected item was stuck.
- (newsticker--treeview-list-select): New.
- (newsticker--treeview-item-show-text)
- (newsticker--treeview-item-show)
- (newsticker--treeview-item-update): Use new
- newsticker-treeview-item-mode.
- (newsticker-treeview-update): Keep current item.
- (newsticker-treeview-next-new-or-immortal-item): Doc change.
- (newsticker--treeview-first-feed): Doc change.
- (newsticker-treeview-list-menu)
- (newsticker-treeview-item-menu): Add menu entries.
- (newsticker-treeview-item-mode): New.
-
- * net/newst-backend.el (newsticker-customize): Delete other
- windows.
-
-2009-12-04 Sam Steingold <sds@gnu.org>
-
- * log-view.el (log-view-mode-map): "q" calls quit-window,
- like in all the other non-self-insert buffers.
-
-2009-12-04 Stefan Monnier <monnier@iro.umontreal.ca>
-
- Minor cleanup.
- * term.el (term-send-raw, term-send-raw-meta): Use read-key-sequence's
- key decoding rather than do it manually via last-input-event +
- ascii-character.
- (term-exec): Use delete-and-extract-region.
- (term-handle-ansi-terminal-messages): Remove unused var `end'.
- (term-process-pager): Remove unused var `i'.
- (term-dynamic-simple-complete): Make obsolete.
- (serial-update-config-menu): Remove unused vars `y' and `str'.
- (term-update-mode-line): Remove unused var `temp'.
-
-2009-12-03 Dan Nicolaescu <dann@ics.uci.edu>
-
- Limit the number of log entries displayed by default.
- * vc.el (vc-print-log-internal): Fix check for limit-unsupported.
- (vc-print-log, vc-print-root-log): Use vc-log-show-limit when not
- using a prefix argument.
-
-2009-12-03 Glenn Morris <rgm@gnu.org>
-
- * progmodes/idlwave.el (class): Restore still useful declaration.
-
-2009-12-03 Alan Mackenzie <acm@muc.de>
-
- Enhance `c-parse-state' to run efficiently in "brace deserts".
-
- * progmodes/cc-mode.el (c-basic-common-init):
- Call c-state-cache-init.
- (c-neutralize-syntax-in-and-mark-CPP): Rename from
- c-extend-and-neutralize-syntax-in-CPP. Mark each CPP construct by
- placing `category' properties value 'c-cpp-delimiter at its boundaries.
-
- * progmodes/cc-langs.el (c-before-font-lock-function):
- c-extend-and-neutralize-syntax-in-CPP has been renamed
- c-neutralize-syntax-in-and-mark-CPP.
-
- * progmodes/cc-fonts.el (c-cpp-matchers): Mark template brackets
- with `category' properties now, not `syntax-table' ones.
-
- * progmodes/cc-engine.el (c-syntactic-end-of-macro): A new
- enhanced (but slower) version of c-end-of-macro that won't land
- inside a literal or on another awkward character.
- (c-state-cache-too-far, c-state-cache-start)
- (c-state-nonlit-pos-interval, c-state-nonlit-pos-cache)
- (c-state-nonlit-pos-cache-limit, c-state-point-min)
- (c-state-point-min-lit-type, c-state-point-min-lit-start)
- (c-state-min-scan-pos, c-state-brace-pair-desert)
- (c-state-old-cpp-beg, c-state-old-cpp-end): New constants and
- buffer local variables.
- (c-state-literal-at, c-state-lit-beg)
- (c-state-cache-non-literal-place, c-state-get-min-scan-pos)
- (c-state-mark-point-min-literal, c-state-cache-top-lparen)
- (c-state-cache-top-paren, c-state-cache-after-top-paren)
- (c-get-cache-scan-pos, c-get-fallback-scan-pos)
- (c-state-balance-parens-backwards, c-parse-state-get-strategy)
- (c-renarrow-state-cache)
- (c-append-lower-brace-pair-to-state-cache)
- (c-state-push-any-brace-pair, c-append-to-state-cache)
- (c-remove-stale-state-cache)
- (c-remove-stale-state-cache-backwards, c-state-cache-init)
- (c-invalidate-state-cache-1, c-parse-state-1)
- (c-invalidate-state-cache): New defuns/defmacros/defsubsts.
- (c-parse-state): Enhance and refactor.
- (c-debug-parse-state): Amend to deal with all the new variables.
-
- * progmodes/cc-defs.el (c-<-as-paren-syntax, c-mark-<-as-paren)
- (c->-as-paren-syntax, c-mark->-as-paren, c-unmark-<->-as-paren):
- modify to use category text properties rather than syntax-table ones.
- (c-suppress-<->-as-parens, c-restore-<->-as-parens): New defsubsts
- to switch off/on the syntactic paren property of C++ template
- delimiters using the category property.
- (c-with-<->-as-parens-suppressed): Macro to invoke code with
- template delims suppressed.
- (c-cpp-delimiter, c-set-cpp-delimiters, c-clear-cpp-delimiters):
- New constant/macros which apply category properties to the start
- and end of preprocessor constructs.
- (c-comment-out-cpps, c-uncomment-out-cpps): Defsubsts which
- "comment out" the syntactic value of characters in preprocessor
- constructs.
- (c-with-cpps-commented-out)
- (c-with-all-but-one-cpps-commented-out): Macros to invoke code
- with characters in all or all but one preprocessor constructs
- "commented out".
-
-2009-12-03 Roland Winkler <Roland.Winkler@physik.uni-erlangen.de>
-
- * proced.el (proced-filter-alist): Use regexp-quote.
-
-2009-12-03 Michael Albinus <michael.albinus@gmx.de>
-
- Cleanup.
- * eshell/em-unix.el (top): Require 'esh-opt and 'pcomplete.
- (eshell/su, eshell/sudo): Require 'tramp. Fix problems reading
- arguments. Expand `default-directory'.
-
- * net/tramp.el (tramp-handle-file-remote-p): Expand FILENAME for
- the benefit of returning an expanded localname.
- (tramp-tramp-file-p): Handle the case NAME is not a string.
-
-2009-12-03 Dan Nicolaescu <dann@ics.uci.edu>
-
- Add support for bzr shelve/unshelve.
- * vc-bzr.el (vc-bzr-shelve-map, vc-bzr-shelve-menu-map)
- (vc-bzr-extra-menu-map): New variables.
- (vc-bzr-extra-menu, vc-bzr-extra-status-menu, vc-bzr-shelve)
- (vc-bzr-shelve-apply, vc-bzr-shelve-list)
- (vc-bzr-shelve-get-at-point, vc-bzr-shelve-delete-at-point)
- (vc-bzr-shelve-apply-at-point, vc-bzr-shelve-menu): New functions.
- (vc-bzr-dir-extra-headers): Display shelves.
-
- * vc-bzr.el (vc-bzr-print-log): Deal with nil arguments better.
-
-2009-12-03 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * textmodes/bibtex.el (bibtex-complete-internal):
- Use completion-in-region.
- (bibtex-text-in-field-bounds): Remove unused var `opoint'.
-
-2009-12-03 Dan Nicolaescu <dann@ics.uci.edu>
-
- Support applying stashes. Improve UI.
- * vc-git.el (vc-git-dir-extra-headers): Add tooltips.
- (vc-git-stash-apply, vc-git-stash-pop)
- (vc-git-stash-apply-at-point, vc-git-stash-pop-at-point)
- (vc-git-stash-menu): New functions.
- (vc-git-stash-menu-map): New variable.
- (vc-git-stash-map): Add bindings to popup a menu and to apply stashes.
-
-2009-12-03 Glenn Morris <rgm@gnu.org>
-
- * vc.el (log-view-vc-backend, log-view-vc-fileset): Declare.
- (vc-print-log-internal): Fix previous change.
- (vc-revert): Correct pluralization.
-
-2009-12-03 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * progmodes/make-mode.el (makefile-special-targets-list): No need for
- it to be an alist any more.
- (makefile-complete): Use completion-in-region.
-
- * progmodes/octave-mod.el (octave-complete-symbol):
- Use completion-in-region.
-
- Misc cleanup.
- * progmodes/idlwave.el (idlwave-comment-hook): Simplify with `or'.
- (idlwave-code-abbrev, idlwave-display-user-catalog-widget)
- (idlwave-complete-class): Don't quote lambda.
- (idlwave-find-symbol-syntax-table, idlwave-mode-syntax-table)
- (idlwave-mode-map): Move initialization into declaration.
- (idlwave-action-and-binding): Use backquotes.
- (idlwave-in-quote, idlwave-reset-sintern, idlwave-complete-in-buffer):
- Simplify.
- (idlwave-is-pointer-dereference): Remove unused var `pos'.
- (idlwave-xml-create-rinfo-list): Remove unused var `entry'.
- (idlwave-convert-xml-clean-sysvar-aliases): Remove unused vars `new',
- `parts', and `all-parts'.
- (idlwave-xml-create-sysvar-alist): Remove unused var `fields'.
- (idlwave-convert-xml-system-routine-info): Remove unused string
- `version-string'.
- (idlwave-display-user-catalog-widget): Use dolist.
- (idlwave-scanning-lib): Declare dynamically-scoped var.
- (idlwave-scan-library-catalogs): Remove unused var `flags'.
- (completion-highlight-first-word-only): Declare to silence bytecomp.
- (idlwave-popup-select): Tighten scope of `resp'.
- (idlwave-find-struct-tag): Remove unused var `beg'.
- (idlwave-after-load-rinfo-hook): Declare.
- (idlwave-sintern-class-info): Remove unused var `taglist'.
- (idlwave-find-class-definition): Remove unused var `list'.
- (idlwave-complete-sysvar-tag-help): Remove unused var `main-base'.
- (idlwave-what-module-find-class): Remove unused var `classes'.
-
-2009-12-03 Juanma Barranquero <lekktu@gmail.com>
-
- * progmodes/pascal.el: Require CL when compiling (for lexical-let).
-
-2009-12-03 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * hippie-exp.el (try-expand-dabbrev-visible): Preserve point in the
- buffers visited. Remove redundant current-buffer-saving.
-
-2009-12-02 Stefan Monnier <monnier@iro.umontreal.ca>
-
- Use completion-in-buffer and remove uses of dynamic scoping.
- * progmodes/pascal.el (pascal-str, pascal-all, pascal-pred)
- (pascal-buffer-to-use, pascal-flag): Don't declare.
- (pascal-func-completion, pascal-type-completion, pascal-var-completion)
- (pascal-get-completion-decl, pascal-keyword-completion):
- Add `pascal-str' argument, save-excursion,
- return the found completions, and don't filter with pascal-pred.
- (pascal-completion-cache): New var.
- (pascal-completion): Don't switch buffer any more (it was never
- necessary). Don't save-excursion any more (it's done by the called
- subroutines). Use a cache to avoid redundant computations.
- Use complete-with-action rather than pascal-completion-response and
- let it apply the predicate as well.
- (pascal-complete-word): Use completion-in-buffer when
- pascal-toggle-completions is nil.
- (pascal-show-completions): Don't bind pascal-buffer-to-use since it's
- not used any more.
- (pascal-comp-defun): Don't change buffer any more.
- Use complete-with-action rather than pascal-completion-response and
- let it apply the predicate as well.
- (pascal-goto-defun): Change buffer before calling pascal-comp-defun
- when neded.
-
-2009-12-02 Kenichi Handa <handa@m17n.org>
-
- * language/indian.el: Include ZWJ and ZWNJ in the patterns to
- shape for all Indic scripts.
-
-2009-12-02 Stefan Monnier <monnier@iro.umontreal.ca>
-
- Use completion-in-buffer.
- * wid-edit.el (widget-field-text-end): New function.
- (widget-field-value-get): Use it.
- (widget-string-complete, widget-file-complete)
- (widget-color-complete): Use it and completion-in-region.
- (widget-complete): Don't narrow the buffer.
-
-2009-12-02 Glenn Morris <rgm@gnu.org>
-
- * mail/rmail.el (rmail-pop-to-buffer): New function. (Bug#2282)
- (rmail-select-summary): Use rmail-pop-to-buffer.
- * mail/rmailsum.el: Replace all pop-to-buffer calls with
- rmail-pop-to-buffer, to prevent horizontal splits.
-
- * calendar/diary-lib.el (diary-list-entries): Replace superfluous
- save-excursion with save-current-buffer.
- Widen before searching. (Bug#5093)
- (diary-list-sexp-entries): Remove superfluous save-excursion.
-
-2009-12-02 Michael Welsh Duggan <mwd@cert.org>
-
- * woman.el (woman-make-bufname): Handle man-pages with "." in the
- name. (Bug#5038)
-
-2009-12-02 Andreas Politz <politza@fh-trier.de> (tiny change)
-
- * ido.el (ido-file-internal): Handle filenames at point that do
- not have a directory part. (Bug#5049)
-
-2009-12-02 Juanma Barranquero <lekktu@gmail.com>
-
- * mpc.el (mpc-intersection, mpc-host, mpc-songs-playlist)
- (mpc-songs-jump-to, mpc-resume): Doc fixes.
-
-2009-12-01 Rob Riepel <riepel@networking.Stanford.EDU>
-
- * emulation/tpu-extras.el (tpu-cursor-free-mode): Emit message.
- (tpu-set-cursor-free, tpu-set-cursor-bound): Don't emit a message
- any more.
-
-2009-12-01 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * comint.el (comint-insert-input): Ignore clicks to the right of
- the field. Reported by Bob Nnamtrop <bobnnamtrop@gmail.com>.
-
- * vc.el (vc-print-log-internal): Don't wait for the process to
- terminate before setting up the major mode.
-
- * pcmpl-unix.el (pcomplete/cd): Complete more than one argument, just
- in case.
-
- * pcomplete.el (pcomplete-std-complete): Don't try to complete past
- the last element.
-
- * simple.el (normal-erase-is-backspace-mode): Fix thinko in message.
-
-2009-12-01 Glenn Morris <rgm@gnu.org>
-
- * window.el (window--display-buffer-2): Fix previous changes.
-
-2009-12-01 Chong Yidong <cyd@stupidchicken.com>
-
- * mail/sendmail.el (mail-setup-hook, mail-send-hook): Doc fixes.
-
-2009-12-01 Glenn Morris <rgm@gnu.org>
-
- * Makefile.in (ELCFILES): Add mpc.elc.
-
-2009-12-01 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * mpc.el: New file.
-
-2009-12-01 Glenn Morris <rgm@gnu.org>
-
- * window.el (window-to-use): Define for compiler.
-
- * emacs-lisp/bytecomp.el (byte-compile-save-excursion): Make message
- consistent with others (no final period).
-
- * mail/rmailmm.el (rmail-mime-handle): Doc fix.
- (rmail-mime-show): Downcase the encoding. (Bug#5070)
-
-2009-12-01 Dan Nicolaescu <dann@ics.uci.edu>
-
- Make vc-print-log buttons work.
- * log-view.el (log-view-mode-map): Inherit from widget-keymap.
+2011-05-08 Ralph Schleicher <rs@ralph-schleicher.de>
-2009-11-30 Ryan C. Thompson <rct@thompsonclan.org> (tiny change)
+ * progmodes/perl-mode.el (perl-imenu-generic-expression):
+ Only match variables declared via `my' or `our' (Bug#8261).
- * savehist.el (savehist-autosave-interval): Allow setting to nil
- through customize. (Bug#5056)
+ * net/browse-url.el (browse-url-of-dired-file): Allow browsing of
+ special file names `.' and `..' (Bug#8259).
-2009-11-30 Juanma Barranquero <lekktu@gmail.com>
+2011-05-08 Chong Yidong <cyd@stupidchicken.com>
- Fix references to jit-lock properties.
- * progmodes/perl-mode.el (perl-font-lock-syntactic-keywords):
- Refer to jit-lock-defer-multiline, not jit-lock-multiline.
- (perl-font-lock-special-syntactic-constructs):
- Quote jit-lock-defer-multiline property.
+ * progmodes/grep.el (grep-mode-font-lock-keywords):
+ Remove buffer-changing entries.
+ (grep-filter): New function.
+ (grep-mode): Add it to compilation-filter-hook.
-2009-11-30 Dan Nicolaescu <dann@ics.uci.edu>
+ * progmodes/compile.el (compilation-filter-hook)
+ (compilation-filter-start): New defvars.
+ (compilation-filter): Call compilation-filter-hook prior to
+ updating the process mark.
- * vc-git.el (vc-git-registered): Call vc-git-root only once.
+2011-05-08 Stefan Monnier <monnier@iro.umontreal.ca>
-2009-11-30 Juri Linkov <juri@jurta.org>
+ * emacs-lisp/eieio.el (defmethod): Fix typo in last change.
- * misearch.el (multi-isearch-search-fun): Always provide a non-nil
- value `buffer' of `multi-isearch-next-buffer-current-function'.
- Use `(current-buffer)' when `buffer' is nil.
- (multi-isearch-next-buffer-from-list): Don't fallback to
- `(current-buffer)' when `buffer' is nil. (Bug#4947)
+2011-05-07 Eli Zaretskii <eliz@gnu.org>
-2009-11-30 Juri Linkov <juri@jurta.org>
+ * mail/sendmail.el (send-mail-function): On MS-Windows, default to
+ mailclient-send-it even if window-system is nil. (Bug#8595)
- * misearch.el (multi-isearch-read-buffers): Move canonicalization
- of buffers with `get-buffer' to `multi-isearch-buffers'.
- (multi-isearch-buffers, multi-isearch-buffers-regexp):
- Canonicalize BUFFERS with `get-buffer'. Doc fix.
- (multi-isearch-files, multi-isearch-files-regexp): Canonicalize
- FILES with `expand-file-name' converting relative file names
- to absolute. Doc fix. (Bug#4727)
+ * term/w32console.el (terminal-init-w32console):
+ Call get-screen-color and use its output to set the frame
+ background-mode. (Bug#8597)
-2009-11-30 Juri Linkov <juri@jurta.org>
+2011-05-07 Stefan Monnier <monnier@iro.umontreal.ca>
- * misearch.el (multi-isearch-read-buffers)
- (multi-isearch-read-matching-buffers): New functions.
- (multi-isearch-buffers, multi-isearch-buffers-regexp):
- Use them in the `interactive' spec. Doc fix.
- (multi-isearch-read-files, multi-isearch-read-matching-files):
+ Make bytecomp.el understand that defmethod defines funs (bug#8631).
+ * emacs-lisp/eieio.el (eieio--defalias, eieio--defgeneric-init-form):
New functions.
- (multi-isearch-files, multi-isearch-files-regexp):
- Use them in the `interactive' spec. Doc fix. (Bug#4725)
-
-2009-11-30 Juri Linkov <juri@jurta.org>
-
- * doc-view.el (doc-view-continuous):
- Rename from `doc-view-continuous-mode'.
- (doc-view-menu): Move "Toggle display" to the top.
- Add submenu "Continuous" with radio buttons "Off"/"On"
- and "Save as Default".
- (doc-view-scroll-up-or-next-page)
- (doc-view-scroll-down-or-previous-page)
- (doc-view-next-line-or-next-page)
- (doc-view-previous-line-or-previous-page):
- Rename `doc-view-continuous-mode' to `doc-view-continuous'. (Bug#4896)
-
-2009-11-30 Juri Linkov <juri@jurta.org>
-
- * comint.el (comint-mode-map): Rebind `M-r' from
- `comint-previous-matching-input' to
- `comint-history-isearch-backward-regexp'.
- Unbind `M-s' to allow global key binding `M-s'.
- Add menu items for `comint-history-isearch-backward' and
- `comint-history-isearch-backward-regexp'. (Bug#3746)
-
-2009-11-30 Juri Linkov <juri@jurta.org>
-
- * replace.el (perform-replace): Let-bind recenter-last-op to nil.
- For def=recenter, replace `recenter' with `recenter-top-bottom'
- that is called with `this-command' and `last-command' let-bound
- to `recenter-top-bottom'. When the last `def' was not `recenter',
- set `recenter-last-op' to nil. (Bug#4981)
-
-2009-11-30 Stefan Monnier <monnier@iro.umontreal.ca>
-
- Minor cleanup and simplification.
- * filecache.el (file-cache-add-directory)
- (file-cache-add-directory-recursively)
- (file-cache-add-from-file-cache-buffer)
- (file-cache-delete-file-regexp, file-cache-delete-directory)
- (file-cache-files-matching-internal, file-cache-display): Use dolist.
- (file-cache-temp-minibuffer-message): Delete function.
- (file-cache-minibuffer-complete): Use minibuffer-message instead.
-
- * progmodes/perl-mode.el (perl-font-lock-special-syntactic-constructs):
- Don't signal an error when bumping into EOB in tr, s, or y.
-
-2009-11-29 Juri Linkov <juri@jurta.org>
-
- * startup.el (fancy-about-text): Fix wording of Guided Tour.
- (Bug#4960)
-
- * descr-text.el (describe-char-unidata-list): Use lowercase name
- for "Unicode name" like in other tags.
-
-2009-11-29 Juri Linkov <juri@jurta.org>
-
- * ediff-util.el (ediff-minibuffer-with-setup-hook):
- New compatibility macro.
- (ediff-read-file-name): Use it instead of `minibuffer-with-setup-hook'.
-
-2009-11-29 Juri Linkov <juri@jurta.org>
-
- Add defcustom to define the cycling order of `recenter-top-bottom'.
- (Bug#4981)
-
- * window.el (recenter-last-op): Doc fix.
- (recenter-positions): New defcustom.
- (recenter-top-bottom): Rewrite to use `recenter-positions'.
- (move-to-window-line-top-bottom): Rewrite to use `recenter-positions'.
-
-2009-11-29 Michael Albinus <michael.albinus@gmx.de>
-
- Improve integration of Tramp and ange-ftp in eshell.
-
- * eshell/em-unix.el (eshell/whoami): Make it a defun but a defalias.
- (eshell/su): Flatten args. Apply better args parsing. Use "cd".
- (eshell/sudo): Flatten args. Let-bind `default-directory'.
-
- * eshell/esh-util.el (top): Require also Tramp when compiling.
- (eshell-directory-files-and-attributes): Check for FTP remote
- connection.
- (eshell-parse-ange-ls): Let-bind `ange-ftp-name-format',
- `ange-ftp-ftp-name-arg', `ange-ftp-ftp-name-res'.
- (eshell-file-attributes): Handle ".". Return `entry'.
-
- * net/ange-ftp.el (ange-ftp-parse-filename): Use `save-match-data'.
- (ange-ftp-directory-files-and-attributes)
- (ange-ftp-real-directory-files-and-attributes): New defuns.
-
- * net/tramp.el (tramp-maybe-open-connection): Open the remote
- shell with "exec" when possible. This prevents trailing prompts
- in `start-file-process'.
-
-2009-11-28 Stefan Monnier <monnier@iro.umontreal.ca>
-
- Try and remove assumptions about point-min==1.
- * nxml/rng-valid.el (rng-validate-mode): Don't hardcode point-min==1.
- (rng-compute-mode-line-string): Show the validation percentage in
- terms of the narrowed text, not the widened text.
- (rng-do-some-validation): Don't catch internal errors when debugging.
- (rng-first-error): Simplify.
- (rng-after-change-function): Remove work around. AFAIK the bug has
- been fixed a while ago.
-
- * image-mode.el (image-minor-mode): Exit more gracefully when the image
- cannot be displayed (e.g. when doing C-x C-f some-new-file.svg RET).
-
- * man.el (Man-completion-table): Make it easier to enter "<sec> <name>".
-
- * eshell/em-prompt.el (eshell-prompt-function): Abbreviate pwd, since
- `cd' doesn't always do it for us (bug#5067).
-
- * pcomplete.el (pcomplete-entries): Revert change installed mistakenly
- on 2009-10-25 as part of some other change (bug#5067).
-
-2009-11-27 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * emacs-lisp/bytecomp.el (byte-compile-warning-types): New type
- `suspicious'.
- (byte-compile-warnings): Use byte-compile-warning-types.
- (byte-compile-save-excursion): Warn about use of set-buffer right
- after save-excursion.
-
- * progmodes/gud.el (gud-basic-call): Don't only save the buffer but
- the excursion as well.
-
-2009-11-27 Michael Albinus <michael.albinus@gmx.de>
-
- * eshell/em-unix.el (eshell/su, eshell/sudo): New defuns,
- providing a Tramp related implementation of "su" and "sudo".
- (eshell-unix-initialize): Add "su" and "sudo".
-
-2009-11-27 Daiki Ueno <ueno@unixuser.org>
-
- * net/socks.el (socks-send-command): Convert binary request to
- unibyte before sending. This fixes mishandling of some port
- numbers such as 129.
-
-2009-11-27 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * help.el (describe-bindings-internal): Remove `interactive'.
-
- * man.el (Man-completion-table): Trim a terminating "(".
- Remove the space between name page a section.
- Add the command's description on the `help-echo' property.
- Remove `process-connection-type' binding since it's unused by
- call-process.
- Provide completion for the "<section> <name>" format as well.
- (Man-default-man-entry): Remove spurious var shadowing the argument.
-
-2009-11-26 Kevin Ryde <user42@zip.com.au>
-
- * log-view.el: Add "Keywords: tools", since its other keywords
- aren't in finder-known-keywords, and following vc.el.
-
- * sha1.el (sha1-string-external): default-directory "/" in case
- otherwise non-existent. process-connection-type pipe for touch of
- efficiency recommended by elisp manual. (An aside in Bug#3911.)
-
-2009-11-26 Stefan Monnier <monnier@iro.umontreal.ca>
-
- Misc coding convention cleanups.
- * htmlfontify.el (hfy-init-kludge-hook): Rename from
- hfy-init-kludge-hooks.
- (hfy-etags-cmd, hfy-flatten-style, hfy-invisible-name, hfy-face-at)
- (hfy-fontify-buffer, hfy-prepare-index-i, hfy-subtract-maps)
- (hfy-save-kill-buffers, htmlfontify-copy-and-link-dir): Use dolist
- and push.
- (hfy-slant, hfy-weight): Use tables rather than code.
- (hfy-box-to-border-assoc, hfy-box-to-style, hfy-decor)
- (hfy-face-to-style-i, hfy-fontify-buffer): Use `case'.
- (hfy-face-attr-for-class): Initialize `face-spec' directly.
- (hfy-face-to-css): Remove `nconc' with single arg.
- (hfy-p-to-face-lennart): Use `or'.
- (hfy-face-at): Hoist common code. Remove spurious quotes in `case'.
- (hfy-overlay-props-at, hfy-mark-tag-hrefs): Eta-reduce.
- (hfy-compile-stylesheet, hfy-merge-adjacent-spans)
- (hfy-compile-face-map, hfy-parse-tags-buffer): Use push.
- (hfy-force-fontification): Use run-hooks.
-
-2009-11-26 Vivek Dasmohapatra <vivek@etla.org>
-
- Various minor fixes.
- * htmlfontify.el (hfy-default-header): Add toggle_invis since
- Javascript belongs in the header, not the body.
- (hfy-javascript): Remove.
- (hfy-fontify-buffer): Don't insert it any more.
- (hfy-face-at): Handle (face0 face1 face2) style face properties.
- Fix bug in invis handling when there were no invis props in a chunk.
-
-2009-11-26 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * vc-bzr.el (vc-bzr-annotate-command): Make operation asynchronous.
-
-2009-11-26 Dan Nicolaescu <dann@ics.uci.edu>
-
- * finder.el (finder-mode-map): Add a menu.
-
-2009-11-26 Michael McNamara <mac@mail.brushroad.com>
-
- * progmodes/verilog-mode.el (verilog-at-struct-p): Support "signed" and
- "unsigned" structs.
-
- (verilog-leap-to-head, verilog-backward-token): Handle "disable
- fork" statement better.
-
-2009-11-26 Wilson Snyder <wsnyder@wsnyder.org>
-
- * progmodes/verilog-mode.el (verilog-auto-insert-lisp)
- (verilog-delete-auto, verilog-delete-empty-auto-pair)
- (verilog-library-filenames): Fix AUTOINSERTLISP to support insert-file.
- Reported by Clay Douglass.
-
- (verilog-auto-inst, verilog-auto-star-safe)
- (verilog-delete-auto-star-implicit, verilog-read-sub-decls):
- Fix removing "// Interfaces" when saving .* expansions.
- Reported by Pierre-David Pfister.
-
-2009-11-26 Glenn Morris <rgm@gnu.org>
-
- * eshell/em-dirs.el (eshell/cd): Don't throw to a tag outside
- the scope.
-
-2009-11-25 Johan Bockgård <bojohan@gnu.org>
-
- * vc-annotate.el (vc-annotate-revision-previous-to-line):
- Really use previous revision.
-
-2009-11-25 Kevin Ryde <user42@zip.com.au>
-
- * man.el (Man-completion-table): default-directory "/" in case
- doesn't otherwise exist. process-environment COLUMNS=999 so as
- not to truncate long names. process-connection-type pipe to avoid
- any chance of hitting the pseudo-tty TIOCGWINSZ.
- (man): completion-ignore-case t for friendliness and since man
- itself is case-insensitive on the command line.
- Further to Bug#3717.
-
- * arc-mode.el: Add "Keywords: files", so the details in its
- commentary can be reached from finder-by-keyword.
- * textmodes/dns-mode.el: Add "Keywords: comm". It's only an
- editing mode, but it's comms related and sgml-mode.el has "comm"
- on that basis too.
- * textmodes/bibtex-style.el: Add "Keywords: tex".
- * international/isearch-x.el, international/ja-dic-cnv.el:
- * international/ja-dic-utl.el, international/kkc.el:
- Add "Keywords: i18n", so they can be reached from finder-by-keyword.
-
-2009-11-25 Juri Linkov <juri@jurta.org>
-
- * man.el (Man-completion-table): Modify regexp to include
- section names to completion strings. (Bug#3717)
-
-2009-11-25 Juri Linkov <juri@jurta.org>
-
- Search recursively in gzipped files. (Bug#4982)
-
- * progmodes/grep.el (grep-highlight-matches): Add new options
- `always' and `auto'. Doc fix.
- (grep-process-setup): Check `grep-highlight-matches' for
- `auto-detect' to determine the need to compute grep defaults.
- Move Windows/DOS specific --colors settings handling
- to `grep-compute-defaults'. Check `grep-highlight-matches'
- to get the value of "--color=".
- (grep-compute-defaults): Compute `grep-highlight-matches' when it
- has the value `auto-detect'. Move Windows/DOS specific settings
- from `grep-process-setup'.
- (zrgrep): New command with alias `rzgrep'.
-
-2009-11-25 Juri Linkov <juri@jurta.org>
-
- * doc-view.el (doc-view-mode): Set buffer-local `view-read-only'
- to nil instead of switching off view-mode. (Bug#4896)
-
-2009-11-25 Juri Linkov <juri@jurta.org>
-
- Mouse-wheel scrolling for DocView Continuous mode. (Bug#4896)
-
- * mwheel.el (mwheel-scroll-up-function)
- (mwheel-scroll-down-function): New defvars.
- (mwheel-scroll): Funcall `mwheel-scroll-up-function' instead of
- `scroll-up', and `mwheel-scroll-down-function' instead of
- `scroll-down'.
-
- * doc-view.el (doc-view-scroll-up-or-next-page)
- (doc-view-scroll-down-or-previous-page): Add optional ARG.
- Use this ARG in the call to image-scroll-up/image-scroll-down.
- Change `interactive' spec to "P". Goto next/previous page only
- when `doc-view-continuous-mode' is non-nil or ARG is nil (for the
- SPC/DEL case). Doc fix.
- (doc-view-next-line-or-next-page)
- (doc-view-previous-line-or-previous-page): Rename arg to ARG
- for consistency.
- (doc-view-mode): Set buffer-local `mwheel-scroll-up-function' to
- `doc-view-scroll-up-or-next-page', and buffer-local
- `mwheel-scroll-down-function' to
- `doc-view-scroll-down-or-previous-page'.
-
-2009-11-25 Juri Linkov <juri@jurta.org>
-
- Provide additional default values (directories at other Dired
- windows) via M-n in the minibuffer of some Dired commands.
-
- * dired-aux.el (dired-diff, dired-compare-directories)
- (dired-do-create-files): Use `dired-dwim-target-defaults' to set
- `minibuffer-default' in `minibuffer-with-setup-hook'.
- (dired-dwim-target-directory): Find a window that displays Dired
- buffer instead of failing when the next window is not Dired.
- Use `get-window-with-predicate' to find for the next Dired window.
- (dired-dwim-target-defaults): New function.
-
- * ediff-util.el (ediff-read-file-name):
- Use `dired-dwim-target-defaults' to set `minibuffer-default'
- in `minibuffer-with-setup-hook'.
-
-2009-11-25 Juri Linkov <juri@jurta.org>
-
- Provide additional default values (file name at point or at the
- current Dired line) via M-n for file reading minibuffers. (Bug#5010)
-
- * minibuffer.el (read-file-name-defaults): New function.
- (read-file-name): Reset `minibuffer-default' to nil when
- it duplicates initial input `insdef'.
- Bind `minibuffer-default-add-function' to lambda that
- calls `read-file-name-defaults' in `minibuffer-selected-window'.
- (minibuffer-insert-file-name-at-point): New command.
-
- * files.el (file-name-at-point-functions): New defcustom.
- (find-file-default): Remove defvar.
- (find-file-read-args): Don't use `find-file-default'.
- Move `minibuffer-with-setup-hook' that sets `minibuffer-default'
- to `read-file-name'.
- (find-file-literally): Use `read-file-name' with
- `confirm-nonexistent-file-or-buffer'.
-
- * ffap.el (ffap-guess-file-name-at-point): New autoloaded function.
-
- * dired.el (dired-read-dir-and-switches):
- Move `minibuffer-with-setup-hook' that sets `minibuffer-default'
- to `read-file-name'.
- (dired-file-name-at-point): New function.
- (dired-mode): Add hook `dired-file-name-at-point' to
- `file-name-at-point-functions'.
+ (defgeneric, eieio--defmethod): Use them.
+ (eieio-defgeneric): Remove.
+ (defmethod): Call defgeneric in a way visible to the byte-compiler.
-2009-11-25 Stefan Monnier <monnier@iro.umontreal.ca>
+2011-05-07 Glenn Morris <rgm@gnu.org>
- Really make the *Completions* window soft-dedicated (bug#5030).
- * window.el (window--display-buffer-2): Add `dedicated' argument.
- (display-buffer): Pass it when needed so the dedicated flag is set
- after calling set-window-buffer, which would otherwise reset it.
+ * calendar/timeclock.el (timeclock-log-data): Remove unused local.
+ Use let rather than let*.
+ (timeclock-find-discrep): Remove unused local.
-2009-11-25 Stefan Monnier <monnier@iro.umontreal.ca>
+ * calendar/diary-lib.el (diary-comment-start): Doc fix.
- * progmodes/meta-mode.el (meta-complete-symbol):
- * progmodes/etags.el (complete-tag):
- * mail/mailabbrev.el (mail-abbrev-complete-alias):
- Use completion-in-region.
-
- * dabbrev.el (dabbrev--minibuffer-origin): Use minibuffer-selected-window.
- (dabbrev-completion): Use completion-in-region.
- (dabbrev--abbrev-at-point): Simplify regexp.
-
- * abbrev.el (abbrev--before-point): Use word-motion functions
- if :regexp is not specified (bug#5031).
-
- * subr.el (string-prefix-p): New function.
-
- * man.el (Man-completion-cache): New var.
- (Man-completion-table): Use it.
-
- * vc.el (vc-print-log-internal): Make `limit' optional for better
- compatibility (e.g. with vc-annotate.el).
-
-2009-11-24 Kevin Ryde <user42@zip.com.au>
-
- * emacs-lisp/checkdoc.el (checkdoc-proper-noun-regexp):
- Build value with regexp-opt instead of explicit joining loop. (Bug#4927)
-
- * emacs-lisp/elint.el (elint-add-required-env): Better error message
- when .el source file not found or other error.
-
-2009-11-24 Markus Triska <markus.triska@gmx.at>
-
- * linum.el (linum-update-window): Ignore intangible (bug#4996).
-
-2009-11-24 Stefan Monnier <monnier@iro.umontreal.ca>
-
- Handle the [back] button properly (bug#4979).
- * descr-text.el (describe-text-properties): Add a `buffer' argument.
- Use help-setup-xref, help-buffer, and with-help-window.
- (describe-char): Add `buffer' argument.
- Pass proper command to help-setup-xref. Don't meddle with
- help-xref-stack-item directly.
- (describe-text-category): Use with-help-window and help-buffer.
-
- * emacs-lisp/shadow.el (list-load-path-shadows): Setup a major mode
- for the displayed buffer (bug#4887).
-
- * man.el (Man-completion-table): New function.
- (man): Use it.
-
-2009-11-24 David Reitter <david.reitter@gmail.com>
-
- * vc-git.el (vc-git-registered): Use checkout directory (where
- .git is) rather than the file's directory and a relative path spec
- to work around a bug in git.
-
-2009-11-24 Michael Albinus <michael.albinus@gmx.de>
-
- Improve handling of processes on remote hosts.
-
- * eshell/esh-util.el (eshell-path-env): New defvar.
- (eshell-parse-colon-path): New defun.
- (eshell-file-attributes): Use `eshell-parse-colon-path'.
-
- * eshell/esh-ext.el (eshell-search-path):
- Use `eshell-parse-colon-path'.
- (eshell-remote-command): Remove argument HANDLER.
- (eshell-external-command): Check for FTP remote connection.
-
- * eshell/esh-proc.el (eshell-gather-process-output):
- Use `file-truename', in order to start also symlinked files.
- Apply `start-file-process' instead of `start-process'.
- Shorten `command' to the local file name part.
-
- * eshell/em-cmpl.el (eshell-complete-commands-list):
- Use `eshell-parse-colon-path'.
-
- * eshell/em-unix.el (eshell/du): Check for FTP remote connection.
-
- * net/tramp.el (tramp-eshell-directory-change): New defun. Add it
- to `eshell-directory-change-hook'.
-
-2009-11-24 Tassilo Horn <tassilo@member.fsf.org>
-
- * doc-view.el (doc-view-mode): Switch off view-mode explicitly,
- because it could be enabled automatically if view-read-only is non-nil.
-
-2009-11-24 Michael Kifer <kifer@cs.stonybrook.edu>
-
- * ediff-vers.el (ediff-rcs-get-output-buffer): Revert the change
- made on 2009-11-22.
-
-2009-11-24 Glenn Morris <rgm@gnu.org>
-
- * bookmark.el (bookmark-bmenu-hide-filenames): Remove assignment to
- deleted variable bookmark-bmenu-bookmark-column.
-
-2009-11-24 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * bookmark.el (bookmark-bmenu-search): Clear echo area when exiting.
-
-2009-11-23 Ken Brown <kbrown@cornell.edu> (tiny change)
-
- * net/browse-url.el (browse-url-filename-alist): On Windows, add
- two slashes to the "file:" prefix.
- (browse-url-file-url): De-munge Cygwin filenames before passing
- them to Windows browser.
- (browse-url-default-windows-browser): Use call-process.
-
-2009-11-23 Juri Linkov <juri@jurta.org>
-
- Implement DocView Continuous mode. (Bug#4896)
- * doc-view.el (doc-view-continuous-mode): New defcustom.
- (doc-view-mode-map): Bind C-n/<down> to
- `doc-view-next-line-or-next-page', C-p/<up> to
- `doc-view-previous-line-or-previous-page'.
- (doc-view-next-line-or-next-page)
- (doc-view-previous-line-or-previous-page): New commands.
-
-2009-11-23 Juri Linkov <juri@jurta.org>
-
- Implement Isearch in comint input history. (Bug#3746)
- * comint.el (comint-mode): Add `comint-history-isearch-setup' to
- `isearch-mode-hook'.
- (comint-history-isearch): New defcustom.
- (comint-history-isearch-backward)
- (comint-history-isearch-backward-regexp): New commands.
- (comint-history-isearch-message-overlay): New buffer-local variable.
- (comint-history-isearch-setup, comint-history-isearch-end)
- (comint-goto-input, comint-history-isearch-search)
- (comint-history-isearch-message, comint-history-isearch-wrap)
- (comint-history-isearch-push-state)
- (comint-history-isearch-pop-state): New functions.
-
-2009-11-23 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-shell-prompt-pattern): Use \r for carriage
- return.
- (tramp-handle-make-symbolic-link)
- (tramp-handle-dired-compress-file, tramp-handle-expand-file-name):
- Quote file names.
- (tramp-send-command-and-check): New argument DONT-SUPPRESS-ERR.
- (tramp-handle-process-file): Use it.
-
-2009-11-23 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * window.el (move-to-window-line-last-op): Remove.
- (move-to-window-line-top-bottom): Reuse recenter-last-op instead.
-
-2009-11-23 Deniz Dogan <deniz.a.m.dogan@gmail.com> (tiny change)
-
- Make M-r mirror the new cycling behavior of C-l.
- * window.el (move-to-window-line-last-op): New var.
- (move-to-window-line-top-bottom): New command.
- (global-map): Bind M-r move-to-window-line-top-bottom.
-
-2009-11-23 Sven Joachim <svenjoac@gmx.de>
-
- * dired-x.el (dired-guess-shell-alist-default):
- Support xz format. (Bug#4953)
-
-2009-11-22 Michael Kifer <kifer@cs.stonybrook.edu>
-
- * emulation/viper-cmd.el: Use viper-last-command-char instead of
- last-command-char/last-command-event.
- (viper-prefix-arg-value): Do correct conversion of event-char for
- XEmacs.
-
- * emulation/viper-util.el, emulation/viper.el:
- Use viper-last-command-char instead of
- last-command-char/last-command-event.
-
- * ediff-init.el, ediff-mult.el, ediff-util.el:
- Replace last-command-char and last-command-event
- with (ediff-last-command-char) everywhere.
-
- * ediff-vers.el (ediff-rcs-get-output-buffer): Make sure the buffer is
- created in fundamental mode.
-
- * ediff.el (ediff-version): Revert the change of interactive-p to
- called-interactively-p.
-
-2009-11-22 Tassilo Horn <tassilo@member.fsf.org>
-
- * progmodes/subword.el (subword-mode-map): Fix subword-mode-map
- generation from word-movement command names.
-
-2009-11-21 Jan Djärv <jan.h.d@swipnet.se>
-
- * cus-start.el (all): Add native condition for font-use-system-font.
-
-2009-11-21 Nathaniel Flath <flat0103@gmail.com>
-
- * progmodes/cc-menus.el (cc-imenu-java-generic-expression):
- Correct the patch from 2009-11-18. (Bug#3910)
-
-2009-11-21 Tassilo Horn <tassilo@member.fsf.org>
-
- * progmodes/subword.el: Rename from lisp/subword.el.
-
- * subword.el: Rename to progmodes/subword.el.
-
- * Makefile.in (ELCFILES): Adapt to subword.el move.
-
-2009-11-21 Thierry Volpiatto <thierry.volpiatto@gmail.com>
- 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.
- (bookmark-bmenu-show-filenames): Use push.
- (bookmark-bmenu-hide-filenames): Use local var instead of
- bookmark-bmenu-bookmark-column. Use pop. Don't save window-excursion.
- (bookmark-bmenu-bookmark): Use the new `bookmark-name-prop' text-prop.
- (bookmark-bmenu-execute-deletions): Don't bother adding/removing the
- filenames now that the bookmark names are always available.
-
-2009-11-21 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * bookmark.el (bookmark-search-prompt, bookmark-search-timer): Remove.
- (bookmark-search-pattern): Move and leave unbound.
- (bookmark-bmenu-mode-map): Change binding.
- (bookmark-read-search-input): Simplify.
- Don't use text-char-description. Don't error on non-char events.
- (bookmark-filtered-alist-by-regexp-only): Remove by folding into the
- only caller (i.e. bookmark-bmenu-filter-alist-by-regexp).
- (bookmark-bmenu-search): Don't check we're in a bookmark-list buffer.
- Use a local var for the timer.
- (bookmark-bmenu-cancel-search): Remove by folding into the only caller
- (i.e. bookmark-bmenu-search).
-
-2009-11-21 Glenn Morris <rgm@gnu.org>
-
- * mail/rmailmm.el (rmail-mime): Decode in fundamental-mode. (Bug#4993)
-
-2009-11-20 Ken Brown <kbrown@cornell.edu> (tiny change)
-
- * net/browse-url.el (browse-url-default-windows-browser):
- Use cygstart for cygwin.
+ * calendar/appt.el (appt-time-msg-list): Doc fix.
-2009-11-20 Karl Fogel <karl.fogel@red-bean.com>
+2011-05-06 Noah Friedman <friedman@splode.com>
- * bookmark.el: Formatting and doc fixes only:
- (bookmark-search-delay): Shorten doc string to fit in 80 columns.
- (bookmark-bmenu-search): Wrap to fit within 80 columns.
- Minor grammar and punctuation fixes in doc string.
- (bookmark-read-search-input): Adjust to fit within 80 columns.
+ * apropos.el (apropos-print-doc): Only use
+ emacs-lisp-docstring-fill-column when it is bound to an integer,
+ per that variable's documentation.
-2009-11-20 Tassilo Horn <tassilo@member.fsf.org>
+2011-05-06 Stefan Monnier <monnier@iro.umontreal.ca>
- * progmodes/cc-cmds.el (c-forward-into-nomenclature)
- (c-backward-into-nomenclature): Adapt to subword renaming.
+ * lpr.el (print-region-1): Echo lpr-program's output, so error messages
+ and warnings are not silently discarded (e.g. use -d instead of -P).
- * subword.el (subword-forward, subword-backward, subword-mark)
- (subword-kill, subword-backward-kill, subword-transpose)
- (subword-downcase, subword-upcase, subword-capitalize)
- (subword-forward-internal, subword-backward-internal):
- Rename from forward-subword, backward-subword, mark-subword,
- kill-subword, backward-kill-subword, transpose-subwords,
- downcase-subword, upcase-subword, capitalize-subword,
- forward-subword-internal, backward-subword-internal.
+2011-05-06 Glenn Morris <rgm@gnu.org>
-2009-11-20 Thierry Volpiatto <thierry.volpiatto@gmail.com>
+ * calendar/appt.el (appt-message-warning-time): Doc fix.
+ (appt-warning-time-regexp): New option.
+ (appt-make-list): Respect appt-message-warning-time.
- * bookmark.el (bookmark-search-delay, bookmark-search-prompt):
+ * calendar/diary-lib.el (diary-comment-start, diary-comment-end):
New options.
- (bookmark-search-pattern, bookmark-search-timer, bookmark-quit-flag):
- New vars.
- (bookmark-read-search-input, bookmark-filtered-alist-by-regexp-only)
- (bookmark-bmenu-filter-alist-by-regexp)
- (bookmark-bmenu-goto-bookmark, bookmark-bmenu-cancel-search): New funs.
- (bookmark-bmenu-search): New command.
- (bookmark-bmenu-mode-map): Bind it.
-
-2009-11-20 Tassilo Horn <tassilo@member.fsf.org>
-
- * progmodes/cc-cmds.el: declare-functioned forward-subword and
- backward-subword to quit the byte-compiler.
-
- * makefile.w32-in: Don't refer cc-subword.elc but subword.elc.
-
- * Makefile.in: Don't refer cc-subword.elc but subword.elc.
-
- * progmodes/cc-cmds.el (c-update-modeline)
- (c-forward-into-nomenclature, c-backward-into-nomenclature):
- Refer to subword.el functions instead of cc-subword.el.
-
- * progmodes/cc-mode.el (subword-mode, c-mode-base-map): Refer to
- subword.el functions instead of cc-subword.el.
-
- * progmodes/cc-subword.el: Rename to subword.el.
- * subword.el: Rename from progmodes/cc-subword.el.
- (subword-mode-map): Rename from c-subword-mode-map.
- (subword-mode): Rename from c-subword-mode.
- (global-subword-mode): New global minor mode.
- (forward-subword): Rename from c-forward-subword.
- (backward-subword): Rename from c-backward-subword.
- (mark-subword): Rename from c-mark-subword.
- (kill-subword): Rename from c-kill-subword.
- (backward-kill-subword): Rename from c-backward-kill-subword.
- (transpose-subwords): Rename from c-tranpose-subword.
- (downcase-subword): Rename from c-downcase-subword.
- (capitalize-subword): Rename from c-capitalize-subword.
- (forward-subword-internal): Rename from c-forward-subword-internal.
- (backward-subword-internal): Rename from c-backward-subword-internal.
-
-2009-11-20 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc.el (vc-deduce-fileset): Allow non-state changing operations
- from a dired buffer.
- (vc-dired-deduce-fileset): New function.
- (vc-root-diff, vc-print-root-log): Use it.
-
- * vc-annotate.el (vc-annotate-show-log-revision-at-line): Pass a
- nil LIMIT argument to vc-print-log-internal.
-
-2009-11-20 Glenn Morris <rgm@gnu.org>
-
- * Makefile.in (ELCFILES): Regenerate.
+ (diary-add-to-list): Strip comments from the displayed string.
+ (diary-mode): Set comment-start and comment-end.
-2009-11-20 Jay Belanger <jay.p.belanger@gmail.com>
+ * vc/diff-mode.el (smerge-refine-subst): Declare.
+ (diff-refine-hunk): Don't require smerge-mode when compiling.
- * calc/calc.el (calc-set-mode-line):
- Rename `calc-complement-signed-mode' to `calc-twos-complement-mode'.
- (math-format-number): Rename `math-format-complement-signed' to
- `math-format-twos-complement'.
+2011-05-06 Juanma Barranquero <lekktu@gmail.com>
- * calc/calc-bin.el (math-format-twos-complement): Rename from
- math-format-complement-signed.
- (calc-radix): Rename `calc-complement-signed-mode' to
- `calc-twos-complement-mode'.
- (calc-octal-radix, calc-hex-radix): Add an argument for
- two's complement.
+ * simple.el (list-processes): Return nil as the docstring says.
- * calc/calc-embed.el (calc-embedded-mode-vars):
- Rename `calc-complement-signed-mode' to `calc-twos-complement-mode'.
+2011-05-05 Michael Albinus <michael.albinus@gmx.de>
- * calc/calc-ext.el (calc-init-extensions):
- Rename `calc-complement-signed-mode' to `calc-twos-complement-mode'.
- (math-format-number-fancy): Let `calc-twos-complement-mode' be nil.
+ * net/ange-ftp.el (ange-ftp-binary-file-name-regexp): Set default
+ to "".
+ (ange-ftp-write-region, ange-ftp-insert-file-contents)
+ (ange-ftp-copy-file-internal): Use only `ange-ftp-binary-file' for
+ determining of binary transfer. (Bug#7383)
- * calc/calc-units.el (math-build-units-table-buffer):
- Let `calc-twos-complement-mode' be nil.
+2011-05-05 Michael Albinus <michael.albinus@gmx.de>
- * calc/calc-menu.el (calc-modes-menu): Clean up two's complement
- entries.
+ * net/tramp-sh.el (tramp-do-copy-or-rename-file-out-of-band):
+ Fix port computation bug. (Bug#8618)
- * calc/calc-vec.el (calcFunc-vunpack):
- * calc/calc-aent.el (calc-do-calc-eval):
- * calc/calc-forms.el (math-format-date):
- * calc/calc-graph.el (calc-graph-plot):
- * calc/calc-math.el (math-use-emacs-fn):
- * calc/calccomp.el (math-compose-expr):
- Let `calc-twos-complement-mode' be nil.
+2011-05-05 Glenn Morris <rgm@gnu.org>
-2009-11-19 Stefan Monnier <monnier@iro.umontreal.ca>
+ * allout-widgets.el (allout-widgets-mode-inhibit): Declare before use.
- * abbrev.el (abbrev-with-wrapper-hook): (re)move...
- * simple.el (with-wrapper-hook): ...to here. Add argument `args'.
- * minibuffer.el (completion-in-region-functions): New hook.
- (completion-in-region): New function.
- * emacs-lisp/lisp.el (lisp-complete-symbol):
- * pcomplete.el (pcomplete-std-complete): Use it.
+ * simple.el (shell-dynamic-complete-functions)
+ (comint-dynamic-complete-functions): Declare.
-2009-11-19 Stefan Monnier <monnier@iro.umontreal.ca>
+ * net/network-stream.el (gnutls-negotiate):
+ * simple.el (tabulated-list-print): Fix declarations.
- * textmodes/tex-mode.el (latex-complete-bibtex-cache)
- (latex-complete-alist): New vars.
- (latex-string-prefix-p, latex-complete-bibtex-keys)
- (latex-complete-envnames, latex-complete-refkeys)
- (latex-complete-data): New functions.
- (latex-complete, latex-indent-or-complete): New commands.
+ * progmodes/gud.el (syntax-symbol, syntax-point):
+ Remove unnecessary and incorrect declarations.
- * window.el (display-buffer-mark-dedicated): New var.
- (display-buffer): Obey it.
- * minibuffer.el (minibuffer-completion-help): Use it.
+ * emacs-lisp/check-declare.el (check-declare-scan):
+ Handle byte-compile-initial-macro-environment in bytecomp.el
- * progmodes/sym-comp.el (symbol-complete): Use completion-in-region.
+2011-05-05 Stefan Monnier <monnier@iro.umontreal.ca>
- * filecache.el (file-cache-add-file): Use push and cons.
- (file-cache-delete-file-regexp): Use push.
- (file-cache-complete): Use completion-in-region.
+ Fix earlier half-done eieio-defmethod change (bug#8338).
+ * emacs-lisp/eieio.el (eieio--defmethod): Rename from eieio-defmethod.
+ Streamline and change calling convention.
+ (defmethod): Adjust accordingly and simplify.
+ (eieio-defclass): Fix broken calls to eieio-defmethod and redirect to
+ new eieio--defmethod.
+ (slot-boundp): Minor CSE simplification.
- * simple.el (with-wrapper-hook): Fix thinko.
+2011-05-05 Milan Zamazal <pdm@zamazal.org>
- * hfy-cmap.el (hfy-rgb-file): Use locate-file.
- (htmlfontify-load-rgb-file): Remove unnused var `ff'.
- Use with-current-buffer and string-to-number.
- (hfy-fallback-colour-values): Use assoc-string.
- * htmlfontify.el (hfy-face-to-css): Remove unused var `style'.
- (hfy-face-at): Remove unused var `found-face'.
- (hfy-compile-stylesheet): Remove unused var `css'.
- (hfy-fontify-buffer): Remove unused vars `in-style', `invis-button',
- and `orig-buffer'.
- (hfy-buffer, hfy-copy-and-fontify-file, hfy-parse-tags-buffer):
- Use with-current-buffer.
- (hfy-text-p): Use expand-file-name and fewer setq.
+ * progmodes/glasses.el (glasses-separate-capital-groups): New option.
+ (glasses-make-readable): Use glasses-separate-capital-groups.
-2009-11-19 Vivek Dasmohapatra <vivek@etla.org>
+2011-05-05 Juanma Barranquero <lekktu@gmail.com>
- * htmlfontify.el, hfy-cmap.el: New files.
+ * emacs-lisp/warnings.el (warning-level-aliases): Reflow docstring.
+ (warning-series): Doc fix.
+ (display-warning): Don't try to create the buffer if we just found it.
-2009-11-19 Juri Linkov <juri@jurta.org>
+2011-05-04 Chong Yidong <cyd@stupidchicken.com>
- * minibuffer.el (completions-format): New defcustom.
- (completion--insert-strings): Implement vertical format.
+ * emacs-lisp/autoload.el (generated-autoload-file): Set to nil.
+ (autoload-find-generated-file): New function.
+ (generate-file-autoloads): Bind generated-autoload-file to
+ buffer-file-name.
+ (update-file-autoloads, update-directory-autoloads):
+ Use autoload-find-generated-file. If called interactively, prompt for
+ output file (Bug#7989).
+ (batch-update-autoloads): Doc fix.
- * simple.el (switch-to-completions): Move point to the first
- completion when point was at the beginning of the buffer.
+2011-05-04 Juanma Barranquero <lekktu@gmail.com>
-2009-11-19 Juri Linkov <juri@jurta.org>
+ * term/w32-win.el (dynamic-library-alist): Add `gnutls'.
- * find-dired.el (find-name-arg): Remove autoload. (Bug#4387)
+2011-05-04 Glenn Morris <rgm@gnu.org>
- * progmodes/grep.el (rgrep): Require `find-dired' for `find-name-arg'.
+ * calendar/diary-lib.el (diary-fancy-date-pattern): Turn it into a
+ function, so it follows changes in calendar-date-style.
+ (diary-fancy-date-matcher): New function.
+ (diary-fancy-font-lock-keywords): Use diary-fancy-date-matcher.
+ (diary-fancy-font-lock-fontify-region-function):
+ Use diary-fancy-date-pattern as a function.
-2009-11-19 Chong Yidong <cyd@stupidchicken.com>
+ * calendar/diary-lib.el (diary-fancy-date-pattern): Do not use
+ non-numbers for `year' etc pseudo-variables. (Bug#8583)
- * mail/sendmail.el (mail-yank-prefix): Change default to "> ".
- (mail-signature): Change default to t.
- (mail-from-style): Deprecate `system-default' value.
- (mail-insert-from-field): For default value of mail-from-style,
- default to `angles' unless `angles' needs quoting and `parens'
- does not.
- (mail-citation-prefix-regexp): Use citation regexp from
- message-mode.
+2011-05-04 Teodor Zlatanov <tzz@lifelogs.com>
-2009-11-19 Michael Albinus <michael.albinus@gmx.de>
+ * net/gnutls.el (gnutls-negotiate): Use CL-style keyword arguments
+ instead of positional arguments. Allow :keylist and :crlfiles
+ arguments.
+ (open-gnutls-stream): Call it.
- * net/tramp.el (tramp-do-copy-or-rename-file-out-of-band):
- Set variables for computing the prompt for reading password.
+ * net/network-stream.el (network-stream-open-starttls): Adjust to
+ call `gnutls-negotiate' with :process and :hostname arguments.
-2009-11-19 Glenn Morris <rgm@gnu.org>
+2011-05-04 Stefan Monnier <monnier@iro.umontreal.ca>
- * dired-aux.el (dired-compress-file-suffixes): Add ".xz". (Bug#4953)
+ * minibuffer.el (completion--message): New function.
+ (completion--do-completion, minibuffer-complete)
+ (minibuffer-force-complete, minibuffer-complete-word): Use it.
+ (completion--do-completion): Don't ignore completion-auto-help when in
+ icomplete-mode.
- * textmodes/flyspell.el (sgml-lexical-context): Declare.
+ * whitespace.el (whitespace-trailing-regexp): Don't rely on the
+ internal encoding (e.g. tibetan zero is not whitespace).
+ (global-whitespace-mode): Prefer save-current-buffer.
+ (whitespace-trailing-regexp): Remove useless save-match-data.
+ (whitespace-empty-at-bob-regexp): Minor simplification.
- * net/newst-treeview.el (newsticker-treeview-treewindow-width)
- (newsticker-treeview-listwindow-height): Fix custom type.
+2011-05-03 Chong Yidong <cyd@stupidchicken.com>
-2009-11-19 Kenichi Handa <handa@m17n.org>
+ * emacs-lisp/autoload.el (generated-autoload-file): Doc fix (Bug#7989).
- * descr-text.el (describe-char-padded-string): Compose with TAB
- only if there's a font for CH.
- (describe-char): Fix the condition for detecting a trivial composition.
+2011-05-03 Agustín Martín Domingo <agustin.martin@hispalinux.es>
-2009-11-18 Nathaniel Flath <flat0103@gmail.com>
+ * textmodes/ispell.el (ispell-add-per-file-word-list):
+ Use `concat' to create string for insertion.
- * progmodes/cc-menus.el (cc-imenu-java-generic-expression): A new,
- more accurate version of the regexp. (Bug#3910)
+2011-05-03 Stefan Monnier <monnier@iro.umontreal.ca>
-2009-11-18 Bernhard Herzog <bernhard.herzog@intevation.de> (tiny change)
+ * textmodes/bibtex.el (bibtex-fill-field-bounds, bibtex-fill-entry):
+ Avoid open-line which runs post-self-insert-hook.
+ (bibtex-fill-entry): Remove unused `end' var.
- * vc-hg.el (vc-hg-diff): Fix last patch: do not change directory.
+2011-05-03 Dirk Ullrich <dirk.ullrich@googlemail.com> (tiny change)
-2009-11-18 Juanma Barranquero <lekktu@gmail.com>
+ * textmodes/ispell.el (ispell-add-per-file-word-list):
+ Protect against `nil' value of `comment-start' (Bug#8579).
- * font-setting.el (font-use-system-font): Declare for byte-compiler.
- (font-setting-change-default-font): Fix typo in docstring.
+2011-05-03 Leo Liu <sdl.web@gmail.com>
-2009-11-18 Alan Mackenzie <acm@muc.de>
+ * isearch.el (isearch-yank-pop): New command.
+ (isearch-mode-map): Bind it to `M-y'.
+ (isearch-forward): Mention it.
- * progmodes/cc-defs.el (c-version): Bump to 5.31.8.
+2011-05-03 Stefan Monnier <monnier@iro.umontreal.ca>
-2009-11-17 Jan Djärv <jan.h.d@swipnet.se>
+ * simple.el (minibuffer-complete-shell-command): Remove.
+ (minibuffer-local-shell-command-map): Use completion-at-point.
+ (read-shell-command): Setup completion vars here instead.
+ (read-expression-map): Bind TAB to symbol completion.
- * font-setting.el (font-use-system-font): Move ...
+ * textmodes/ispell.el (lookup-words): Use with-temp-buffer; signal
+ error directly rather via storing it into `results'.
- * cus-start.el (all): ... to here.
+2011-05-02 Leo Liu <sdl.web@gmail.com>
-2009-11-17 Michael Albinus <michael.albinus@gmx.de>
+ * vc/diff.el: Fix description.
- * net/tramp.el (tramp-advice-file-expand-wildcards): Simplify.
- Don't set `ad-return-value' if `ad-do-it' doesn't.
+2011-05-02 Lars Magne Ingebrigtsen <larsi@gnus.org>
- * net/tramp-gvfs.el (tramp-gvfs-handle-write-region): Set file
- modification time.
+ * server.el (server-eval-at): New function.
-2009-11-17 Jan Djärv <jan.h.d@swipnet.se>
+2011-05-01 Lars Magne Ingebrigtsen <larsi@gnus.org>
- * menu-bar.el: Put "Use system font" in Option-menu.
- (menu-bar-options-save): Add font-use-system-font.
+ * net/network-stream.el (open-network-stream): Take a :nowait
+ parameter and pass it on to `make-network-process'.
+ (network-stream-open-plain): Ditto.
- * loadup.el: If feature system-font-setting or font-render-setting is
- there, load font-setting.
+2011-04-30 Andreas Schwab <schwab@linux-m68k.org>
- * Makefile.in (ELCFILES): Add font-settings.el.
- * font-setting.el: New file.
+ * faces.el (face-spec-set-match-display): Don't match toolkit
+ options on terminal frames.
-2009-11-17 Glenn Morris <rgm@gnu.org>
+2011-04-29 Stefan Monnier <monnier@iro.umontreal.ca>
- * vc-svn.el (vc-svn-print-log): Fix typo in previous.
+ * progmodes/pascal.el: Use lexical binding.
+ (pascal-mode-map): Remove author preferences.
- * net/newst-treeview.el (newsticker--treeview-list-update-faces):
- Preserve point in the list buffer. (Bug#4939)
- Use point-at-eol.
- (newsticker--treeview-list-update-highlight)
- (newsticker--treeview-tree-update-highlight): Use point-at-bol/eol.
+ * pcomplete.el (pcomplete-std-complete): Don't abuse
+ completion-at-point.
-2009-11-16 Jay Belanger <jay.p.belanger@gmail.com>
+2011-04-28 Juanma Barranquero <lekktu@gmail.com>
- * calc/calc-bin.el (math-symclip, calcFunc-symclip, calc-symclip):
- Remove.
+ * calc/calccomp.el (math-comp-to-string-flat-term): Simplify by
+ removing code that has been dead since 1991 or so.
- * calc/calc-ext.el (calc-init-extensions): Remove references to
- symclip.
+ * startup.el (command-line): When warning about "_emacs", use a
+ delayed warning to allow the user to filter it out.
- * calc/calc-menu.el (calc-arithmetic-menu): Remove `calc-symclip'.
+2011-04-28 Deniz Dogan <deniz@dogan.se>
- * calc/calc-map.el (calc-get-operator, calc-b-oper-keys):
- * calc/calc-help.el (calc-b-prefix-help): Remove references to
- `calc-symclip'.
+ * net/rcirc.el (rcirc-handler-353): Fix bug for channels which the
+ user has not joined.
-2009-11-16 Kevin Ryde <user42@zip.com.au>
+2011-04-28 Stefan Monnier <monnier@iro.umontreal.ca>
- * textmodes/flyspell.el (sgml-mode-flyspell-verify):
- Use `sgml-lexical-context' instead of own parse for tag (Bug#4511).
+ * pcomplete.el (pcomplete-completions-at-point): Return nil if there
+ aren't any completions at point.
- * emacs-lisp/lisp-mnt.el (lm-keywords): Allow multi-line keywords.
- (lm-keywords-list): Allow comma-only separator like "foo,bar".
- Ignore trailing spaces by omit-nulls to split-string (fixing
- regression from Emacs 21 due to the incompatible split-string
- change). (Bug #4928.)
+2011-04-28 Juanma Barranquero <lekktu@gmail.com>
-2009-11-16 Dan Nicolaescu <dann@ics.uci.edu>
+ * subr.el (display-delayed-warnings): New function.
+ (delayed-warnings-hook): New variable.
- * vc.el (vc-log-show-limit): Default to 2000.
- (vc-print-log-internal): Insert buttons to request more entries
- when limiting the output.
+2011-04-28 Stefan Monnier <monnier@iro.umontreal.ca>
- * vc-sccs.el (vc-sccs-print-log):
- * vc-rcs.el (vc-rcs-print-log):
- * vc-cvs.el (vc-cvs-print-log):
- * vc-git.el (vc-git-print-log): Return 'limit-unsupported when
- LIMIT is non-nil.
+ * minibuffer.el (completion-at-point, completion-help-at-point):
+ Don't presume that a given completion-at-point-function will always
+ use the same calling convention.
-2009-11-16 Michael Albinus <michael.albinus@gmx.de>
+ * pcomplete.el (pcomplete-completions-at-point):
+ Obey pcomplete-ignore-case. Don't call pcomplete-norm-func unless
+ pcomplete-seen is non-nil.
+ (pcomplete-comint-setup): Also recognize the new comint/shell
+ completion functions.
+ (pcomplete-do-complete): Don't call pcomplete-norm-func unless
+ pcomplete-seen is non-nil.
- * net/tramp-gvfs.el (tramp-gvfs-dbus-event-error): Raise only an
- error when `tramp-gvfs-dbus-event-vector' is set.
- (tramp-gvfs-maybe-open-connection): Loop over `read-event'.
+2011-04-27 Niels Giesen <niels.giesen@gmail.com>
-2009-11-16 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * vc-rcs.el (vc-rcs-consult-headers): Add missing save-excursion.
-
-2009-11-16 Michael Albinus <michael.albinus@gmx.de>
-
- * net/dbus.el (dbus-unregister-service): New defun.
- (dbus-register-property): Register the handlers of
- "org.freedesktop.DBus.Properties" for SERVICE.
- (dbus-property-handler): Fix docstring.
-
-2009-11-16 YAMAMOTO Mitsuharu <mituharu@math.s.chiba-u.ac.jp>
-
- * emacs-lisp/bytecomp.el (byte-compile-output-file-form):
- Quote doc string reference in defvaralias as it is not in special form.
- (byte-compile-output-docform): Doc fix.
-
-2009-11-16 Jay Belanger <jay.p.belanger@gmail.com>
-
- * calc/calc.el (math-2-word-size, math-half-2-word-size)
- (calc-complement-signed-mode): New variables.
- (calc-set-mode-line): Add indicator for twos-complements.
- (math-format-number): Format twos-complement notation.
-
- * calc/calc-bin.el (calc-word-size): Reset the variables
- `math-2-word-size' and `math-half-2-word-size'.
- (math-format-complement-signed, math-symclip, calcFunc-symclip)
- (calc-symclip): New functions.
-
- * calc/calc-aent.el (math-read-token): Read complement signed numbers.
-
- * calc/calc-embed.el (calc-embedded-mode-vars):
- Add `calc-complement-signed-mode' to the list of modes.
-
- * calc/calc-map.el (calc-get-operator): Add `calc-symclip'.
- (calc-b-oper-keys): Add `calc-symclip' to list.
-
- * calc/calc-ext.el (math-read-number-fancy): Read complement
- signed numbers.
- (calc-init-extensions): Add binding for `calc-symclip'.
- Add autoload for `calcFunc-symclip' and `calc-symclip'.
-
- * calc/calc-menu.el (calc-arithmetic-menu): Add item for
- `calc-symclip'.
- (calc-modes-menu): Add item for twos complement mode.
-
- * calc/calc-help.el (calc-b-prefix-help): Add help for `calc-symclip'.
-
-2009-11-15 Chong Yidong <cyd@stupidchicken.com>
-
- * register.el (jump-to-register, insert-register): Handle Semantic
- tags. From commented-out advice in semantic/senator.el.
-
-2009-11-15 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc.el (vc-log-show-limit): New variable.
- (vc-print-log, vc-print-root-log): Add new argument LIMIT. Set it
- when using a prefix argument.
- (vc-print-log-internal): Add new argument LIMIT.
-
- * vc-svn.el (vc-svn-print-log):
- * vc-mtn.el (vc-mtn-print-log):
- * vc-hg.el (vc-hg-print-log):
- * vc-bzr.el (vc-bzr-print-log): Add new optional argument LIMIT,
- pass it to the log command when set. Make the BUFFER argument
- non-optional.
-
- * vc-sccs.el (vc-sccs-print-log):
- * vc-rcs.el (vc-rcs-print-log):
- * vc-git.el (vc-git-print-log):
- * vc-cvs.el (vc-cvs-print-log): Add new optional argument LIMIT,
- ignore it. Make the BUFFER argument non-optional
-
- * bindings.el (mode-line-buffer-identification): Do not purecopy.
-
-2009-11-15 Chong Yidong <cyd@stupidchicken.com>
-
- * dired.el (dired-mode-map): Move encryption items to "Operate"
- menu (Bug#4703).
+ * calendar/icalendar.el (diary-lib): Add require statement.
+ (icalendar--create-uid): Read out a uid from a text-property on
+ the first character in the entry. This allows for code to add its
+ own uid to the entry.
+ (icalendar--convert-float-to-ical): Add export of
+ `diary-float'-entries save for those with the optional DAY
+ argument.
- * strokes.el (strokes-update-window-configuration): Make strokes
- buffer current before erasing (Bug#4906).
+2011-04-27 Daniel Colascione <dan.colascione@gmail.com>
-2009-11-15 Juri Linkov <juri@jurta.org>
+ * subr.el (shell-quote-argument): Use alternate escaping strategy
+ when we spot a variable reference in a string.
- * simple.el (set-mark-default-inactive): Add :type, :group
- and :version. (Bug#4876)
+2011-04-26 Daniel Colascione <dan.colascione@gmail.com>
-2009-11-15 Michael Albinus <michael.albinus@gmx.de>
+ * cus-start.el (all): Define customization for debug-on-event.
- * arc-mode.el (archive-maybe-copy): Move creation of directory ...
- (archive-unique-fname): ... here. (Bug#4929)
+2011-04-26 Daniel Colascione <dan.colascione@gmail.com>
-2009-11-15 Stefan Monnier <monnier@iro.umontreal.ca>
+ * subr.el (shell-quote-argument): Escape correctly under Windows.
- * help-mode.el (help-make-xrefs): Undo the last revert, and replace it
- with a real fix.
+2011-04-25 Stefan Monnier <monnier@iro.umontreal.ca>
- * novice.el (disabled-command-function): Add useful args.
- Setup the help buffer so that [back] works.
- Remove redundant call to help-mode.
- (disabled-command-function): Use `case'.
- (en/disable-command): New function extracted from enable-command.
- (enable-command, disable-command): Use it.
+ * emulation/cua-base.el (cua-selection-mode): Make it toggle again.
-2009-11-14 Glenn Morris <rgm@gnu.org>
-
- * menu-bar.el (menu-bar-tools-menu): Read and send mail entries are not
- constants. (Bug#4913)
-
- * emacs-lisp/elint.el (elint-standard-variables): Doc fix.
-
-2009-11-14 Shigeru Fukaya <shigeru.fukaya@gmail.com>
-
- * emacs-lisp/elint.el (elint-standard-variables): Add some variables
- defined in C that have no doc-strings. (Bug#1063)
-
-2009-11-14 Francis Wright <F.J.Wright@qmul.ac.uk>
-
- * cus-edit.el (data, files):
- * ps-print.el (postscript): Doc fixes for custom groups. (Bug#3327)
-
-2009-11-14 Chong Yidong <cyd@stupidchicken.com>
-
- * simple.el (shell-command): Doc fix (Bug#4891).
-
- * help-mode.el (help-make-xrefs): Revert 2009-11-13 change.
-
-2009-11-14 Glenn Morris <rgm@gnu.org>
-
- * emulation/viper.el (viper-set-hooks): Remove duplicate advice
- statements for vc-diff, emerge-quit, and rmail-cease-edit.
- If they are already loaded, eval-after-load will do the right thing.
-
- * speedbar.el (top-level): Remove unnecessary load of ange-ftp when
- compiling.
-
- * emacs-lisp/bytecomp.el (byte-compile-single-version): Remove, unused.
-
- * simple.el (x-selection-owner-p): Declare.
- (read-mail-command): Use custom radio type rather than choice.
- (completion-no-auto-exit): Doc fix.
-
- * custom.el (defgroup):
- * epg-config.el (epg): Doc fixes.
-
-2009-11-14 Dan Nicolaescu <dann@ics.uci.edu>
-
- * bindings.el (mode-line-buffer-identification): Purecopy only the string.
- * international/ccl.el (define-ccl-program): Do not purecopy the
- docstring, defconst does it anyway.
-
-2009-11-13 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * add-log.el (add-change-log-entry): Avoid displaying the changelog
- a second time.
-
- * x-dnd.el (x-dnd-maybe-call-test-function):
- * window.el (split-window-vertically):
- * whitespace.el (whitespace-help-on):
- * vc-rcs.el (vc-rcs-consult-headers):
- * userlock.el (ask-user-about-lock-help)
- (ask-user-about-supersession-help):
- * type-break.el (type-break-force-mode-line-update):
- * time-stamp.el (time-stamp-conv-warn):
- * terminal.el (te-set-output-log, te-more-break, te-filter)
- (te-sentinel, terminal-emulator):
- * term.el (make-term, term-exec, term-sentinel, term-read-input-ring)
- (term-write-input-ring, term-check-source, term-start-output-log):
- (term-display-buffer-line, term-dynamic-list-completions):
- (term-ansi-make-term, serial-term):
- * subr.el (selective-display):
- * strokes.el (strokes-xpm-to-compressed-string, strokes-decode-buffer)
- (strokes-encode-buffer, strokes-xpm-for-compressed-string):
- * speedbar.el (speedbar-buffers-tail-notes, speedbar-buffers-item-info)
- (speedbar-reconfigure-keymaps, speedbar-add-localized-speedbar-support)
- (speedbar-remove-localized-speedbar-support)
- (speedbar-set-mode-line-format, speedbar-create-tag-hierarchy)
- (speedbar-update-special-contents, speedbar-buffer-buttons-engine)
- (speedbar-buffers-line-directory):
- * simple.el (shell-command-on-region, append-to-buffer)
- (prepend-to-buffer):
- * shadowfile.el (shadow-save-todo-file):
- * scroll-bar.el (scroll-bar-set-window-start, scroll-bar-drag-1)
- (scroll-bar-maybe-set-window-start):
- * sb-image.el (speedbar-image-dump):
- * saveplace.el (save-place-alist-to-file, save-places-to-alist)
- (load-save-place-alist-from-file):
- * ps-samp.el (ps-print-message-from-summary):
- * ps-print.el (ps-flush-output, ps-insert-file, ps-get-boundingbox)
- (ps-background-image, ps-begin-job, ps-do-despool):
- * ps-bdf.el (bdf-find-file, bdf-read-font-info):
- * printing.el (pr-interface, pr-ps-file-print, pr-find-buffer-visiting)
- (pr-ps-message-from-summary, pr-lpr-message-from-summary):
- (pr-call-process, pr-file-list, pr-interface-save):
- * novice.el (disabled-command-function)
- (enable-command, disable-command):
- * mouse.el (mouse-buffer-menu-alist):
- * mouse-copy.el (mouse-kill-preserving-secondary):
- * macros.el (kbd-macro-query):
- * ledit.el (ledit-go-to-lisp, ledit-go-to-liszt):
- * informat.el (batch-info-validate):
- * ido.el (ido-copy-current-word, ido-initiate-auto-merge):
- * hippie-exp.el (try-expand-dabbrev-visible):
- * help-mode.el (help-make-xrefs):
- * help-fns.el (describe-variable):
- * generic-x.el (bat-generic-mode-run-as-comint):
- * finder.el (finder-mouse-select):
- * find-dired.el (find-dired-sentinel):
- * filesets.el (filesets-file-close):
- * files.el (list-directory):
- * faces.el (list-faces-display, describe-face):
- * facemenu.el (list-colors-display):
- * ezimage.el (ezimage-image-association-dump, ezimage-image-dump):
- * epg.el (epg--process-filter, epg-cancel):
- * epa.el (epa--marked-keys, epa--select-keys, epa-display-info)
- (epa--read-signature-type):
- * emerge.el (emerge-copy-as-kill-A, emerge-copy-as-kill-B)
- (emerge-file-names):
- * ehelp.el (electric-helpify):
- * ediff.el (ediff-regions-wordwise, ediff-regions-linewise):
- * ediff-vers.el (rcs-ediff-view-revision):
- * ediff-util.el (ediff-setup):
- * ediff-mult.el (ediff-append-custom-diff):
- * ediff-diff.el (ediff-exec-process, ediff-process-sentinel)
- (ediff-wordify):
- * echistory.el (Electric-command-history-redo-expression):
- * dos-w32.el (find-file-not-found-set-buffer-file-coding-system):
- * disp-table.el (describe-display-table):
- * dired.el (dired-find-buffer-nocreate):
- * dired-aux.el (dired-rename-subdir, dired-dwim-target-directory):
- * dabbrev.el (dabbrev--same-major-mode-p):
- * chistory.el (list-command-history):
- * apropos.el (apropos-documentation):
- * allout.el (allout-obtain-passphrase):
- (allout-copy-exposed-to-buffer):
- (allout-verify-passphrase): Use with-current-buffer.
-
-2009-11-13 Glenn Morris <rgm@gnu.org>
-
- * Makefile.in (ELCFILES): Regenerate.
-
-2009-11-13 Michael Albinus <michael.albinus@gmx.de>
-
- * net/dbus.el (dbus-registered-objects-table): Rename from
- `dbus-registered-functions-table', because it contains also properties.
- (dbus-unregister-object): Unregister also properties.
- (dbus-get-property, dbus-set-property, dbus-get-all-properties):
- Use a timeout of 500 msec, in order to not block.
- (dbus-register-property, dbus-property-handler): New defuns.
-
-2009-11-13 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * simple.el (minibuffer-default-add-completions): Drop deprecated
- 4th arg.
-
-2009-11-13 Tomas Abrahamsson <tab@lysator.liu.se>
-
- * textmodes/artist.el (artist-mouse-choose-operation):
- Call `tmm-prompt' instead of `x-popup-menu' if we cannot popup
- menus. Bug noticed by Eli Zaretskii <eliz@gnu.org>.
- (artist-compute-up-event-key): New function.
- (artist-mouse-choose-operation, artist-down-mouse-1): Call it.
-
-2009-11-13 Kenichi Handa <handa@m17n.org>
-
- * language/japan-util.el: Make sure that the value of jisx0208
- property is jisx0208 character.
-
-2009-11-13 Dan Nicolaescu <dann@ics.uci.edu>
-
- * international/mule.el (auto-coding-regexp-alist): Only purecopy
- car or each item, not the whole list.
-
-2009-11-12 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * minibuffer.el (minibuffer-completion-help):
- Use minibuffer-hide-completions.
-
-2009-11-12 Per Starbäck <per@starback.se> (tiny change)
-
- * dired.el (dired-save-positions, dired-restore-positions): New funs.
- (dired-revert): Use them (bug#4880).
-
-2009-11-12 Dan Nicolaescu <dann@ics.uci.edu>
-
- * tooltip.el (tooltip-frame-parameters): Undo previous change.
-
-2009-11-12 Juri Linkov <juri@jurta.org>
-
- * ffap.el (ffap-alternate-file-other-window, ffap-literally):
- New functions.
- (find-file-literally-at-point): Alias of `ffap-literally'.
-
-2009-11-12 Dan Nicolaescu <dann@ics.uci.edu>
-
- * textmodes/ispell.el (ispell-skip-region-alist):
- * textmodes/css-mode.el (auto-mode-alist):
- * progmodes/compile.el (auto-mode-alist):
- * international/mule.el (ctext-non-standard-encodings-alist)
- (ctext-non-standard-encodings-regexp):
- * simple.el (shell-command-switch, text-read-only):
- * replace.el (occur-mode-map):
- * paths.el (rmail-file-name):
- * jka-cmpr-hook.el (jka-compr-build-file-regexp):
- * find-file.el (ff-special-constructs):
- * files.el (file-name-handler-alist):
- * composite.el: Purecopy strings.
-
- * emacs-lisp/cl-macs.el (define-compiler-macro): Purecopy the file name.
-
-2009-11-11 Dan Nicolaescu <dann@ics.uci.edu>
-
- * widget.el (define-widget): Purecopy the docstring.
- * international/mule-cmds.el (charset): Do not purecopy the
- docstring here, define-widget does it.
-
- * textmodes/texinfo.el (texinfo-open-quote, texinfo-close-quote):
- * textmodes/bibtex-style.el (auto-mode-alist):
- * progmodes/inf-lisp.el (inferior-lisp-prompt):
- * progmodes/compile.el (compile-command):
- * language/korea-util.el (default-korean-keyboard):
- * international/mule-conf.el (file-coding-system-alist):
- * emacs-lisp/eldoc.el (eldoc-minor-mode-string):
- * tooltip.el (tooltip-frame-parameters):
- * newcomment.el (comment-end, comment-padding):
- * dired.el (dired-trivial-filenames):
- * comint.el (comint-file-name-prefix): Purecopy initial values.
-
-2009-11-11 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-advice-minibuffer-electric-separator)
- (tramp-advice-minibuffer-electric-tilde): Unload advices via
- `tramp-unload'.
- (tramp-advice-make-auto-save-file-name)
- (tramp-advice-file-expand-wildcards): Apply also `ad-activate'
- after removing the advice.
-
-2009-11-11 Dan Nicolaescu <dann@ics.uci.edu>
-
- * progmodes/grep.el (grep-regexp-alist):
- * international/mule-cmds.el (iso-2022-control-alist):
- * emacs-lisp/timer.el (timer-duration-words):
- * subr.el (version-separator, version-regexp-alist):
- * minibuffer.el (completion-styles-alist):
- * faces.el (face-attribute-name-alist, list-faces-sample-text):
- Change defvars to defconsts.
-
- * Makefile.in (ELCFILES): Add international/mule-conf.elc.
- * loadup.el ("international/mule-conf"): Load the byte compiled version.
- * international/mule-conf.el: Allow to be byte compiled.
-
- * international/mule.el (define-charset): Purecopy props.
- (load-with-code-conversion): Purecopy doc string and file name.
- (put-charset-property): Purecopy strings.
- (auto-coding-alist, auto-coding-regexp-alist): Purecopy initial value.
-
- * international/mule-cmds.el (register-input-method): Purecopy arguments.
- (define-char-code-property): Correctly purecopy the table.
-
- * international/ccl.el (define-ccl-program): Purecopy the docstring.
-
- * emacs-lisp/easy-mmode.el (define-minor-mode): Purecopy :lighter.
-
- * subr.el (add-hook): Purecopy strings.
- (eval-after-load): Purecopy load-history-regexp and the form.
-
- * custom.el (custom-declare-group): Purecopy load-file-name.
-
- * subr.el (menu-bar-separator): New defconst.
- * net/eudc.el (eudc-tools-menu):
- * international/mule-cmds.el (set-coding-system-map)
- (mule-menu-keymap):
- * emacs-lisp/lisp-mode.el (emacs-lisp-mode-map):
- * vc-hooks.el (vc-menu-map):
- * replace.el (occur-mode-map):
- * menu-bar.el (menu-bar-file-menu, menu-bar-search-menu)
- (menu-bar-edit-menu, menu-bar-goto-menu)
- (menu-bar-custom-menu, menu-bar-showhide-menu)
- (menu-bar-options-menu, menu-bar-tools-menu)
- (menu-bar-encryption-decryption-menu, menu-bar-describe-menu)
- (menu-bar-search-documentation-menu, menu-bar-manuals-menu)
- (menu-bar-help-menu):
- * ediff-hook.el (menu-bar-ediff-menu, menu-bar-ediff-merge-menu):
- * buff-menu.el (Buffer-menu-mode-map): Use menu-bar-separator.
-
- * term/x-win.el (x-gtk-stock-map):
- * progmodes/vera-mode.el (auto-mode-alist):
- * progmodes/inf-lisp.el (inferior-lisp-filter-regexp)
- (inferior-lisp-program, inferior-lisp-load-command):
- * progmodes/hideshow.el (hs-special-modes-alist):
- * progmodes/gud.el (same-window-regexps):
- * progmodes/grep.el (grep-program, find-program, xargs-program):
- * net/telnet.el (same-window-regexps):
- * net/rlogin.el (same-window-regexps):
- * language/ethiopic.el (font-ccl-encoder-alist):
- * vc-sccs.el (vc-sccs-master-templates):
- * vc-rcs.el (vc-rcs-master-templates):
- * subr.el (cl-assertion-failed):
- * simple.el (next-error-overlay-arrow-position):
- * lpr.el (lpr-command):
- * locate.el (locate-ls-subdir-switches):
- * info.el (same-window-regexps, info)
- (Info-goto-emacs-command-node, Info-goto-emacs-key-command-node):
- * image-mode.el (image-mode, auto-mode-alist):
- * hippie-exp.el (hippie-expand-ignore-buffers):
- * format.el (format-alist):
- * find-dired.el (find-ls-subdir-switches, find-grep-options)
- (find-name-arg):
- * facemenu.el (facemenu-keybindings):
- * dired.el (dired-listing-switches, dired-chown-program):
- * diff.el (diff-switches, diff-command):
- * cus-edit.el (same-window-regexps):
- * bindings.el (mode-line-mule-info)
- (mode-line-buffer-identification): Purecopy strings.
-
-2009-11-11 Juri Linkov <juri@jurta.org>
-
- * simple.el (dired-get-filename) <declare-function>:
- Tell the byte-compiler about dired-get-filename.
- (shell-command): In Dired mode, get filename from the current line
- as the default value.
-
-2009-11-10 Glenn Morris <rgm@gnu.org>
-
- * dired.el, hi-lock.el, calendar/cal-menu.el, calendar/calendar.el:
- * calendar/holidays.el, progmodes/cperl-mode.el:
- Update x-popup-menu declarations.
-
- * emacs-lisp/shadow.el (find-emacs-lisp-shadows)
- (list-load-path-shadows): Use dolist.
- (list-load-path-shadows): Use with-current-buffer.
-
-2009-11-10 Juri Linkov <juri@jurta.org>
-
- * minibuffer.el (read-file-name): Support a list of default values
- in `default-filename'. Use the first file name where only one
- element is required. Doc fix.
-
-2009-11-09 Michael Albinus <michael.albinus@gmx.de>
-
- * net/dbus.el (dbus-unregister-object): Release service, if no
- other method is registered for it.
-
-2009-11-08 Markus Rost <rost@math.uni-bielefeld.de>
-
- * bookmark.el (bookmark-completing-read): Sort bookmark names if
- bookmark-sort-flag is non-nil (Bug#4653).
-
-2009-11-08 Chong Yidong <cyd@stupidchicken.com>
-
- * emulation/cua-base.el: Add CUA property to some CC mode commands
- (Bug#4100).
-
-2009-11-08 Kevin Ryde <user42@zip.com.au>
-
- * emacs-lisp/checkdoc.el (checkdoc-proper-noun-regexp): Match noun
- at end of sentence (Bug#4818).
-
-2009-11-08 Jared Finder <jfinder@crypticstudios.com>
+2011-04-25 Michael Albinus <michael.albinus@gmx.de>
- * progmodes/compile.el (compilation-error-regexp-alist-alist):
- Handle "see declaration of" MSFT statements (Bug#4100).
+ * net/tramp.el (tramp-process-actions): Add POS argument.
+ Delete region between POS and (pos).
-2009-11-08 Michael Albinus <michael.albinus@gmx.de>
+ * net/tramp-sh.el (tramp-do-copy-or-rename-file-out-of-band):
+ Use `nil' position in `tramp-process-actions' call.
+ (tramp-maybe-open-connection): Call `tramp-process-actions' with pos.
- * net/tramp.el (tramp-advice-make-auto-save-file-name)
- (tramp-advice-file-expand-wildcards): Unload via
- `ad-remove-advice'.
+ * net/tramp-smb.el (tramp-smb-maybe-open-connection): Use `nil'
+ position in `tramp-process-actions' call.
* net/trampver.el: Update release number.
-2009-11-08 Kevin Ryde <user42@zip.com.au>
-
- * net/tramp.el (tramp-advice-file-expand-wildcards): Don't rely on
- `ad-do-it'.
-
-2009-11-08 Andr <m00naticus@gmail.com> (tiny change)
-
- * net/tramp.el (tramp-handle-write-region): Copy but rename temp file,
- in order to keep context in SELinux.
+2011-04-25 Stefan Monnier <monnier@iro.umontreal.ca>
-2009-11-08 Chong Yidong <cyd@stupidchicken.com>
+ * custom.el (defcustom): Obey lexical-binding.
- * dired-aux.el (dired-query): Place cursor in echo area and allow
- C-g.
+ Fix octave-inf completion problems reported by Alexander Klimov.
+ * progmodes/octave-inf.el (inferior-octave-mode-syntax-table):
+ Inherit from octave-mode-syntax-table.
+ (inferior-octave-mode): Set info-lookup-mode.
+ (inferior-octave-completion-at-point): New function.
+ (inferior-octave-complete): Use it and completion-in-region.
+ (inferior-octave-dynamic-complete-functions): Use it as well, and use
+ comint-filename-completion.
+ * progmodes/octave-mod.el (octave-mode-syntax-table): Use _ syntax for
+ symbol elements which shouldn't be word elements.
+ (octave-font-lock-keywords, octave-beginning-of-defun)
+ (octave-function-header-regexp): Adjust regexps accordingly.
+ (octave-mode-map): Also use info-lookup-symbol for C-c C-h.
- * dired.el (dired-mode-map): Disable dired-maybe-insert-subdir
- menu item if not on a directory (Bug#4701).
+2011-04-25 Juanma Barranquero <lekktu@gmail.com>
-2009-11-07 Michael Albinus <michael.albinus@gmx.de>
+ * net/gnutls.el (gnutls-errorp): Declare before first use.
- Sync with Tramp 2.1.17.
+2011-04-24 Teodor Zlatanov <tzz@lifelogs.com>
- * net/tramp.el (tramp-handle-copy-directory): Don't use
- `file-remote-p' (due to compatibility).
+ * net/gnutls.el (gnutls-negotiate): Add hostname, verify-flags,
+ verify-error, and verify-hostname-error parameters. Check whether
+ default trustfile exists before going to use it. Add missing
+ argument to gnutls-message-maybe call. Return return value.
+ Reported by Claudio Bley <claudio.bley@gmail.com>.
+ (open-gnutls-stream): Add usage example.
- * net/tramp-compat.el (tramp-compat-copy-directory)
- (tramp-compat-delete-directory): New defuns.
+ * net/network-stream.el (network-stream-open-starttls): Give host
+ parameter to `gnutls-negotiate'.
+ (gnutls-negotiate): Adjust `gnutls-negotiate' declaration.
+ * subr.el (shell-quote-argument): Escape correctly under Windows.
- * net/tramp-fish.el (tramp-fish-handle-delete-directory):
- * net/tramp-gvfs.el (tramp-gvfs-handle-delete-directory):
- Use `tramp-compat-delete-directory'.
+2011-04-24 Daniel Colascione <dan.colascione@gmail.com>
- * net/tramp-smb.el (tramp-smb-handle-copy-directory)
- (tramp-smb-handle-delete-directory):
- Use `tramp-compat-copy-directory' and `tramp-compat-delete-directory'.
+ * progmodes/cc-engine.el (c-forward-decl-or-cast-1):
+ Use correct match group (bug#8438).
- * net/trampver.el: Update release number.
+2011-04-24 Chong Yidong <cyd@stupidchicken.com>
-2009-11-07 Chong Yidong <cyd@stupidchicken.com>
-
- * tar-mode.el (tar-copy): Call write-region on the right buffer
- (Bug#4857).
-
- * mail/rmailsum.el (rmail-summary-rmail-update): Call linum-update
- by hand, if necessary (Bug#4878).
-
-2009-11-06 Chong Yidong <cyd@stupidchicken.com>
-
- * buff-menu.el (Buffer-menu-buffer+size): Use display property to
- align size column (Bug#4839).
-
- * emacs-lisp/autoload.el (autoload-rubric): Always issue a provide
- statement.
-
-2009-11-05 Dan Nicolaescu <dann@ics.uci.edu>
-
- * progmodes/ld-script.el (auto-mode-alist):
- * vc-hooks.el (vc-directory-exclusion-list): Purecopy strings.
-
- * cus-face.el (custom-declare-face): Purecopy face spec.
-
-2009-11-06 Kenichi Handa <handa@m17n.org>
-
- * international/uni-bidi.el: Re-generated.
- * international/uni-category.el: Re-generated.
- * international/uni-combining.el: Re-generated.
- * international/uni-mirrored.el: Re-generated.
-
-2009-11-05 Dan Nicolaescu <dann@ics.uci.edu>
-
- * textmodes/tex-mode.el (tex-alt-dvi-print-command)
- (tex-dvi-print-command, tex-bibtex-command, tex-start-commands)
- (tex-start-options, slitex-run-command, latex-run-command)
- (tex-run-command, tex-directory):
- * textmodes/ispell.el (ispell-html-skip-alists)
- (ispell-tex-skip-alists, ispell-tex-skip-alists):
- * textmodes/fill.el (adaptive-fill-first-line-regexp):
- (adaptive-fill-regexp):
- * textmodes/dns-mode.el (auto-mode-alist):
- * progmodes/python.el (interpreter-mode-alist):
- * progmodes/etags.el (tags-compression-info-list):
- * progmodes/etags.el (tags-file-name):
- * net/browse-url.el (browse-url-galeon-program)
- (browse-url-firefox-program):
- * mail/sendmail.el (mail-signature-file)
- (mail-citation-prefix-regexp):
- * international/mule-conf.el (eight-bit):
- * international/latexenc.el (latex-inputenc-coding-alist):
- * international/fontset.el (x-pixel-size-width-font-regexp):
- * emacs-lisp/warnings.el (warning-type-format):
- * emacs-lisp/trace.el (trace-buffer):
- * emacs-lisp/lisp-mode.el (lisp-interaction-mode-map)
- (emacs-lisp-mode-map):
- * calendar/holidays.el (holiday-solar-holidays)
- (holiday-bahai-holidays, holiday-islamic-holidays)
- (holiday-christian-holidays, holiday-hebrew-holidays)
- (hebrew-holidays-4, hebrew-holidays-3, hebrew-holidays-2)
- (hebrew-holidays-1, holiday-oriental-holidays)
- (holiday-general-holidays):
- * x-dnd.el (x-dnd-known-types):
- * tool-bar.el (tool-bar):
- * startup.el (site-run-file):
- * shell.el (shell-dumb-shell-regexp):
- * rfn-eshadow.el (file-name-shadow-tty-properties)
- (file-name-shadow-properties):
- * paths.el (remote-shell-program, news-directory):
- * mouse.el ([C-down-mouse-3]):
- * menu-bar.el (menu-bar-tools-menu):
- * jka-cmpr-hook.el (jka-compr-load-suffixes)
- (jka-compr-mode-alist-additions, jka-compr-compression-info-list)
- (jka-compr-compression-info-list):
- * isearch.el (search-whitespace-regexp):
- * image-file.el (image-file-name-extensions):
- * find-dired.el (find-ls-option):
- * files.el (directory-listing-before-filename-regexp)
- (directory-free-space-args, insert-directory-program)
- (list-directory-brief-switches, magic-fallback-mode-alist)
- (magic-fallback-mode-alist, auto-mode-interpreter-regexp)
- (automount-dir-prefix):
- * faces.el (face-x-resources, x-font-regexp, x-font-regexp-head)
- (x-font-regexp-slant, x-font-regexp-weight, face-x-resources)
- (face-font-registry-alternatives, face-font-registry-alternatives)
- (face-font-family-alternatives):
- * facemenu.el (facemenu-add-new-face, facemenu-background-menu)
- (facemenu-foreground-menu, facemenu-face-menu):
- * epa-hook.el (epa-file-name-regexp):
- * dnd.el (dnd-protocol-alist):
- * textmodes/rst.el (auto-mode-alist):
- * button.el (default-button): Purecopy strings.
-
-2009-11-06 Glenn Morris <rgm@gnu.org>
-
- * Makefile.in (ELCFILES): Update.
-
-2009-11-05 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * emacs-lisp/lucid.el: Move to obsolete/lucid.el.
- * emacs-lisp/levents.el: Move to obsolete/levents.el.
-
- * nxml/xsd-regexp.el (xsdre-gen-categories):
- * nxml/xmltok.el (xmltok-parse-entity):
- * nxml/rng-parse.el (rng-parse-validate-file):
- * nxml/rng-maint.el (rng-format-manual)
- (rng-manual-output-force-new-line):
- * nxml/rng-loc.el (rng-save-schema-location-1):
- * nxml/rng-cmpct.el (rng-c-parse-file):
- * nxml/nxml-maint.el (nxml-insert-target-repertoire-glyph-set):
- * nxml/nxml-parse.el (nxml-parse-file): Use with-current-buffer.
-
-2009-11-05 Wilson Snyder <wsnyder@wsnyder.org>
-
- * progmodes/verilog-mode.el (verilog-getopt-file, verilog-set-define):
- Remove extra save-excursions and make-variable-buffer-local's.
- Suggested by Stefan Monnier.
-
- (verilog-getopt-file, verilog-module-inside-filename-p)
- (verilog-set-define): Merge GNU 1.35 and repair changes from
- switching to using with-current-buffer.
-
- (verilog-read-always-signals-recurse): Fix "a == 2'b00 ? b : c"
- being treated as a number and confusing AUTORESET.
- Reported by Dan Dever.
-
- (verilog-auto-ignore-concat, verilog-read-sub-decls-expr):
- Add verilog-auto-ignore-concat to fix backward compatibility with
- older verilog-modes. Reported by Dan Katz.
-
- (verilog-read-auto-template): Fix AUTO_TEMPLATEs with regexps
- containing closing anchors "...$".
-
- (verilog-read-decls): Fix AUTOREG not detecting "assign {a,b}".
- Reported by Wade Smith.
-
- (verilog-batch-execute-func): Comment on function usage.
-
-2009-11-05 Michael McNamara <mac@mail.brushroad.com>
-
- * progmodes/verilog-mode.el (verilog-label-re): Fix regular expression
- for labels.
-
- (verilog-label-re, verilog-calc-1): Support proper indent of named
- asserts.
-
- (verilog-backward-token, verilog-basic-complete-re)
- (verilog-beg-of-statement, verilog-indent-re): Support proper
- indent of the assert statement at the beginning of a block of text.
-
- (verilog-beg-block-re, verilog-ovm-begin-re): Support the
- `ovm_object_param_utils_begin and `ovm_component_param_utils_begin
- tokens as begins.
-
-2009-11-05 Glenn Morris <rgm@gnu.org>
-
- * emacs-lisp/bytecomp.el (byte-compile-insert-header): Drop test for
- Emacs 19. (Bug#1531)
- (byte-compile-fix-header): Update for the above change.
- Drop test for epoch::version.
-
- * emacs-lisp/autoload.el (autoload-rubric): Add optional feature arg.
- * cus-dep.el (custom-make-dependencies):
- * finder.el (finder-compile-keywords):
- Use autoload-rubric's feature argument.
-
- * calendar/diary-lib.el (top-level): Make load behave more like require.
+ * emacs-lisp/package.el (package-built-in-p): Fix typo.
+ (package-menu--generate): New arg specifying packages to show.
+ (package-menu-refresh, package-menu-execute, list-packages):
+ Callers changed.
+ (package-show-package-list): New function, replacing deleted
+ package--list-packages (renamed because it is non-internal).
- * vc-git.el (vc-git-stash-map): Move definition before use.
+ * finder.el (finder-list-matches): Use package-show-package-list
+ instead of deleted package--list-packages.
-2009-11-04 Dan Nicolaescu <dann@ics.uci.edu>
+ * vc/vc-annotate.el (vc-annotate-goto-line): New command.
+ Based on a previous implementation by Juanma Barranquero (Bug#8366).
+ (vc-annotate-mode-map): Bind it to RET.
- * custom.el (custom-declare-group): Purecopy standard-value.
- (custom-declare-group): Purecopy custom-prefix.
+2011-04-24 Uday S Reddy <u.s.reddy@cs.bham.ac.uk> (tiny change)
- * international/mule.el (load-with-code-conversion):
- Call do-after-load-evaluation unconditionally.
+ * progmodes/etags.el (next-file): Don't use set-buffer to change
+ buffers (Bug#8478).
- * emacs-lisp/bytecomp.el (byte-compile-output-file-form): Handle defvaralias.
+2011-04-24 Chong Yidong <cyd@stupidchicken.com>
-2009-11-04 Stefan Monnier <monnier@iro.umontreal.ca>
+ * files.el (auto-mode-alist): Use js-mode for .json (Bug#8529).
- * descr-text.el: Require help-mode rather than help-fns (bug#4861).
+ * apropos.el (apropos-label-face): Avoid variable-pitch face.
+ (apropos-accumulator): Doc fix.
+ (apropos-function, apropos-macro, apropos-command)
+ (apropos-variable, apropos-face, apropos-group, apropos-widget)
+ (apropos-plist): Add face property.
+ (apropos-symbols-internal): Fix indentation.
+ (apropos-print): Simplify help, and recognize apropos-multi-type.
+ (apropos-print-doc): Use button-type-get to extract the button's
+ face property. Fill docstring (Bug#8352).
-2009-11-04 Glenn Morris <rgm@gnu.org>
+2011-04-23 Juanma Barranquero <lekktu@gmail.com>
- * emacs-lisp/bytecomp.el (byte-compile-version-cond): Remove macro.
- (byte-compile-compatibility): Remove option.
- (byte-compile-close-variables, byte-compile-fix-header)
- (byte-compile-insert-header, byte-compile-output-docform)
- (byte-compile-file-form-defmumble, byte-compile-byte-code-maker)
- (byte-compile-lambda, byte-compile-form, byte-defop-compiler19)
- (byte-compile-list, byte-compile-concat, byte-compile-function-form)
- (byte-compile-insert, byte-compile-defun):
- Remove support for byte-compile-compatibility and Emacs 18. (Bug#4571)
- (byte-defop-compiler19): Remove.
- Without byte-compile-compatibility, the 'emacs19-opcode property is not
- used by anything. Replace all calls with byte-defop-compiler.
+ * buff-menu.el (Buffer-menu--buffers): Fix typo in docstring (bug#8535).
-2009-11-04 Juri Linkov <juri@jurta.org>
+ * play/mpuz.el (mpuz-silent): Doc fix.
+ (mpuz-mode-map): Use mapc.
+ (mpuz-put-number-on-board): Rename parameter L to COLUMNS.
+ (mpuz-letter-to-digit, mpuz-check-all-solved, mpuz-create-buffer):
+ Fix typos in docstrings.
- * menu-bar.el (menu-bar-make-mm-toggle): Quote each element of `props'.
- (menu-bar-options-menu): Don't quote the `prop' arg of
- `menu-bar-make-mm-toggle'.
+ * play/doctor.el (doc$, doctor-$, doctor-read-print, doctor-read-token)
+ (doctor-nounp, doctor-pronounp): Fix typos in docstrings.
-2009-11-04 Juanma Barranquero <lekktu@gmail.com>
+ * mouse-drag.el (mouse-drag-throw): Fix typo in docstring.
- * calendar/calendar.el (cal-loaddefs):
- * calendar/diary-lib.el (diary-loaddefs):
- * calendar/holidays.el (hol-loaddefs):
- * eshell/esh-module.el (esh-groups): Load rather than require.
+2011-04-23 Chong Yidong <cyd@stupidchicken.com>
-2009-11-03 Stefan Monnier <monnier@iro.umontreal.ca>
+ * minibuffer.el (completion--do-completion): Avoid the "Next char
+ not unique" prompt if icomplete-mode is enabled (Bug#5849).
- * calendar/todo-mode.el (todo-add-category): Don't hardcode
- point-min==1.
- (todo-top-priorities): Only display-buffer when called interactively.
- (todo-item-start): Don't save excursion point.
- (todo-item-end): Be slightly more careful. Add `include-sep' arg.
- (todo-insert-item-here, todo-file-item, todo-remove-item):
- Adjust uses of todo-item-start and todo-item-end.
+ * mouse.el (mouse-drag-mode-line-1): Make sure that if we push
+ mouse-2 into unread-command-events, it is interpreted correctly.
- * emacs-lisp/autoload.el (generated-autoload-feature): Remove.
- (autoload-rubric): Don't use any more.
+ * image-mode.el (image-type, image-mode-map, image-minor-mode-map)
+ (image-toggle-display): Doc fix.
- * emacs-lisp/byte-run.el (define-obsolete-variable-alias): Use dolist,
- and only put a prop if it is non-nil.
+2011-04-23 Stephen Berman <stephen.berman@gmx.net>
-2009-11-03 Juri Linkov <juri@jurta.org>
+ * textmodes/page.el (what-page): Use line-number-at-pos to
+ calculate line number (Bug#6825).
- * menu-bar.el (menu-bar-make-mm-toggle, menu-bar-make-toggle)
- (menu-bar-options-menu): Fix list quoting (Bug#4429).
+2011-04-22 Juanma Barranquero <lekktu@gmail.com>
- * buff-menu.el (Buffer-menu-mode-map): Add hyphen between "Buffer"
- and "Menu" to make top-level menu item visually one unit (like
- it's done for "Lisp-Interaction", "Emacs-Lisp" and other
- multi-word menu items). Fix :help string for quit-window.
+ * eshell/esh-mode.el (find-tag-interactive): Declare function.
+ (eshell-find-tag): Remove `with-no-warnings', unneeded now.
+ Pass argument NO-DEFAULT to `find-tag-interactive'.
-2009-11-03 Glenn Morris <rgm@gnu.org>
+2011-04-22 Juanma Barranquero <lekktu@gmail.com>
- * emacs-lisp/bytecomp.el (byte-compile-file-form-defvar)
- (byte-compile-file-form-define-abbrev-table)
- (byte-compile-file-form-custom-declare-variable)
- (byte-compile-variable-ref, byte-compile-defvar):
- Whether or not a warning is enabled should only affect whether we issue
- the warning, not whether or not we collect the relevant data.
- Eg warnings can be turned on and off throughout the course of a file.
+ Lexical-binding cleanup.
+
+ * progmodes/ada-mode.el (ada-after-change-function, ada-loose-case-word)
+ (ada-no-auto-case, ada-capitalize-word, ada-untab, ada-narrow-to-defun):
+ * progmodes/ada-prj.el (ada-prj-initialize-values)
+ (ada-prj-display-page, ada-prj-field-modified, ada-prj-display-help)
+ (ada-prj-show-value):
+ * progmodes/ada-xref.el (ada-find-any-references, ada-gdb-application):
+ * progmodes/antlr-mode.el (antlr-with-displaying-help-buffer)
+ (antlr-invalidate-context-cache, antlr-options-menu-filter)
+ (antlr-language-option-extra, antlr-c++-mode-extra, antlr-run-tool):
+ * progmodes/bug-reference.el (bug-reference-push-button):
+ * progmodes/fortran.el (fortran-line-length):
+ * progmodes/glasses.el (glasses-change):
+ * progmodes/octave-mod.el (octave-fill-paragraph):
+ * progmodes/python.el (python-mode, python-pdbtrack-track-stack-file)
+ (python-pdbtrack-grub-for-buffer, python-sentinel):
+ * progmodes/sql.el (sql-save-connection):
+ * progmodes/tcl.el (tcl-indent-command, tcl-popup-menu):
+ * progmodes/xscheme.el (xscheme-enter-debugger-mode):
+ Mark unused parameters.
+
+ * progmodes/compile.el (compilation--flush-directory-cache)
+ (compilation--flush-parse, compile-internal): Mark unused parameters.
+ (compilation-buffer-name): Rename parameter MODE-NAME to NAME-OF-MODE.
+ (compilation-next-error-function): Remove unused variable `timestamp'.
+
+ * progmodes/cpp.el (cpp-parse-close): Remove unused variable `begin'.
+ (cpp-signal-read-only, cpp-grow-overlay): Mark unused parameters.
+
+ * progmodes/dcl-mode.el (dcl-end-of-command):
+ Remove unused variable `start'.
+ (dcl-calc-command-indent-multiple, dcl-calc-cont-indent-relative)
+ (dcl-option-value-basic, dcl-option-value-offset)
+ (dcl-option-value-margin-offset, dcl-option-value-comment-line):
+ Mark unused parameters.
+ (dcl-save-local-variable): Remove unused variable `val'.
+ (mode): Declare.
+
+ * progmodes/delphi.el (delphi-save-state, delphi-after-change):
+ Mark unused parameters.
+ (delphi-ignore-changes): Move before first use.
+ (delphi-charset-token-at): Remove unused variable `start'.
+ (delphi-else-start): Remove unused variable `if-count'.
+ (delphi-comment-block-start, delphi-comment-block-end):
+ Remove unused variable `kind'.
+ (delphi-indent-line): Remove unused variable `new-point'.
+
+ * progmodes/ebrowse.el (ebrowse-files-list)
+ (ebrowse-list-of-matching-members, ebrowse-tags-list-members-in-file):
+ Mark unused parameters. Don't quote `lambda'.
+ (ebrowse-sort-tree-list, ebrowse-same-tree-member-buffer-list):
+ Don't quote `lambda'.
+ (ebrowse-revert-tree-buffer-from-file, ebrowse-tags-choose-class)
+ (ebrowse-goto-visible-member/all-member-lists): Mark unused parameters.
+ (ebrowse-create-tree-buffer): Rename parameter OBARRAY to CLASSES.
+ (ebrowse-toggle-mark-at-point): Remove unused variable `pnt'.
+ Use `ignore-errors'.
+ (ebrowse-frozen-tree-buffer-name, ebrowse-find-source-file)
+ (ebrowse-view/find-file-and-search-pattern)
+ (ebrowse-view/find-member-declaration/definition):
+ Rename parameter TAGS-FILE-NAME to TAGS-FILE.
+ (ebrowse-find-class-declaration, ebrowse-view-class-declaration):
+ Rename parameter PREFIX-ARG to PREFIX.
+ (ebrowse-tags-read-name): Remove unused variables `start' and
+ `member-info'.
+ (ebrowse-display-member-buffer): Rename variable `tags-file-name'
+ to `tags-file'.
+
+ * progmodes/etags.el (local-find-tag-hook): Declare.
+ (tag-partial-file-name-match-p, tag-any-match-p, list-tags):
+ Mark unused parameters.
+
+ * progmodes/executable.el (compilation-error-regexp-alist): Declare.
+ (executable-interpret): Mark unused parameter.
+
+ * progmodes/flymake.el (flymake-process-sentinel)
+ (flymake-after-change-function)
+ (flymake-create-temp-with-folder-structure)
+ (flymake-get-include-dirs-dot): Mark unused parameters.
+ (flymake-safe-delete-directory): Remove unused variable `err'.
+
+ * progmodes/gdb-mi.el (speedbar-change-initial-expansion-list)
+ (speedbar-timer-fn, speedbar-line-text)
+ (speedbar-change-expand-button-char, speedbar-delete-subblock)
+ (speedbar-center-buffer-smartly): Declare functions.
+ (gdb-find-watch-expression): Remove unused variable `array'.
+ (gdb-edit-value, gdb-gdb, gdb-ignored-notification, gdb-thread-created)
+ (gdb-starting): Mark unused parameters.
+ (gud-gdbmi-marker-filter): Remove unused variable `output-record'.
+ (gdb-table-string): Remove unused variable `res'.
+ (gdb-place-breakpoints): Remove unused variables `flag' and `bptno'.
+ (gdb-disassembly-handler-custom): Remove unused variable `pos'.
+ (gdb-display-buffer): Remove unused variable `cur-size'.
+
+ * progmodes/gud.el (gud-def): Use `defalias' instead of `defun' to
+ allow lexical-binding compilation.
+ (gud-expansion-speedbar-buttons, gud-gdb-goto-stackframe)
+ (gud-dbx-massage-args, gud-xdb-massage-args, gud-perldb-massage-args)
+ (gud-jdb-massage-args, gud-jdb-find-source, gud-find-class):
+ Mark unused parameters.
+ (gud-gdb-marker-filter): Remove unused variable `match'.
+ (gud-find-class): Bind `syntax-symbol' and `syntax-point' to suitable
+ lambda expressions and funcall them, instead of using `fset'.
+
+ * progmodes/hideif.el (hif-parse-if-exp): Rename parameter
+ HIF-TOKEN-LIST to TOKEN-LIST and let-bind `hif-token-list'.
+
+ * progmodes/hideshow.el (hs-hide-block-at-point): Remove unused
+ variable `header-beg'; use `let'.
+
+ * progmodes/icon.el (indent-icon-exp): Remove unused variables
+ `restart', `last-sexp' and `at-do'.
+
+ * progmodes/js.el (js--debug): Mark unused parameter.
+ (js--parse-state-at-point): Remove unused variable `bound'; use `let'.
+ (js--splice-into-items): Remove unused variable `item'.
+ (js--read-symbol, js--read-tab): Pass 1/-1 to `ido-mode', not t/nil.
+
+ * progmodes/make-mode.el (makefile-make-font-lock-keywords):
+ Rename parameter FONT-LOCK-KEYWORDS to FL-KEYWORDS.
+ (makefile-complete): Remove unused variable `try'.
+ (makefile-fill-paragraph, makefile-match-function-end):
+ Mark unused parameters.
+
+ * progmodes/octave-inf.el (inferior-octave-complete):
+ Remove unused variable `proc'.
+ (inferior-octave-output-digest): Mark unused parameter.
+
+ * progmodes/perl-mode.el (perl-calculate-indent):
+ Remove unused variable `err'.
+
+ * progmodes/prolog.el (prolog-mode-keybindings-inferior)
+ (prolog-indent-line): Mark unused parameters.
+ (prolog-indent-line): Remove unused variable `beg'.
+
+ * progmodes/ps-mode.el (reporter-prompt-for-summary-p)
+ (reporter-dont-compact-list): Declare.
+
+ * progmodes/sh-script.el (sh-font-lock-quoted-subshell):
+ Remove unused variable `char'.
+ (sh-debug): Mark unused parameter.
+ (sh-get-indent-info): Remove unused variable `start'.
+ (sh-calculate-indent): Remove unused variable `var'.
+
+ * progmodes/simula.el (simula-popup-menu): Mark unused parameter.
+ (simula-electric-keyword): Remove unused variable `null'.
+ (simula-search-backward, simula-search-forward): Remove unused
+ variables `begin' and `end'.
+
+ * progmodes/vera-mode.el (vera-guess-basic-syntax):
+ Remove unused variable `pos'.
+ (vera-electric-tab, vera-comment-uncomment-region):
+ Mark unused parameters.
+ (vera-electric-tab): Rename parameter PREFIX-ARG to PREFIX.
+
+2011-04-22 Chong Yidong <cyd@stupidchicken.com>
+
+ * emacs-lisp/package.el (package--builtins, package-alist)
+ (package-load-descriptor, package-built-in-p, package-activate)
+ (define-package, package-installed-p)
+ (package-compute-transaction, package-buffer-info)
+ (package--push): Doc fix. Distinguish more clearly between
+ version strings and version lists.
- * eshell/esh-mode.el (ansi-color-apply-on-region): Autoload it...
- (eshell-handle-ansi-color): ... Rather than requiring ansi-color.
+2011-04-21 Juanma Barranquero <lekktu@gmail.com>
-2009-11-03 Stefan Monnier <monnier@iro.umontreal.ca>
+ Lexical-binding cleanup.
- * term/ns-win.el (ns-scroll-bar-move, ns-face-at-pos):
- * play/mpuz.el (mpuz-create-buffer):
- * play/landmark.el (lm-prompt-for-move, lm-print-wts, lm-print-smell)
- (lm-print-y,s,noise, lm-print-w0, lm-init):
- * play/gomoku.el (gomoku-prompt-for-move):
+ * play/5x5.el (5x5-make-random-solution, 5x5-make-mutate-current)
+ (5x5-make-mutate-best):
* play/fortune.el (fortune-in-buffer):
- * play/dissociate.el (dissociated-press):
- * play/decipher.el (decipher-adjacency-list, decipher-display-regexp)
- (decipher-analyze-buffer, decipher-stats-buffer, decipher-stats-buffer):
- * mail/supercite.el (sc-eref-show):
- * mail/smtpmail.el (smtpmail-send-it):
- * mail/rmailsum.el (rmail-summary-next-labeled-message)
- (rmail-summary-previous-labeled-message, rmail-summary-wipe)
- (rmail-summary-undelete-many, rmail-summary-rmail-update)
- (rmail-summary-goto-msg, rmail-summary-expunge)
- (rmail-summary-get-new-mail, rmail-summary-search-backward)
- (rmail-summary-add-label, rmail-summary-output-menu)
- (rmail-summary-output-body):
- * mail/rfc822.el (rfc822-addresses):
- * mail/reporter.el (reporter-dump-variable, reporter-dump-state):
- * mail/mailpost.el (post-mail-send-it):
- * mail/hashcash.el (hashcash-generate-payment):
- * mail/feedmail.el (feedmail-run-the-queue)
- (feedmail-queue-send-edit-prompt-help-first)
- (feedmail-send-it-immediately, feedmail-give-it-to-buffer-eater)
- (feedmail-deduce-address-list):
- * eshell/esh-ext.el (eshell-remote-command):
- * eshell/em-unix.el (eshell-occur-mode-mouse-goto):
- * emulation/viper-util.el (viper-glob-unix-files, viper-save-setting)
- (viper-wildcard-to-regexp, viper-glob-mswindows-files)
- (viper-save-string-in-file, viper-valid-marker):
- * emulation/viper-keym.el (viper-toggle-key):
- * emulation/viper-ex.el (ex-expand-filsyms, viper-get-ex-file)
- (ex-edit, ex-global, ex-mark, ex-next-related-buffer, ex-quit)
- (ex-get-inline-cmd-args, ex-tag, ex-command, ex-compile):
- * emulation/viper-cmd.el (viper-exec-form-in-vi)
- (viper-exec-form-in-emacs, viper-brac-function):
- * emulation/viper.el (viper-delocalize-var):
- * emulation/vip.el (vip-mode, vip-get-ex-token, vip-ex, vip-get-ex-pat)
- (vip-get-ex-command, vip-get-ex-opt-gc, vip-get-ex-buffer)
- (vip-get-ex-count, vip-get-ex-file, ex-edit, ex-global, ex-mark)
- (ex-map, ex-unmap, ex-quit, ex-read, ex-tag, ex-command):
- * emulation/vi.el (vi-switch-mode, vi-ex-cmd):
- * emulation/edt.el (edt-electric-helpify):
- * emulation/cua-rect.el (cua--rectangle-aux-replace):
- * emulation/cua-gmrk.el (cua--insert-at-global-mark)
- (cua--delete-at-global-mark, cua--copy-rectangle-to-global-mark)
- (cua-indent-to-global-mark-column):
- * calendar/diary-lib.el (calendar-mark-1):
- * calendar/cal-hebrew.el (calendar-hebrew-mark-date-pattern):
- Use with-current-buffer.
- * emulation/viper.el (viper-delocalize-var): Use dolist.
-
-2009-11-03 Chong Yidong <cyd@stupidchicken.com>
-
- * comint.el (comint-replace-by-expanded-history-before-point):
- Replace !! with the previous input string literally (Bug#1795).
-
-2009-11-02 Jay Belanger <jay.p.belanger@gmail.com>
-
- * calc/calc-forms.el (calc-date-notation): Allow a "blank string"
- to be made up of whitespace.
-
-2009-11-02 Chong Yidong <cyd@stupidchicken.com>
-
- * minibuffer.el (read-file-name): Don't use file dialogs for
- remote directories (Bug#99).
-
-2009-11-01 Chong Yidong <cyd@stupidchicken.com>
-
- * progmodes/sh-script.el (sh-font-lock-paren): Fix last change.
-
-2009-11-01 Andreas Schwab <schwab@linux-m68k.org>
-
- * view.el (view-mode-exit): If OLD-BUF is dead bury the buffer
- instead of deleting the window or frame.
-
-2009-10-31 Chong Yidong <cyd@stupidchicken.com>
-
- * textmodes/sgml-mode.el (sgml-mode-facemenu-add-face-function):
- Support face colors.
-
- * textmodes/tex-mode.el (tex-facemenu-add-face-function):
- New function. Support face colors (Bug#1168).
- (tex-common-initialization): Use it.
-
- * facemenu.el (facemenu-enable-faces-p): Enable facemenu if the
- mode allows it (Bug#1168).
-
-2009-10-31 Juri Linkov <juri@jurta.org>
-
- * facemenu.el (list-colors-display): Don't mark buffer as
- modified (Bug#3948).
-
-2009-10-31 Chong Yidong <cyd@stupidchicken.com>
-
- * international/mule-diag.el (list-character-sets-1):
- Minor message fix (Bug#3526).
-
- * progmodes/etags.el (etags-list-tags, etags-tags-apropos):
- Fix face property (Bug#4834).
- (etags-list-tags, etags-tags-apropos-additional)
- (etags-tags-apropos, tags-select-tags-table): Add follow-link
- property.
-
- * menu-bar.el (menu-bar-tools-menu): Add Semantic and EDE menu
- items.
-
-2009-10-31 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * textmodes/two-column.el (2C-split):
- * textmodes/texnfo-upd.el (texinfo-multi-file-included-list):
- * textmodes/tex-mode.el (tex-set-buffer-directory):
- * textmodes/spell.el (spell-region, spell-string):
- * textmodes/reftex.el (reftex-erase-buffer):
- (reftex-get-file-buffer-force, reftex-kill-temporary-buffers):
- * textmodes/reftex-toc.el (reftex-toc-promote-action):
- * textmodes/reftex-sel.el (reftex-get-offset, reftex-insert-docstruct)
- (reftex-select-item):
- * textmodes/reftex-ref.el (reftex-label-info-update)
- (reftex-offer-label-menu):
- * textmodes/reftex-index.el (reftex-index-change-entry)
- (reftex-index-phrases-info):
- * textmodes/reftex-global.el (reftex-create-tags-file)
- (reftex-save-all-document-buffers, reftex-ensure-write-access):
- * textmodes/reftex-dcr.el (reftex-echo-ref, reftex-echo-cite)
- (reftex-view-crossref-from-bibtex):
- * textmodes/reftex-cite.el (reftex-bibtex-selection-callback)
- (reftex-extract-bib-entries-from-thebibliography)
- (reftex-all-used-citation-keys, reftex-create-bibtex-file):
- * textmodes/refbib.el (r2b-capitalize-title):
- (r2b-convert-buffer, r2b-help):
- * textmodes/page-ext.el (pages-directory)
- (pages-directory-goto-with-mouse):
- * textmodes/bibtex.el (bibtex-validate-globally):
- * textmodes/bib-mode.el (bib-capitalize-title):
- * textmodes/artist.el (artist-clear-buffer, artist-system):
- * progmodes/xscheme.el (global-set-scheme-interaction-buffer):
- (local-set-scheme-interaction-buffer, xscheme-process-filter)
- (verify-xscheme-buffer, xscheme-enter-interaction-mode)
- (xscheme-enter-debugger-mode, xscheme-debugger-mode-p)
- (xscheme-send-control-g-interrupt, xscheme-start-process)
- (xscheme-process-sentinel, xscheme-cd):
- * progmodes/verilog-mode.el (verilog-read-always-signals)
- (verilog-set-define, verilog-getopt-file)
- (verilog-module-inside-filename-p):
- * progmodes/sh-script.el:
- * progmodes/python.el (python-pdbtrack-get-source-buffer)
- (python-pdbtrack-grub-for-buffer, python-execute-file):
- * progmodes/octave-inf.el (inferior-octave):
- * progmodes/idlwave.el (idlwave-scan-user-lib-files)
- (idlwave-shell-compile-helper-routines, idlwave-set-local)
- (idlwave-display-completion-list-xemacs, idlwave-list-abbrevs)
- (idlwave-display-completion-list-emacs, idlwave-list-load-path-shadows)
- (idlwave-completion-fontify-classes, idlwave-display-calling-sequence):
- * progmodes/idlw-shell.el (idlwave-shell-examine-display-clear)
- (idlwave-shell-filter, idlwave-shell-examine-highlight)
- (idlwave-shell-sentinel, idlwave-shell-filter-directory)
- (idlwave-shell-display-line, idlwave-shell-set-bp-in-module)
- (idlwave-shell-examine-display, idlwave-shell-run-region)
- (idlwave-shell-filter-bp, idlwave-shell-save-and-action)
- (idlwave-shell-sources-filter, idlwave-shell-goto-next-error):
- * progmodes/idlw-help.el (idlwave-help-get-special-help)
- (idlwave-help-get-help-buffer):
- * progmodes/gud.el (gud-basic-call, gud-find-class)
- (gud-tooltip-activate-mouse-motions-if-enabled):
- * progmodes/gdb-mi.el (gdb-mouse-toggle-breakpoint-fringe):
- * progmodes/ebrowse.el (ebrowse-member-table, ebrowse-save-tree-as)
- (ebrowse-view-exit-fn, ebrowse-tags-list-members-in-file)
- (ebrowse-tags-next-file):
- * progmodes/ebnf2ps.el (ebnf-generate-eps, ebnf-generate-eps)
- (ebnf-eps-production-list, ebnf-begin-file, ebnf-log)
- (ebnf-eps-finish-and-write):
- * progmodes/cpp.el (cpp-edit-save):
- * progmodes/cperl-mode.el (cperl-pod-to-manpage):
- * progmodes/cc-defs.el (c-emacs-features):
- * progmodes/antlr-mode.el (antlr-invalidate-context-cache)
- (antlr-directory-dependencies):
- * progmodes/ada-xref.el (ada-gnat-parse-gpr, ada-get-ali-file-name)
- (ada-run-application, ada-find-in-src-path, ada-goto-parent)
- (ada-find-any-references, ada-make-filename-from-adaname)
- (ada-make-body-gnatstub):
- * obsolete/rnews.el (news-list-news-groups):
- * obsolete/resume.el (resume-suspend-hook, resume-write-buffer-to-file):
- * obsolete/iso-acc.el (iso-acc-minibuf-setup):
- * net/rcirc.el (rcirc-debug):
- * net/newst-treeview.el (newsticker--treeview-list-add-item)
- (newsticker--treeview-list-clear, newsticker-treeview-browse-url)
- (newsticker--treeview-list-update-faces, newsticker-treeview-save)
- (newsticker--treeview-item-show-text, newsticker--treeview-item-show)
- (newsticker--treeview-tree-update-tag, newsticker--treeview-buffer-init)
- (newsticker-treeview-show-item, newsticker--treeview-unfold-node)
- (newsticker--treeview-list-clear-highlight)
- (newsticker--treeview-list-update-highlight)
- (newsticker--treeview-list-highlight-start)
- (newsticker--treeview-tree-update-highlight)
- (newsticker--treeview-get-selected-item)
- (newsticker-treeview-mark-list-items-old)
- (newsticker--treeview-set-current-node):
- * net/newst-plainview.el (newsticker--buffer-set-uptodate):
- * net/newst-backend.el (newsticker--get-news-by-funcall)
- (newsticker--get-news-by-wget, newsticker--image-get)
- (newsticker--image-sentinel):
- * net/mairix.el (mairix-rmail-fetch-field, mairix-gnus-fetch-field):
- * net/eudcb-ph.el (eudc-ph-do-request, eudc-ph-open-session):
- (eudc-ph-close-session):
- * net/eudc.el (eudc-save-options):
- * language/thai-word.el (thai-update-word-table):
- * language/japan-util.el (japanese-string-conversion):
- * international/titdic-cnv.el (tsang-quick-converter)
- (ziranma-converter, ctlau-converter):
- * international/mule-cmds.el (describe-language-environment):
- * international/ja-dic-cnv.el (skkdic-convert-okuri-ari)
- (skkdic-convert-postfix, skkdic-convert-prefix):
- (skkdic-convert-okuri-nasi, skkdic-convert):
- * emacs-lisp/re-builder.el (reb-update-overlays):
- * emacs-lisp/pp.el (pp-to-string, pp-display-expression):
- * emacs-lisp/gulp.el (gulp-send-requests):
- * emacs-lisp/find-gc.el (trace-call-tree):
- * emacs-lisp/eieio-opt.el (eieio-browse, eieio-describe-class)
- (eieio-describe-generic):
- * emacs-lisp/eieio-base.el (eieio-persistent-read):
- * emacs-lisp/edebug.el (edebug-outside-excursion):
- * emacs-lisp/debug.el (debugger-make-xrefs):
- * emacs-lisp/cust-print.el (custom-prin1-to-string):
- * emacs-lisp/chart.el (chart-new-buffer):
- * emacs-lisp/authors.el (authors-scan-el, authors-scan-change-log):
- Use with-current-buffer.
- * textmodes/artist.el (artist-system): Don't call
- copy-sequence on a fresh string.
- * progmodes/idlw-shell.el (easymenu setup): Use dolist.
-
-2009-10-31 Stephen Berman <stephen.berman@gmx.net>
-
- * calendar/todo-mode.el (todo-edit-item): Signal an error if there
- is no item to edit. (Bug#4820)
- (todo-top-priorities): Restore point and restore narrowing in Todo
- buffer. (Bug#4820)
-
-2009-10-31 Glenn Morris <rgm@gnu.org>
-
- * net/ange-ftp.el (top-level): Don't require dired when compiling.
- (comint-last-output-start, comint-last-input-start)
- (comint-last-input-end): Don't defvar when compiling.
- (ange-ftp-process-file): Use bound-and-true-p.
-
- * pcmpl-rpm.el (top-level): Move provide statement to end.
- (pcmpl-rpm): Remove unused custom group.
-
- * pcmpl-gnu.el (tar-parse-info, tar-header-name): Declare for compiler.
-
- * mail/emacsbug.el (report-emacs-bug): Request `emacs -Q' recipes.
-
- * emacs-lisp/bytecomp.el (byte-compile-warning-types)
- (byte-compile-warnings): Add `constants' as an option.
- (byte-compile-callargs-warn, byte-compile-arglist-warn)
- (display-call-tree): Update for byte-compile-fdefinition possibly
- returning `(macro lambda ...)'. (Bug#4778)
- (byte-compile-variable-ref, byte-compile-setq-default):
- Respect `constants' member of byte-compile-warnings.
-
-2009-10-30 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * vc-bzr.el (vc-bzr-revision-keywords): New var.
- (vc-bzr-revision-completion-table): Use it to fix completion of "s:"
- to "submit:".
-
-2009-10-30 Dan Nicolaescu <dann@ics.uci.edu>
-
- * textmodes/ispell.el (ispell-skip-region-alist):
- * international/mule-conf.el (eight-bit):
- * international/fontset.el (font-encoding-alist):
- * startup.el (pure-space-overflow-message):
- * simple.el (overwrite-mode-textual, overwrite-mode-binary):
- * paths.el (gnus-nntp-service, rmail-spool-directory)
- (term-file-prefix):
- * files.el (save-some-buffers-action-alist):
- * cmuscheme.el (same-window-buffer-names):
- * ielm.el (same-window-buffer-names):
- * shell.el (same-window-buffer-names):
- * mail/sendmail.el (same-window-buffer-names):
- * progmodes/inf-lisp.el (same-window-buffer-names):
- * bindings.el (mode-line-client)
- (mode-line-column-line-number-mode-map):
- * language/tibetan.el (tibetan-precomposition-rule-regexp)
- (tibetan-precomposed-regexp): Purecopy string arguments.
-
-2009-10-28 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * calc/calc.el (calc, calc-refresh, calc-trail-buffer, calc-record)
- (calcDigit-nondigit):
- * calc/calc-yank.el (calc-copy-to-buffer):
- * calc/calc-units.el (calc-invalidate-units-table):
- * calc/calc-trail.el (calc-trail-yank):
- * calc/calc-store.el (calc-insert-variables):
- * calc/calc-rewr.el (math-rewrite, math-rewrite-phase):
- * calc/calc-prog.el (calc-read-parse-table):
- * calc/calc-keypd.el (calc-do-keypad, calc-keypad-right-click):
- * calc/calc-help.el (calc-describe-bindings, calc-describe-key):
- * calc/calc-graph.el (calc-graph-delete, calc-graph-add-curve)
- (calc-graph-juggle, calc-graph-count-curves, calc-graph-plot)
- (calc-graph-plot, calc-graph-format-data, calc-graph-set-styles)
- (calc-graph-name, calc-graph-find-command, calc-graph-view)
- (calc-graph-view, calc-gnuplot-command, calc-graph-init):
- * calc/calc-ext.el (calc-realign):
- * calc/calc-embed.el (calc-do-embedded, calc-do-embedded)
- (calc-embedded-finish-edit, calc-embedded-make-info)
- (calc-embedded-finish-command, calc-embedded-stack-change):
- * calc/calc-aent.el (calcAlg-enter): Use with-current-buffer.
-
- * pcomplete.el (pcomplete-comint-setup): If there's a choice, replace
- shell-dynamic-complete-filename in preference to
- comint-dynamic-complete-filename.
-
- * bookmark.el (bookmark-insert-location, bookmark-bmenu-list)
- (bookmark-bmenu-show-filenames, bookmark-bmenu-hide-filenames):
- Don't consider whether the display supports colors.
- (bookmark-import-new-list): Use dolist.
- (bookmark-bmenu-mode-map): Move initialization into declaration.
- (bookmark-bmenu-list): Use dolist, simplify.
- (bookmark-show-all-annotations): Use save-selected-window and dolist.
- (menu-bar-final-items): Use push.
-
-2009-10-28 Bernhard Herzog <bernhard.herzog@intevation.de> (tiny change)
-
- * vc-hg.el (vc-hg-state, vc-hg-working-revision): Use process-file so
- it works on remote files.
- (vc-hg-diff): Don't pass any `--cwd' argument.
-
-2009-10-27 Kevin Ryde <user42@zip.com.au>
-
- * emacs-lisp/checkdoc.el (checkdoc-proper-noun-region-engine):
- Use help-xref-info-regexp and help-xref-url-regexp to identify links.
- (Further to Bug#3921).
-
-2009-10-27 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp-imap.el (top): Add `X-Size' to `imap-hash-headers'.
- (tramp-imap-do-copy-or-rename-file): Don't use the inode, when
- calling `tramp-imap-put-file'. Add file size to the call.
- (tramp-imap-get-file-entries): Compute also user name, file size,
- and date.
- (tramp-imap-handle-insert-directory): Insert uid and gid.
- (tramp-imap-handle-file-attributes): Transform uid and gid
- according to `id-format'.
- (tramp-imap-put-file): New optional parameter SIZE. Encode file
- size in header X-Size.
-
-2009-10-26 Juanma Barranquero <lekktu@gmail.com>
-
- * simple.el (transpose-subr): Give clearer error when the mark
- is not set. (Bug#4807)
-
-2009-10-26 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-perl-file-truename): New defconst.
- Perl code contributed by yary <not.com@gmail.com> (tiny change).
- (tramp-handle-file-truename, tramp-get-remote-perl): Use it.
- Check also for "perl-file-spec" and "perl-cwd-realpath" properties.
- (tramp-handle-write-region): In case of APPEND, reuse the tmpfile name.
-
- * net/tramp-imap.el (tramp-imap-file-name-handler-alist):
- Ignore `dired-call-process'.
- (tramp-imap-make-iht): Use `user' and `ssl' with `imap-hash-make'.
-
-2009-10-26 Julian Scheid <julians37@gmail.com>
-
- * net/tramp.el (tramp-perl-file-name-all-completions): New defconst.
- (tramp-get-remote-readlink): New defun.
- (tramp-handle-file-truename): Use it.
- (tramp-handle-file-exists-p): Check file-attributes cache, assume
- file exists if cache value present.
- (tramp-check-cached-permissions): New defun.
- (tramp-handle-file-readable-p): Use it.
- (tramp-handle-file-writable-p): Likewise.
- (tramp-handle-file-executable-p): Likewise.
- (tramp-handle-file-name-all-completions): Try using Perl to get
- partial completions. When perl not available, combine `cd' and
- `ls' into single remote operation and use shell expansion to get
- partial remote directory contents. Set `file-exists-p' cache for
- directory and any files returned by ls. Change cache handling to
- support partial directory contents. Use error message emitted by
- remote `cd' or Perl code for local tramp-error.
- (tramp-do-copy-or-rename-file-directly): Avoid separate
- tramp-send-command-and-check call.
- (tramp-handle-process-file): Merge three remote ops into one.
- Do not flush all caches when `process-file-side-effects' is set.
- (tramp-handle-write-region): Avoid tramp-set-file-uid-gid if
- file-attributes shows uid/gid to be set already.
-
-2009-10-26 Dan Nicolaescu <dann@ics.uci.edu>
-
- * textmodes/tex-mode.el (tex-dvi-view-command)
- (tex-show-queue-command, tex-open-quote):
- * progmodes/ruby-mode.el (auto-mode-alist)
- (interpreter-mode-alist): Purecopy strings.
-
- * emacs-lisp/lisp-mode.el (emacs-lisp-mode-map): Purecopy item names.
-
- * emacs-lisp/derived.el (define-derived-mode): Purecopy the doc
- string for the hook, keymap and abbrev table.
-
- * emacs-lisp/byte-run.el (make-obsolete): Purecopy the current name.
-
- * x-dnd.el (x-dnd-xdnd-to-action):
- * startup.el (fancy-startup-text, fancy-about-text): Change to
- defconst from defvar.
-
- * ps-print.el (ps-page-dimensions-database): Purecopy initial value.
-
- * mouse.el (mouse-buffer-menu-mode-groups, x-fixed-font-alist):
- Purecopy initialization strings.
-
- * mail/sendmail.el (mail-header-separator)
- (mail-personal-alias-file):
- * mail/rmail.el (rmail-default-dont-reply-to-names)
- (rmail-ignored-headers, rmail-retry-ignored-headers)
- (rmail-highlighted-headers, rmail-secondary-file-directory)
- (rmail-secondary-file-regexp):
- * files.el (null-device, file-name-invalid-regexp)
- (locate-dominating-stop-dir-regexp)
- (inhibit-first-line-modes-regexps): Purecopy initialization strings.
- (interpreter-mode-alist): Use mapcar instead of mapc.
-
- * buff-menu.el (Buffer-menu-mode-map): Purecopy name.
-
- * bindings.el (mode-line-major-mode-keymap): Purecopy name.
- (completion-ignored-extensions):
- (debug-ignored-errors): Purecopy strings.
-
-2009-10-26 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * pcomplete.el (pcomplete-std-complete): Obey pcomplete-use-paring.
- (pcomplete, pcomplete-parse-buffer-arguments, pcomplete-opt)
- (pcomplete--here): Use push.
-
- * subr.el (all-completions): Declare the 4th arg obsolete.
-
-2009-10-25 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * pcomplete.el (pcomplete-unquote-argument-function): New var.
- (pcomplete-unquote-argument): New function.
- (pcomplete--common-suffix): Always pay attention to case.
- (pcomplete--table-subvert): Quote and unquote the text.
- (pcomplete--common-quoted-suffix): New function.
- (pcomplete-std-complete): Use it and pcomplete-begin.
-
- * bookmark.el (bookmark-bmenu-list): Don't use switch-to-buffer if
- we're inside a dedicated or minibuffer window.
-
-2009-10-24 Karl Fogel <kfogel@red-bean.com>
-
- * bookmark.el: Update documentation, especially documentation
- of `bookmark-alist' and of the bookmark file format.
- Patch by Drew Adams, with minor tweaks from me. (Bug#4195)
-
-2009-10-24 Chong Yidong <cyd@stupidchicken.com>
-
- * mail/emacsbug.el (report-emacs-bug): Clarify that the
- keybindings apply to the mail buffer (Bug#4003). Shrink help
- window to buffer.
-
- * whitespace.el (whitespace-mode, whitespace-newline-mode)
- (global-whitespace-mode, global-whitespace-newline-mode)
- (whitespace-toggle-options, global-whitespace-toggle-options):
- Doc fix (Bug#3660).
-
- * nxml/nxml-mode.el (nxml-balanced-close-start-tag): Use the value
- of xmltok-start before the end tag was inserted (Bug#2840).
-
- * progmodes/sh-script.el (sh-font-lock-paren): Handle case
- patterns that are preceded by an open-paren (Bug#1320).
-
-2009-10-24 Sven Joachim <svenjoac@gmx.de>
-
- * files.el (delete-directory): Delete symlinks to directories with
- delete-file (Bug#4739).
-
-2009-10-24 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc.el (vc-backend-for-registration): Rename from
- vc-get-backend-for-registration. Update callers.
-
- * international/mule-cmds.el (set-language-info-alist):
- Purecopy lang-env.
- (leim-list-header, leim-list-entry-regexp): Change defvars to defconst.
- (charset): Purecopy the name.
- (define-char-code-property): Purecopy string arguments.
-
- * emacs-lisp/byte-run.el (make-obsolete, make-obsolete-variable):
- Purecopy string arguments.
-
- * emacs-lisp/lisp-mode.el (emacs-lisp-mode-map):
- * ediff-hook.el (menu-bar-ediff-menu):
- * buff-menu.el (Buffer-menu-mode-map): Purecopy names and tooltips.
- * bookmark.el (menu-bar-bookmark-map): Add :help and purecopy the name.
-
-2009-10-24 Glenn Morris <rgm@gnu.org>
-
- * comint.el (comint-dynamic-list-completions):
- * term.el (term-dynamic-list-completions): Use choose-completion rather
- than obsolete alias mouse-choose-completion.
-
- * filecache.el (file-cache-completions-keymap): Bind mouse-2 to
- file-cache-choose-completion.
- (file-cache-choose-completion): Handle an optional event argument.
- (file-cache-mouse-choose-completion): Make it an obsolete alias.
-
- * progmodes/octave-mod.el (octave-complete-symbol):
- Use choose-completion if mouse-choose-completion is ever removed.
-
- * textmodes/sgml-mode.el (sgml-looking-back-at): Move definition before
- use.
-
- * emacs-lisp/checkdoc.el (generate-autoload-cookie): Define for
- compiler.
-
- * vc-hooks.el (vc-responsible-backend): Fix declaration.
-
-2009-10-24 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * minibuffer.el (completion--embedded-envvar-table): Fix last change.
- Ignore `pred' now that we receive one.
- Handle test-completion specially.
-
-2009-10-23 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc.el (vc-responsible-backend): Throw an error if not backend is
- found. Remove the REGISTER argument. Move the code dealing with
- REGISTER ...
- (vc-get-backend-for-registration): ... here. New function.
- (vc-deduce-fileset): Call vc-get-backend-for-registration instead
- of vc-responsible-backend, pass the file name instead of the
- directory name.
-
-2009-10-23 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * pcomplete.el (pcomplete-common-suffix, pcomplete-table-subvert):
- New funs.
- (pcomplete-std-complete): Use them. Obey pcomplete-termination-string.
- (pcomplete-comint-setup): Don't modify a global var via
- accidental side-effects.
- (pcomplete-shell-setup): Adjust call accordingly.
- (pcomplete-parse-comint-arguments): Use push.
-
-2009-10-23 Chong Yidong <cyd@stupidchicken.com>
-
- * emacs-lisp/checkdoc.el (checkdoc-proper-noun-region-engine):
- Allow uncapitalized info node names (Bug#3921).
-
- * mail/emacsbug.el (report-emacs-bug): Tweak the sentence pointing
- to the DEBUG file (Bug#3781).
-
-2009-10-23 Jari Aalto <jari.aalto@cante.net>
-
- * textmodes/ispell.el (ispell-dictionary-base-alist): Add finnish
- dictionary entry (Bug#4579).
-
-2009-10-23 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (top): Remove `tramp-rfn-eshadow-update-overlay'
- from `rfn-eshadow-update-overlay-hook' when unloading.
- (tramp-methods): Add `tramp-copy-keep-tmpfile' for "rsync" and
- "rsyncc". Adjust doc string.
- (tramp-temp-buffer-file-name): New buffer-local defvar.
- (tramp-handle-insert-file-contents, tramp-handle-write-region):
- Keep temporary file when indicated by method ("rsync" and
- "rsyncc").
- (tramp-handle-write-region): Handle APPEND.
- (tramp-delete-temp-file-function): New defun. Added to
- `kill-buffer-hook'.
-
-2009-10-23 Juanma Barranquero <lekktu@gmail.com>
-
- * menu-bar.el (cua-enable-cua-keys): Declare for the byte-compiler.
-
-2009-10-23 Dan Nicolaescu <dann@ics.uci.edu>
-
- * term/tty-colors.el (msdos-color-values): Remove declaration, unused.
- (color-name-rgb-alist, tty-standard-colors)
- (tty-color-mode-alist): Change to defconst.
-
- * simple.el (mark-inactive): Purecopy message.
-
- * menu-bar.el (menu-bar-make-mm-toggle, menu-bar-make-toggle): Fix macro.
- (global-map, yank-menu):
- * textmodes/ispell.el (ispell-menu-map):
- * net/eudc.el (eudc-tools-menu):
- * international/mule-cmds.el (describe-language-environment-map)
- (setup-language-environment-map, set-coding-system-map)
- (mule-menu-keymap):
- * vc-hooks.el (vc-menu-entry, vc-menu-map):
- * replace.el (occur-mode-map):
- * pcvs-defs.el (cvs-global-menu): Purecopy names and tooltips.
-
-2009-10-23 Jay Belanger <jay.p.belanger@gmail.com>
-
- * calc/calc.el (math-read-number, math-read-number-simple):
- Use `save-match-data'.
-
-2009-10-22 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * simple.el (normal-erase-is-backspace-mode): Use input-decode-map
- rather than fiddling with global-map bindings, since it should only
- affect per-terminal settings.
- See http://bugs.gentoo.org/show_bug.cgi?id=289709.
-
- * minibuffer.el (completion-table-with-terminator): Allow to specify
- the terminator-regexp.
-
- * simple.el (switch-to-completions): Look for *Completions* in other
- frames as well.
-
- * pcomplete.el: Allow the use of completion-tables.
- (pcomplete-std-complete): New command.
- (pcomplete-dirs-or-entries): Use a single call to pcomplete-entries.
- (pcomplete--here): Use a function for `form' rather than an expression,
- so it can be byte-compiled.
- (pcomplete-here, pcomplete-here*): Adjust accordingly.
- Add edebug declaration.
- (pcomplete-show-completions): Remove unused var `curbuf'.
- (pcomplete-do-complete, pcomplete-stub):
- Don't assume `completions' is a list of strings any more.
-
-2009-10-22 Juanma Barranquero <lekktu@gmail.com>
-
- * find-dired.el (find-name-arg): Fix typo in docstring.
-
-2009-10-22 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * pcmpl-linux.el (pcomplete/kill): Don't abuse pcomplete-entries.
- (pcmpl-linux-fs-types): Same, and update to new modules layout.
-
- * pcmpl-gnu.el (pcmpl-gnu-makefile-names): Use a single call to
- pcomplete-entries.
-
- * comint.el (comint-read-input-ring, comint-write-input-ring)
- (comint-substitute-in-file-name)
- (comint-dynamic-complete-as-filename)
- (comint-dynamic-simple-complete)
- (comint-dynamic-list-filename-completions)
- (comint-dynamic-list-completions)
- (comint-redirect-results-list-from-process): Minor simplifications.
-
-2009-10-21 Kevin Ryde <user42@zip.com.au>
-
- * emacs-lisp/checkdoc.el (checkdoc-file-comments-engine):
- When inserting ";;; Code" put it before any ";;;###autoload" cookie on
- the first form. And insert a blank line after ";;; Code" since
- that's usual style. (Bug#4612)
-
- * net/dns.el: Add "Keywords: comm", as per net/net-utils.el.
-
-2009-10-21 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * minibuffer.el (completion-table-with-terminator): Properly implement
- boundaries, in case `terminator' appears in the suffix.
- (completion--embedded-envvar-table): Don't return boundaries if
- there's no valid completion. Simplify.
- (completion-file-name-table): New completion table extracted from
- completion--file-name-table.
- (completion--file-name-table): Use it.
- (read-file-name-predicate): Declare obsolete.
- (read-file-name): Use the pred arg i.s.o read-file-name-predicate.
- * vc-bzr.el (vc-bzr-revision-completion-table): Use the new
- completion-file-name-table, and use the `pred' argument.
- * files.el (locate-file-completion-table): Use the `pred' arg rather
- than read-file-name-predicate.
- (abbreviate-file-name): Use \` rather than ^ for BOS.
-
-2009-10-21 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc.el (vc-deduce-fileset): Undo previous change, do not tell
- vc-responsible-backend to register, it causes problems.
-
-2009-10-21 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * help-fns.el: Don't require help-mode (to avoid bootstrap issues).
-
-2009-10-21 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp-smb.el (tramp-smb-get-stat-capability): New defun.
- (tramp-smb-handle-file-attributes): Use it.
- (tramp-smb-do-file-attributes-with-stat): Don't raise an error.
- (tramp-smb-handle-insert-directory): Use `mapc' rather than
- `mapcar'. Use `tramp-smb-get-stat-capability'.
- Add `dired-filename' text properties.
- (tramp-smb-get-cifs-capabilities): Apply `save-match-data'.
- (tramp-smb-maybe-open-connection): Simplify check for smbclient
- version.
-
-2009-10-20 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * subr.el (read-key-delay): Reduce to 0.01.
- (read-key): Use read-key-sequence-vector to avoid turning M-t into 244
- (bug#4751).
-
-2009-10-19 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * bindings.el (function-key-map): Map C-@ to C-SPC if C-@ is unbound.
-
- * info.el (Info-complete-menu-item): Handle `boundaries' explicitly.
- (Info-menu): Remove unused vars `last' and `completions'.
- (Info-index-nodes): Remove unused var `node'.
-
- * info.el (Info-complete-menu-item): Use complete-with-action.
-
-2009-10-19 Dan Nicolaescu <dann@ics.uci.edu>
-
- Make vc-annotate work through copies and renames.
- * vc-annotate.el (vc-annotate-extract-revision-at-line):
- Return the file name too.
- (vc-annotate-revision-at-line)
- (vc-annotate-find-revision-at-line)
- (vc-annotate-revision-previous-to-line)
- (vc-annotate-show-log-revision-at-line): Update to get the file
- name from vc-annotate-extract-revision-at-line.
- (vc-annotate-show-diff-revision-at-line-internal): Change the
- argument to mean whether to show a file diff or not. Get the file
- name from vc-annotate-extract-revision-at-line.
- (vc-annotate-show-diff-revision-at-line):
- Update vc-annotate-show-diff-revision-at-line call.
- (vc-annotate-warp-revision): Add an optional file argument.
-
- * vc-git.el (vc-git-annotate-command): Pass -C -C to the blame command.
- (vc-git-annotate-extract-revision-at-line): Also return the file
- name if found.
-
- * vc-hg.el (vc-hg-annotate-command): Pass --follow to the annotate
- command. Remove unused code.
- (vc-hg-annotate-re): Update to match --follow output.
- (vc-hg-annotate-extract-revision-at-line): Also return the file
- name if found.
-
- * vc.el: Update annotate-extract-revision-at-line documentation.
-
-2009-10-18 Kevin Ryde <user42@zip.com.au>
-
- * ibuffer.el (ibuffer-confirm-operation-on): Correction to error
- re-throw, `err' is a pair not a list so can't use apply (Bug#4740).
-
- * net/browse-url.el (browse-url): Identify alist with "consp and
- not functionp" and let all other things go down the `apply' leg,
- as suggested by Stefan. (Further to bug#4531.)
-
-2009-10-18 Chong Yidong <cyd@stupidchicken.com>
-
- * minibuffer.el (read-file-name): Check for repeat before putting
- a default argument in file-name-history (Bug#4657).
-
- * emacs-lisp/lisp-mode.el (preceding-sexp): Recognize hash table
- read syntax (Bug#4737).
-
- * textmodes/sgml-mode.el (sgml-delete-tag): Use sgml-looking-back-at.
-
-2009-10-18 Aaron S. Hawley <aaron.s.hawley@gmail.com>
-
- * textmodes/sgml-mode.el (sgml-tag-help): Prompt user for tag.
- (html-tag-alist, html-tag-help): Add descriptions for undocumented
- entries and make note of obsolete tags.
-
-2009-10-18 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * net/ange-ftp.el (ange-ftp-file-size): Use unwind-protect.
-
-2009-10-18 Glenn Morris <rgm@gnu.org>
-
- * Makefile.in (compile-last): Ensure GREP_OPTIONS is null before calling
- grep, so that binary files (eg international/uni-bidi.el) can match.
- Remove test for "UnicodeData" files, since it is hopefully unnecessary
- now, and in any case the file header format has changed.
-
-2009-10-17 Glenn Morris <rgm@gnu.org>
-
- * textmodes/flyspell.el (flyspell-large-region, flyspell-word)
- (flyspell-get-word, flyspell-large-region)
- (flyspell-auto-correct-previous-word): Doc/error message fixes.
-
-2009-10-17 Chong Yidong <cyd@stupidchicken.com>
-
- * Makefile.in (ELCFILES): Add ede/shell.
-
-2009-10-17 Dan Nicolaescu <dann@ics.uci.edu>
-
- * term/common-win.el (x-colors): Purecopy it.
-
-2009-10-17 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * tar-mode.el (tar-data-swapped-p): Make the assertion a bit more
- permissive for when the buffer is empty.
- (tar-header-block-tokenize): Decode the username and groupname.
- (tar-chown-entry, tar-chgrp-entry): Encode the names (bug#4730).
-
-2009-10-17 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * international/mule-cmds.el (select-safe-coding-system): If the file
- has a coding cookie, use it regardless of any other setting (bug#4712).
-
-2009-10-17 Glenn Morris <rgm@gnu.org>
-
- * foldout.el (foldout-mouse-swallow-events):
- * gs.el (gs-load-image): Replace obsolete forms of sit-for, sleep-for.
-
- * dired.el (dired-ls-F-marks-symlinks, dired-keep-marker-rename)
- (dired-keep-marker-copy, dired-keep-marker-hardlink)
- (dired-keep-marker-symlink, dired-dwim-target)
- (dired-copy-preserve-time): Do not autoload these defcustoms.
-
- * mail/rmail.el (rmail-write-region-annotate): Prevent viewing different
- messages from messing up the file coding. (Bug#4623)
-
-2009-10-17 Jari Aalto <jari.aalto@cante.net>
-
- * textmodes/ispell.el (ispell-get-decoded-string): Give an error
- if no match is found for the current dictionary. (Bug#4578)
-
- * textmodes/flyspell.el (flyspell-get-word): Make `following' argument
- optional, since that is how it is documented, and this is often called
- with a nil argument. (Bug#4577)
- (flyspell-external-point-words, flyspell-auto-correct-word)
- (flyspell-correct-word-before-point, flyspell-word-search-forward)
- (flyspell-word-search-backward): Remove nil argument in calls to
- flyspell-get-word, since it is not needed now.
-
-2009-10-17 Ulrich Mueller <ulm@gentoo.org>
-
- * play/doctor.el (doctor-adverbp): Exclude some nouns. (Bug#4565)
-
-2009-10-16 Glenn Morris <rgm@gnu.org>
-
- * net/rcirc.el (rcirc-authenticate): Simplify previous change.
-
-2009-10-16 Toru TSUNEYOSHI <t_tuneyosi@hotmail.com>
-
- * net/ange-ftp.el (ange-ftp-send-cmd): Handle `size' like `mdtm'.
- (ange-ftp-file-size): New function.
- (ange-ftp-file-attributes): Use it.
-
-2009-10-16 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp-smb.el (tramp-smb-version): New defvar.
- (tramp-smb-maybe-open-connection): Use it, in order to avoid
- repeated checks.
-
-2009-10-16 Glenn Morris <rgm@gnu.org>
-
- * emacs-lisp/byte-run.el (define-obsolete-variable-alias): Doc fix.
- Maybe copy some custom properties from old to new name. (Bug#4706)
-
-2009-10-16 Juanma Barranquero <lekktu@gmail.com>
-
- * subr.el (error, sit-for, start-process-shell-command)
- (start-file-process-shell-command): Set the calling convention
- after the function definition.
-
-2009-10-16 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * subr.el (error, sit-for, start-process-shell-command)
- (start-file-process-shell-command): Use the new
- set-advertised-calling-convention feature.
-
-2009-10-16 Taichi Kawabata <kawabata.taichi@gmail.com>
-
- * international/ucs-normalize.el (ucs-normalize-version):
- Change to 1.2.
- (check-range): Adjust for Unicode 5.2.
-
-2009-10-15 Juri Linkov <juri@jurta.org>
-
- * menu-bar.el (menu-bar-file-menu): Convert `separator-exit'
- to the `menu-item' format.
-
-2009-10-15 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-replace-environment-variables): Do not fail
- if the environment variable does not exist.
-
- * net/tramp-smb.el (tramp-smb-errors): Add error messages.
- (tramp-smb-get-share, tramp-smb-get-localname): Use only VEC as
- parameter.
- (tramp-smb-handle-add-name-to-file)
- (tramp-smb-handle-copy-directory, tramp-smb-handle-copy-file)
- (tramp-smb-handle-delete-directory, tramp-smb-handle-delete-file)
- (tramp-smb-handle-file-attributes)
- (tramp-smb-do-file-attributes-with-stat)
- (tramp-smb-handle-file-local-copy)
- (tramp-smb-handle-insert-directory)
- (tramp-smb-handle-make-directory)
- (tramp-smb-handle-make-directory-internal)
- (tramp-smb-handle-make-symbolic-link)
- (tramp-smb-handle-rename-file, tramp-smb-handle-set-file-modes)
- (tramp-smb-handle-write-region, tramp-smb-get-file-entries)
- (tramp-smb-maybe-open-connection): Apply the changed parameters.
- (tramp-smb-read-file-entry): Read Disk names in compressed format.
- Handle long file names.
- (tramp-smb-get-cifs-capabilities): Check, whether the connection
- process is running.
- (tramp-smb-maybe-open-connection): Trace "smbclient -V" command.
- Read share names with "-g" option.
-
-2009-10-15 Ryan Yeske <rcyeske@gmail.com>
-
- * net/rcirc.el (rcirc-view-log-file): New command.
- (rcirc-track-minor-mode-map): Remove C-c ` binding.
- (rcirc-authenticate, rcirc-authinfo): Allow nickserv-nick to be
- specified.
-
-2009-10-15 Glenn Morris <rgm@gnu.org>
-
- * w32-fns.el (w32-batch-update-autoloads): Take autoload-make-program
- from the second command-line argument.
- * makefile.w32-in (autoloads, $(lisp)/calendar/cal-loaddefs.el)
- ($(lisp)/calendar/diary-loaddefs.el, $(lisp)/calendar/hol-loaddefs.el)
- ($(lisp)/mh-e/mh-loaddefs.el): Pass $(MAKE) as second argument to
- w32-batch-update-autoloads.
- * emacs-lisp/autoload.el (autoload-make-program): New variable.
- (batch-update-autoloads): Handle autoload-excludes on windows-nt.
-
- * mail/rmailedit.el (rmail-cease-edit): Give an error if the end of
- the headers cannot be located. Simplify, subtracting superflous
- save-excursions.
-
-2009-10-15 Stefan Monnier <monnier@iro.umontreal.ca>
-
- Replace completion-base-size by completion-base-position to fix bugs
- such as (bug#4699).
- * simple.el (completion-base-position): New var.
- (completion-base-size): Mark as obsolete.
- (choose-completion): Make it work for mouse events as well.
- Pass the new base-position to choose-completion-string.
- (choose-completion-guess-base-position): New function, extracted from
- choose-completion-delete-max-match.
- (choose-completion-delete-max-match): Use it. Make obsolete.
- (choose-completion-string): Use the new base-position info.
- (completion-root-regexp): Delete.
- (completion-setup-function): Preserve completion-base-position.
- Eliminate obsolete base-size manipulation.
- * minibuffer.el (display-completion-list): Don't mess with base-size.
- (minibuffer-completion-help): Set completion-base-position instead.
- * mouse.el (mouse-choose-completion): Redefine as a mere alias to
- choose-completion.
- * textmodes/bibtex.el (bibtex-complete):
- * emacs-lisp/crm.el (crm--choose-completion-string):
- Adjust to new calling convention.
- * complete.el (partial-completion-mode): Use minibufferp to avoid
- bumping into incompatible change to choose-completion-string-functions.
- * ido.el (ido-choose-completion-string): Make its calling convention
- more permissive.
- * comint.el (comint-dynamic-list-input-ring-select): Remove obsolete
- base-size manipulation.
- (comint-dynamic-list-input-ring): Use dotimes and push.
- * iswitchb.el (iswitchb-completion-help): Remove dead-code call to
- fundamental-mode. Use `or'.
-
-2009-10-14 Juri Linkov <juri@jurta.org>
-
- * misearch.el (multi-isearch-next-buffer-from-list)
- (multi-isearch-next-file-buffer-from-list): Doc fix. (Bug#4723)
-
-2009-10-14 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * Makefile.in (compile-onefile): Load `bytecomp' rather than
- `bytecomp.el'.
-
- * minibuffer.el (completion-pcm--merge-completions): Make sure the
- string we return is all made up of text from the completions rather
- than part from the completions and part from the input (bug#4219).
-
- * ido.el (ido-everywhere): Use define-minor-mode.
-
- * buff-menu.el (list-buffers, ctl-x-map):
- Mark the entry points with ;;;###autoload cookies.
-
-2009-10-14 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc-git.el (vc-git-dir-extra-headers): Set the branch name
- correctly in the detached head case.
- (vc-git-print-log): Remove unused binding.
-
- * vc.el (vc-responsible-backend): When a directory is passed for
- for registration create a VC repository if no backend is
- responsible for the directory argument.
- (vc-deduce-fileset): Tell vc-responsible-backend to register.
-
- * vc.el: Move comments about RCS and SCCS ...
- * vc-rcs.el:
- * vc-sccs.el: ... here, respectively.
-
-2009-10-14 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * minibuffer.el (completion--file-name-table): Return nil if there's
- no file completion, even if substitute-in-file-name changed
- the string (bug#4708).
-
-2009-10-13 Juri Linkov <juri@jurta.org>
-
- * files-x.el (read-file-local-variable-value): Don't filter out
- minor modes from mode name completion (bug#4664).
-
-2009-10-13 Juanma Barranquero <lekktu@gmail.com>
-
- * international/mule-cmds.el (ucs-names): Remove exclusion of
- "Enclosed Ideographic Supplement" range (U+1F200..U+1F2FF).
-
-2009-10-13 Kenichi Handa <handa@m17n.org>
-
- * international/uni-name.el: Regenerated.
-
-2009-10-13 Juanma Barranquero <lekktu@gmail.com>
-
- * bs.el (bs-mode): Fix last change. (`revert-buffer-function'
- should be automatically buffer-local, but isn't.)
-
-2009-10-12 Sam Steingold <sds@gnu.org>
-
- * progmodes/compile.el (compilation-next-error-function): Fix the
- timestamps if the buffer has been visited before.
- (compilation-mode-font-lock-keywords): Do not prepend "^ *" to
- non-anchored patterns, like the perl one (bug#3928).
-
-2009-10-12 Glenn Morris <rgm@gnu.org>
-
- * net/tramp-smb.el (tramp-smb-do-file-attributes-with-stat):
- Let-bind `size'.
-
-2009-10-12 Juanma Barranquero <lekktu@gmail.com>
-
- * proced.el (proced-unload-function): New function.
-
- * bs.el (bs-mode): Set `revert-buffer-function' to `bs-refresh'.
- (bs-refresh): Add IGNORED arg for `revert-buffer' compatibility.
- Doc fix.
-
- * menu-bar.el (menu-bar-file-menu): Fix format of `separator-exit' item.
-
-2009-10-11 Juri Linkov <juri@jurta.org>
-
- * files-x.el (read-file-local-variable-value):
- Provide default value only for bound variables (bug#4664).
-
-2009-10-11 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-local-host-p): Function shall return nil for
- connection methods like smb.
-
- * net/tramp-cache.el (tramp-flush-connection-property): The hash
- can be empty.
-
- * net/tramp-smb.el (tramp-smb-errors): Add error messages.
- (tramp-smb-file-name-handler-alist): Add handlers for
- `add-name-to-file', `make-symbolic-link'.
- (tramp-smb-handle-add-name-to-file)
- (tramp-smb-do-file-attributes-with-stat)
- (tramp-smb-handle-make-symbolic-link)
- (tramp-smb-get-cifs-capabilities): New defuns.
- (tramp-smb-handle-copy-directory, tramp-smb-handle-copy-file)
- (tramp-smb-handle-delete-directory, tramp-smb-handle-delete-file)
- (tramp-smb-handle-file-local-copy)
- (tramp-smb-handle-make-directory-internal)
- (tramp-smb-handle-rename-file, tramp-smb-handle-write-region):
- The file name syntax depends on cifs capabilities.
- (tramp-smb-handle-file-attributes):
- Call `tramp-smb-do-file-attributes-with-stat' if possible.
- (tramp-smb-handle-insert-directory): Use posix attributes if possible.
- (tramp-smb-handle-set-file-modes): It is applicable for posix only.
-
-2009-10-11 Chong Yidong <cyd@stupidchicken.com>
-
- * emacs-lisp/eieio.el: Avoid requiring cl at runtime.
- (eieio-defclass): Apply deftype handler and setf-method properties
- directly.
- (eieio-add-new-slot): Avoid union function from cl library.
- (eieio--typep): New function.
- (eieio-perform-slot-validation): Use it.
-
-2009-10-10 Karl Fogel <kfogel@red-bean.com>
-
- * bookmark.el (bookmark-yank-word, bookmark-insert-current-bookmark):
- Update documentation to refer to the variables documented in r1.135.
- (Bug#4188)
-
-2009-10-10 Karl Fogel <kfogel@red-bean.com>
-
- * bookmark.el (Info-suffix-list): Remove this unused variable.
- (bookmark-current-point): Remove this obsolete variable.
- (bookmark-set, bookmark-rename, bookmark-send-edited-annotation):
- Adjust for removal of bookmark-current-point.
-
- (bookmarks-already-loaded, bookmark-current-buffer)
- (bookmark-yank-point): Document. (Bug#4188)
-
-2009-10-10 Glenn Morris <rgm@gnu.org>
-
- * frame.el (frame-height): Doc fix.
+ * play/gomoku.el (gomoku-init-display):
+ * play/solitaire.el (solitaire, solitaire-do-check):
+ * play/tetris.el (tetris-default-update-speed-function):
+ Mark unused parameters.
+
+ * play/bubbles.el (bubbles-mode): Set `show-trailing-whitespace'.
+ (bubbles--shift): Remove unused variable `char-org'.
+ (bubbles--set-faces): Remove unused variable `fg-col'. Simplify.
+ (bubbles--show-images): Remove unused variable `char'.
+
+ * play/decipher.el (decipher-keypress, decipher-alphabet-keypress)
+ (decipher-get-undo, decipher-set-map, decipher-complete-alphabet)
+ (decipher-resync, decipher-loop-with-breaks, decipher--analyze)
+ (decipher-analyze-buffer): Use ?\s.
+ (decipher-make-checkpoint): Remove unused variable `mapping'.
+
+ * play/doctor.el (doctor-doc): Rename parameter DOCTOR-SENT to SENT.
+
+ * play/gamegrid.el (gamegrid-add-score-with-update-game-score):
+ Remove unused variable `result'; use `let'.
+
+ * play/gametree.el (gametree-current-layout, gametree-apply-layout):
+ Rename parameter TOP-LEVEL to FROM-TOP-LEVEL; use `ignore-errors'.
+ (gametree-children-shown-p, gametree-compute-reduced-score):
+ Use `ignore-errors'.
+
+ * play/handwrite.el (ps-lpr-switches): Declare.
+ (handwrite): Remove unused variables `pmin' and `lastp'.
+
+ * play/hanoi.el (hanoi-move-ring): Remove unused variable `total-steps'.
+
+ * play/landmark.el (landmark-init-display)
+ (landmark-update-naught-weights): Mark unused parameters.
+ (landmark-y): Remove unused variable `noise'. Simplify.
+ (landmark-human-plays): Remove unused variable `score'.
+
+ * play/mpuz.el (mpuz-try-letter): Remove unused variable `message'.
+ (mpuz-try-proposal): Remove unused variable `game'.
+
+ * play/zone.el (life-patterns): Declare.
+
+2011-04-20 Juanma Barranquero <lekktu@gmail.com>
+
+ * vc/vc.el (ediff-vc-internal): Declare function.
+
+2011-04-20 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * shell.el: Use lexical-binding and std completion UI.
+ (shell-filter-ctrl-a-ctrl-b): Work as a preoutput filter.
+ (shell-mode): Put shell-filter-ctrl-a-ctrl-b on
+ comint-preoutput-filter-functions rather than on
+ comint-output-filter-functions.
+ (shell-command-completion, shell--command-completion-data)
+ (shell-filename-completion, shell-environment-variable-completion)
+ (shell-c-a-p-replace-by-expanded-directory): New functions.
+ (shell-dynamic-complete-functions, shell-dynamic-complete-command)
+ (shell-dynamic-complete-filename, shell-replace-by-expanded-directory)
+ (shell-dynamic-complete-environment-variable): Use them.
+ (shell-dynamic-complete-as-environment-variable)
+ (shell-dynamic-complete-as-command): Remove.
+ (shell-match-partial-variable): Match past point.
+ * comint.el: Clean up use of completion-at-point-functions.
+ (comint-completion-at-point): New function.
+ (comint-mode): Use it completion-at-point-functions.
+ (comint-dynamic-complete): Make it obsolete.
+ (comint-replace-by-expanded-history-before-point): Add dry-run arg.
+ (comint-c-a-p-replace-by-expanded-history): New function.
+ (comint-dynamic-complete-functions)
+ (comint-replace-by-expanded-history): Use it.
+ * minibuffer.el (completion-table-with-terminator): Allow dynamic
+ termination strings. Try harder to avoid second try-completion.
+ (completion-in-region-mode-map): Disable bindings that don't work yet.
+
+ * comint.el: Use lexical-binding. Require CL.
+ (comint-dynamic-complete-functions): Use comint-filename-completion.
+ (comint-completion-addsuffix): Tweak custom type.
+ (comint-filename-completion, comint--common-suffix)
+ (comint--common-quoted-suffix, comint--table-subvert)
+ (comint--complete-file-name-data): New functions.
+ (comint-dynamic-complete-as-filename, comint-dynamic-complete-filename)
+ (comint-dynamic-list-filename-completions): Use them.
+ (comint-dynamic-simple-complete): Make obsolete.
+
+ * minibuffer.el (completion-in-region-mode):
+ Keep completion-in-region-mode--predicate global.
+ (completion-in-region--postch):
+ Assume completion-in-region-mode--predicate is not null.
- * calendar/calendar.el (calendar-split-width-threshold): New option.
- (calendar-basic-setup): Use calendar-split-width-threshold.
-
-2009-10-09 Juanma Barranquero <lekktu@gmail.com>
-
- * international/mule-cmds.el (ucs-names): Exclude new "Enclosed
- Ideographic Supplement" range (U+1F200..U+1F2FF).
-
-2009-10-09 Karl Fogel <kfogel@red-bean.com>
-
- * bookmark.el (bookmark-bmenu-rename): Don't call bookmark-bmenu-list,
- since the list will have been rebuilt anyway. (Bug#4349)
-
-2009-10-09 Karl Fogel <kfogel@red-bean.com>
-
- * bookmark.el (bookmark-delete): Don't let batch arg prevent saving.
- (bookmark-bmenu-execute-deletions): Don't save here, as
- bookmark-delete will now do so if necessary.
- Suggested by Thierry Volpiatto <thierry.volpiatto {_AT_} gmail.com>.
- (Bug#4348)
-
-2009-10-09 Glenn Morris <rgm@gnu.org>
-
- * mail/emacsbug.el (report-emacs-bug): Also print `features'.
-
-2009-10-09 Karl Fogel <kfogel@red-bean.com>
-
- * bookmark.el (bookmark-jump): Add new `display-func' parameter.
- (bookmark-jump-other-window): Just invoke bookmark-jump with new
- argument now, so the two function's behaviors will match. (Bug#3645)
-
-2009-10-08 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-file-name-real-user, tramp-file-name-domain)
- (tramp-file-name-real-host, tramp-file-name-port):
- Apply `save-match-data'.
-
- * net/tramp-smb.el (tramp-smb-handle-copy-directory): Handle the
- case both directories are remote.
- (tramp-smb-handle-expand-file-name): Implement "~" expansion.
- (tramp-smb-maybe-open-connection): Flush the cache only if necessary.
-
-2009-10-07 Juanma Barranquero <lekktu@gmail.com>
-
- * makefile.w32-in (WINS_UPDATES): Fix typo in previous change.
-
-2009-10-07 Glenn Morris <rgm@gnu.org>
-
- * emacs-lisp/autoload.el (batch-update-autoloads): Remove useless use
- of concat.
-
-2009-10-07 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * files-x.el (read-file-local-variable): Include some
- non-user-variables in the completion table (bug#4664).
-
-2009-10-07 Michael Albinus <michael.albinus@gmx.de>
+ * progmodes/flymake.el (flymake-start-syntax-check-process):
+ Obey `dir'. Simplify.
+
+ * vc/vc.el (vc-version-ediff): Call ediff-vc-internal directly, since
+ we're in VC after all.
+
+2011-04-20 Christoph Scholtes <cschol2112@googlemail.com>
+
+ * vc/vc.el (vc-diff-build-argument-list-internal)
+ (vc-version-ediff, vc-ediff): New commands.
+ (vc-version-diff): Use vc-diff-build-argument-list-internal.
+
+2011-04-20 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/byte-opt.el (byte-decompile-bytecode-1): Remove dead code,
+ add sanity check.
+
+ * obsolete/erc-hecomplete.el: Make obsolete.
+ * obsolete/: Standardize obsolescence info in the header.
+
+2011-04-20 Glenn Morris <rgm@gnu.org>
+
+ * calendar/solar.el (solar-horizontal-coordinates):
+ Use the longitude argument rather than `calendar-longitude'.
+ (solar-date-next-longitude): Remove unused locals.
+
+2011-04-20 Vinicius Jose Latorre <viniciusjl@ig.com.br>
+
+ * whitespace.el: New version 13.2.1.
+
+2011-04-20 felix <EmacsWiki> (tiny change)
+
+ * whitespace.el (global-whitespace-mode): keep highlight when
+ switching between major modes on a file.
+
+2011-04-19 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/octave-mod.el (octave-in-comment-p, octave-in-string-p)
+ (octave-not-in-string-or-comment-p): Use syntax-ppss so it works with
+ multi-line comments as well.
+
+2011-04-19 Juanma Barranquero <lekktu@gmail.com>
+
+ Lexical-binding cleanup.
+
+ * arc-mode.el (archive-mode-revert):
+ * cmuscheme.el (scheme-interactively-start-process):
+ * custom.el (custom-initialize-delay):
+ * dnd.el (dnd-open-local-file, dnd-open-remote-url):
+ * dos-w32.el (direct-print-region-helper, direct-print-region-function):
+ * emacs-lock.el (emacs-lock-clear-sentinel):
+ * ezimage.el (defezimage):
+ * follow.el (follow-avoid-tail-recenter):
+ * fringe.el (set-fringe-mode-1):
+ * generic-x.el (bat-generic-mode-compile):
+ * help-mode.el (help-info-variable, help-do-xref)
+ (help-mode-revert-buffer):
+ * help.el (view-emacs-todo):
+ * iswitchb.el (iswitchb-completion-help):
+ * jka-compr.el (jka-compr-make-temp-name, jka-compr-load):
+ * kmacro.el (kmacro-cycle-ring-next, kmacro-cycle-ring-previous)
+ (kmacro-delete-ring-head, kmacro-bind-to-key, kmacro-view-macro):
+ * locate.el (locate-update):
+ * longlines.el (longlines-encode-region)
+ (longlines-after-change-function):
+ * outline.el (outline-isearch-open-invisible):
+ * ps-def.el (declare-function, charset-dimension, char-width)
+ (encode-char):
+ * ps-mule.el (ps-mule-plot-string):
+ * recentf.el (recentf-make-menu-items, recentf-cancel-dialog)
+ (recentf-edit-list-select, recentf-edit-list-validate)
+ (recentf-open-files-action):
+ * rect.el (delete-whitespace-rectangle-line)
+ (rectangle-number-line-callback):
+ * register.el (window-configuration-to-register)
+ (frame-configuration-to-register):
+ * scroll-bar.el (scroll-bar-mode, toggle-horizontal-scroll-bar):
+ * select.el (xselect-convert-to-string, xselect-convert-to-length)
+ (xselect-convert-to-targets, xselect-convert-to-delete)
+ (xselect-convert-to-filename, xselect-convert-to-charpos)
+ (xselect-convert-to-lineno, xselect-convert-to-colno)
+ (xselect-convert-to-os, xselect-convert-to-host)
+ (xselect-convert-to-user, xselect-convert-to-class)
+ (xselect-convert-to-name, xselect-convert-to-integer)
+ (xselect-convert-to-atom, xselect-convert-to-identity):
+ * subr.el (declare, ignore, process-kill-without-query)
+ (text-clone-maintain):
+ * terminal.el (te-get-char, te-tic-sentinel):
+ * tool-bar.el (tool-bar-make-keymap):
+ * tooltip.el (tooltip-timeout, tooltip-hide, tooltip-help-tips):
+ * type-break.el (type-break-mode, type-break-noninteractive-query):
+ * view.el (View-back-to-mark):
+ * wid-browse.el (widget-browse-action, widget-browse-widget)
+ (widget-browse-widgets, widget-browse-sexp):
+ * widget.el (define-widget-keywords):
+ * xt-mouse.el (xterm-mouse-translate, turn-off-xterm-mouse-tracking):
+ Mark unused parameters.
+
+ * align.el (align-adjust-col-for-rule): Mark unused parameter.
+ (align-areas): Remove unused variable `look'.
+ (align-region): Remove unused variables `real-end' and `pos-list'.
+
+ * apropos.el (apropos-score-doc): Remove unused variable `i'.
+
+ * bindings.el (mode-line-modified, mode-line-remote):
+ Mark unused parameters.
+ (mode-line-mule-info): Mark unused parameter; don't quote `lambda'.
+
+ * buff-menu.el (Buffer-menu-revert-function): Mark unused parameters.
+ (Buffer-menu-mode): Mark unused parameter; don't quote `lambda'.
+
+ * comint.el (comint-history-isearch-pop-state)
+ (comint-postoutput-scroll-to-bottom, comint-truncate-buffer)
+ (comint-strip-ctrl-m, comint-read-noecho): Mark unused parameters.
+ (comint-substitute-in-file-name): Doc fix.
+
+ * completion.el (cmpl-statistics-block): Mark unused parameter.
+ (add-completions-from-tags-table, add-completions-from-lisp-buffer)
+ (save-completions-to-file, load-completions-from-file):
+ Remove unused local variable `e'.
+
+ * composite.el (compose-chars): Remove unused variable `len'.
+ (lgstring-insert-glyph): Remove unused variable `g'.
+ (compose-glyph-string): Remove unused variables `ascent',
+ `descent', `lbearing' and `rbearing'.
+ (compose-glyph-string-relative): Remove unused variables
+ `lbearing', `rbearing' and `wadjust'.
+ (compose-gstring-for-graphic): Remove unused variables `header',
+ `wadjust', `xoff' and `yoff'. Use `let', not `let*'.
+ (compose-gstring-for-terminal): Remove unused variables `header'
+ and `nchars'. Use `let', not `let*'.
+
+ * cus-edit.el (Custom-set, Custom-save, custom-reset)
+ (Custom-reset-current, Custom-reset-saved, Custom-reset-standard)
+ (Custom-buffer-done, custom-buffer-create-internal)
+ (custom-browse-visibility-action, custom-browse-group-tag-action)
+ (custom-browse-variable-tag-action, custom-browse-face-tag-action)
+ (widget-magic-mouse-down-action, custom-toggle-parent)
+ (custom-add-parent-links, custom-toggle-hide-variable)
+ (custom-face-edit-value-visibility-action, custom-face-edit-fix-value)
+ (custom-toggle-hide-face, face, hook, custom-group-link-action)
+ (custom-face-menu-create, custom-variable-menu-create, get)
+ (custom-group-menu-create, Custom-no-edit): Mark unused parameters.
+ (custom-reset-standard-save-and-update): Remove unused variable `value'.
+ (customize-apropos): Remove unused variable `tests'.
+ (custom-group-value-create): Remove unused variable `hidden-p'.
+ (sort-fold-case): Declare.
+
+ * cus-theme.el (custom-reset-standard-faces-list)
+ (custom-reset-standard-variables-list): Declare.
+ (customize-create-theme, custom-theme-revert, custom-theme-write)
+ (custom-theme-choose-mode, customize-themes, custom-theme-save):
+ Mark unused parameters.
+
+ * dabbrev.el (dabbrev-completion): Remove unused variable `init'.
+
+ * delim-col.el (delimit-columns-max): Move defvar before first use.
+
+ * descr-text.el (describe-char-categories): Don't quote `lambda'.
+ (describe-char): Don't quote `lambda'. Mark unused parameter.
+
+ * desktop.el (desktop-save-buffer-p): Mark unused parameter.
+ (auto-insert): Declare.
+ (desktop-restore-file-buffer): Rename desktop-* parameters;
+ mark unused ones.
+ (desktop-create-buffer): Rename desktop-* parameters and bind them.
+ (desktop-buffer): Rename desktop-* parameters.
+
+ * dframe.el (x-sensitive-text-pointer-shape, x-pointer-shape): Declare.
+ (dframe-reposition-frame-xemacs, dframe-help-echo)
+ (dframe-hack-buffer-menu, dframe-set-timer, dframe-set-timer-internal):
+ Mark unused parameters.
+
+ * dired-aux.el (backup-extract-version-start, overwrite-query)
+ (overwrite-backup-query, rename-regexp-query)
+ (rename-non-directory-query): Declare.
+ (dired-shell-stuff-it, dired-do-create-files): Mark unused parameters.
+ (dired-add-entry): Remove unused variable `orig-file-name'.
+ (dired-copy-file-recursive): Remove unused variable `dirfailed'.
+ Use parameter PRESERVE-TIME instead of accessing dynamic variable
+ `dired-copy-preserve-time' directly.
+ (dired-do-create-files-regexp): Remove unused variable `fn-count'.
+ (dired-insert-subdir-newpos): Rename unused variable `pos'.
+
+ * dired-x.el (dired-omit-size-limit): Move defcustom before first use.
+ (dired-virtual-revert, dired-make-relative-symlink):
+ Mark unused parameters.
+ (manual-program): Declare.
+ (dired-x-hands-off-my-keys): Rename parameters of lambda expression.
+ (inode, s, mode, nlink, uid, gid, size, time, name, sym): Declare them,
+ wrapped in `with-no-warnings' to avoid replacing one warning by another.
+
+ * dirtrack.el (dirtrack): Remove unused variable `multi-line'.
+
+ * dos-fns.el (dos-8+3-filename): Remove unused variable `i'.
+
+ * echistory.el (electric-history-in-progress, Helper-return-blurb):
+ Declare.
+
+ * edmacro.el (edmacro-finish-edit): Remove unused variable `kmacro'.
+
+ * electric.el (Electric-command-loop): Rename parameter
+ INHIBIT-QUIT to INHIBIT-QUITTING and bind `inhibit-quit'.
+
+ * expand.el (expand-in-literal): Remove unused variable `here'.
+
+ * facemenu.el (facemenu-add-new-color):
+ Remove unused variable `docstring'.
+
+ * faces.el (face-id, make-face-bold, make-face-unbold, make-face-italic)
+ (make-face-unitalic, make-face-bold-italic): Mark unused parameters.
+ (face-attr-construct): Mark unused parameter. Doc fix.
+ (read-color): Remove unused variable `hex-string'.
+
+ * files.el (parse-colon-path): Rename argument CD-PATH to SEARCH-PATH.
+ (locate-dominating-file): Remove unused vars `prev-file' and `user'.
+ (remote-file-name-inhibit-cache, revert-buffer): Clean up docstrings.
+ (display-buffer-other-frame): Remove unused variable `old-window'.
+ (kill-buffer-hook): Declare.
+ (insert-file-contents-literally, set-auto-mode, risky-local-variable-p):
+ Mark unused parameters.
+ (after-find-file): Pass 1 to `auto-save-mode', not t.
+
+ * files-x.el (auto-insert): Declare.
+ (modify-file-local-variable-prop-line): Remove unused variable `val'.
+
+ * find-lisp.el (find-lisp-find-dired-internal): Remove unused
+ variable `buf'. Mark unused parameter.
+ (find-lisp-insert-directory): Mark unused parameter.
+
+ * format.el (format-decode-run-method): Mark unused parameter; doc fix.
+ (format-encode-region): Remove unused variables `cur-buf' and `result'.
+ (format-common-tail): Remove, unused.
+ (format-deannotate-region): Remove unused variable `loc'.
+ (format-annotate-region): Remove unused variable `p'.
+ (format-annotate-single-property-change): Remove unused variables
+ `default' and `tail'.
+
+ * forms.el (read-file-filter): Declare.
+ (forms--iif-hook, forms--revert-buffer): Mark unused parameters.
+
+ * frame.el (frame-creation-function-alist): Mark unused parameter.
+ (frame-geom-spec-cons): Pass FRAME to `frame-geom-value-cons'.
+
+ * hilit-chg.el (hilit-chg-cust-fix-changes-face-list, hilit-chg-clear):
+ Remove unused parameters.
+ (hilit-chg-set-face-on-change): Remove unused variable `beg-decr'.
+ (highlight-compare-with-file): Remove unused variable `buf-b-read-only'.
+
+ * htmlfontify.el (hfy-default-footer, hfy-decor, hfy-invisible)
+ (hfy-parse-tags-buffer, hfy-prepare-index-i, hfy-prepare-index)
+ (hfy-prepare-tag-map): Mark unused parameters.
+ (htmlfontify-buffer): Use `called-interactively-p'.
+
+ * ibuf-ext.el (ibuffer-do-kill-lines, ibuffer-jump-to-buffer)
+ (ibuffer-copy-filename-as-kill, ibuffer-mark-on-buffer)
+ (ibuffer-do-occur): Mark unused parameters.
+ (ibuffer-forward-next-marked): Remove unused variable `curmark'.
+ (ibuffer-diff-buffer-with-file-1): Remove unused variable `proc'.
+
+ * ibuffer.el: Don't quote `lambda'.
+ (ibuffer-count-marked-lines, ibuffer-count-deletion-lines)
+ (ibuffer-unmark-all, ibuffer-toggle-marks, ibuffer-redisplay-engine):
+ Mark unused parameters.
+
+ * ido.el (ido-mode, ido-wide-find-dir-or-delete-dir)
+ (ido-completing-read): Mark unused parameters.
+ (ido-copy-current-word): Mark unused parameters;
+ remove unused variable `name'.
+ (ido-sort-merged-list): Remove unused parameter `dirs'.
+
+ * ielm.el (ielm-input-sender): Mark unused parameter.
+ (ielm-string, ielm-form, ielm-pos, ielm-result, ielm-error-type)
+ (ielm-output, ielm-wbuf, ielm-pmark): Declare.
+ (ielm-eval-input): Rename argument IELM-STRING to INPUT-STRING to keep
+ `ielm-string' as a dynamic variable accessible from the IELM prompt.
+ Bind `ielm-string' to INPUT-STRING. Remove unused variable `err'.
+
+ * image-dired.el (image-dired-display-thumbs): Remove unused
+ variables `curr-file' and `count'.
+ (image-dired-remove-tag): Remove unused variable `start'.
+ (image-dired-tag-files, image-dired-create-thumbs): Remove unused
+ variable `curr-file'
+ (image-dired-rotate-original): Remove unused variable `temp-file'.
+ (image-dired-mouse-select-thumbnail, image-dired-mouse-toggle-mark):
+ Remove unused variable `file'.
+ (image-dired-gallery-generate): Remove unused variable `curr'.
+ (image-dired-dired-edit-comment-and-tags): Mark unused parameters.
+
+ * indent.el (tab-to-tab-stop): Remove unused variable `opoint'.
+
+ * info-xref.el (info-xref-goto-node-p): Remove unused variable `err'.
+
+ * informat.el (texinfo-command-start, texinfo-command-end): Declare.
+
+ * isearch.el (minibuffer-history-symbol): Declare.
+ (isearch-edit-string): Remove unused variable `err'.
+ (isearch-message-prefix, isearch-message-suffix):
+ Mark unused parameters.
+
+ * ls-lisp.el (ls-lisp-insert-directory): Remove unused variable `fil'.
+
+ * macros.el (insert-kbd-macro): Remove unused variable `mods'.
+
+ * makesum.el (double-column): Remove unused variable `cnt'.
+
+ * misearch.el (multi-isearch-pop-state): Mark unused parameter.
+ (ido-ignore-item-temp-list): Declare.
+
+ * mouse-drag.el (mouse-drag-throw): Remove unused variables
+ `mouse-delta', `window-last-row', `mouse-col-delta', `window-last-col',
+ `adjusted-mouse-col-delta' and `adjusted-mouse-delta'.
+ (mouse-drag-drag): Remove unused variables `mouse-delta' and
+ `mouse-col-delta'.
+
+ * mouse-sel.el (mouse-extend-internal):
+ Remove unused variable `orig-window-frame'.
+
+ * pcomplete.el (pcomplete-args, pcomplete-begins, pcomplete-last)
+ (pcomplete-index, pcomplete-stub, pcomplete-seen, pcomplete-norm-func):
+ Move declarations before first use.
+ (pcomplete-opt): Mark unused parameters; doc fix.
+
+ * proced.el (proced-revert): Mark unused parameter.
+ (proced-send-signal): Remove unused variable `err'.
+
+ * ps-print.el (ps-print-preprint-region, ps-print-preprint):
+ Rename parameter PREFIX-ARG to ARG.
+ (ps-basic-plot-string, ps-basic-plot-whitespace):
+ Mark unused parameters.
+
+ * replace.el (replace-count): Define.
+ (occur-revert-function): Mark unused parameters.
+ (ido-ignore-item-temp-list, isearch-error, isearch-forward)
+ (isearch-case-fold-search, isearch-string): Declare.
+ (occur-engine): Rename parameter CASE-FOLD-SEARCH to CASE-FOLD and
+ bind `case-fold-search'. Remove unused variables `beg' and `end',
+ and simplify.
+ (replace-eval-replacement): Rename parameter REPLACE-COUNT to
+ COUNT and bind `replace-count'.
+ (replace-loop-through-replacements): Rename parameter REPLACE-COUNT
+ to COUNT.
+
+ * savehist.el (print-readably, print-string-length): Declare.
+
+ * shadowfile.el (shadow-expand-cluster-in-file-name):
+ Remove unused variable `cluster'.
+ (shadow-copy-file): Remove unused variable `i'.
+ (shadow-noquery, shadow-clusters, shadow-site-cluster)
+ (shadow-parse-fullname, shadow-parse-name, shadow-define-cluster)
+ (shadow-define-literal-group, shadow-define-regexp-group)
+ (shadow-make-group, shadow-shadows-of): Clean up docstrings.
+
+ * shell.el (shell-filter-ctrl-a-ctrl-b): Mark unused parameter.
+ (shell): Use `called-interactively-p'.
+ (shell-directory-tracker): Remove unused variable `chdir-failure'.
+
+ * simple.el (compilation-context-lines, comint-file-name-quote-list)
+ (comint-file-name-chars, comint-delimiter-argument-list): Declare.
+ (delete-backward-char): Remove unused variable `ocol'.
+ (minibuffer-avoid-prompt, minibuffer-history-isearch-pop-state)
+ (line-move-1, event-apply-alt-modifier, event-apply-super-modifier)
+ (event-apply-hyper-modifier, event-apply-shift-modifier)
+ (event-apply-control-modifier, event-apply-meta-modifier):
+ Mark unused parameters.
+ (undo-make-selective-list): Remove duplicate variable `undo-elt'.
+ (normal-erase-is-backspace-mode): Remove unused variable `old-state'.
+
+ * speedbar.el (speedbar-ignored-directory-expressions)
+ (speedbar-supported-extension-expressions, speedbar-directory-buttons)
+ (speedbar-find-file, speedbar-dir-follow)
+ (speedbar-directory-buttons-follow, speedbar-tag-find)
+ (speedbar-buffer-buttons, speedbar-buffer-buttons-temp)
+ (speedbar-buffers-line-directory, speedbar-buffer-click):
+ Mark unused parameters.
+ (speedbar-tag-file): Remove unused variable `mode'.
+ (speedbar-buffers-tail-notes): Remove unused variable `mod'; simplify.
+
+ * strokes.el (strokes-decode-buffer): Remove unused variable `ext'.
+
+ * talk.el (talk): Remove unused variable `display'.
+
+ * tar-mode.el (tar-subfile-save-buffer): Remove unused variable `name'.
+ (tar-write-region-annotate): Mark unused parameter.
+
+ * time.el (now, time, load, mail, 24-hours, hour, 12-hours, am-pm)
+ (minutes, seconds, time-zone, day, year, monthname, month, dayname):
+ Declare them, wrapped in `with-no-warnings' to avoid replacing one
+ warning by another.
+
+ * time-stamp.el (time-stamp-string-preprocess):
+ Remove unused variable `require-padding'.
+
+ * tree-widget.el (widget-glyph-enable): Declare.
+ (tree-widget-action): Mark unused parameter.
+
+ * w32-fns.el (x-get-selection): Mark unused parameter.
+ (autoload-make-program, generated-autoload-file): Declare.
+
+ * wdired.el (wdired-revert): Mark unused parameters.
+ (wdired-xcase-word): Remove unused variable `err'.
+
+ * whitespace.el (whitespace-buffer-changed): Mark unused parameters.
+ (whitespace-help-scroll): Remove unused variable `data-help'.
+
+ * wid-edit.el (widget-mouse-help, widget-overlay-inactive)
+ (widget-image-insert, widget-after-change, default)
+ (widget-default-format-handler, widget-default-notify)
+ (widget-default-prompt-value, widget-info-link-action)
+ (widget-url-link-action, widget-function-link-action)
+ (widget-variable-link-action, widget-file-link-action)
+ (widget-emacs-library-link-action, widget-emacs-commentary-link-action)
+ (widget-field-prompt-internal, widget-field-action, widget-field-match)
+ (widget-choice-mouse-down-action, toggle, widget-radio-button-notify)
+ (widget-insert-button-action, widget-delete-button-action, visibility)
+ (widget-documentation-link-action, widget-documentation-string-action)
+ (widget-const-prompt-value, widget-regexp-match, symbol)
+ (widget-coding-system-prompt-value)
+ (widget-key-sequence-value-to-external, sexp)
+ (widget-sexp-value-to-internal, character, vector, cons)
+ (widget-choice-prompt-value, widget-boolean-prompt-value)
+ (widget-color--choose-action): Mark unused parameters.
+ (widget-item-match-inline, widget-choice-match-inline)
+ (widget-checklist-match, widget-checklist-match-inline)
+ (widget-group-match): Rename parameter VALUES to VALS.
+ (widget-field-value-set): Remove unused variable `size'.
+ (widget-color-action): Remove unused variables `value' and `start'.
+
+ * windmove.el (windmove-wrap-loc-for-movement): Remove unused
+ variable `dir'. Doc fix.
+ (windmove-find-other-window): Don't pass it.
+
+ * window.el (count-windows): Mark unused parameter.
+ (bw-adjust-window): Remove unused variable `err'.
+
+ * woman.el (woman-file-name): Remove unused variable `default'.
+ (woman-expand-directory-path): Rename parameters WOMAN-MANPATH and
+ WOMAN-PATH to PATH-DIRS and PATH-REGEXPS, respectively.
+ (global-font-lock-mode): Declare.
+ (woman-decode-region): Mark unused parameter.
+ (woman-get-tab-stop): Rename parameter TAB-STOP-LIST to TAB-STOPS.
+
+ * x-dnd.el (x-dnd-default-test-function, x-dnd-handle-old-kde)
+ (x-dnd-handle-xdnd, x-dnd-handle-motif): Mark unused parameters.
+ (x-dnd-handle-moz-url): Remove unused variable `title'.
+ (x-dnd-handle-xdnd): Remove unused variables `x', `y' and `ret-action'.
+
+ * xml.el (xml-parse-tag, xml-parse-attlist):
+ Remove unused variable `pos'.
+
+2011-04-19 Glenn Morris <rgm@gnu.org>
+
+ * calendar/cal-tex.el (cal-tex-list-holidays, cal-tex-cursor-month)
+ (cal-tex-cursor-week, cal-tex-cursor-week2, cal-tex-cursor-week-iso)
+ (cal-tex-cursor-filofax-2week, cal-tex-cursor-filofax-week)
+ (cal-tex-cursor-filofax-daily, cal-tex-mini-calendar)
+ * calendar/cal-html.el (cal-html-insert-minical):
+ * calendar/diary-lib.el (diary-list-entries-1, diary-list-entries)
+ (calendar-mark-date-pattern):
+ Prefix "unused" locals.
+
+ * calendar/cal-dst.el (dst-adjust-time): Remove never-implemented
+ optional argument `style'.
+
+ * calendar/appt.el (appt-make-list):
+ * calendar/cal-china.el (calendar-chinese-date-string):
+ * calendar/cal-hebrew.el (calendar-hebrew-list-yahrzeits)
+ (diary-hebrew-yahrzeit):
+ * calendar/cal-tex.el (cal-tex-last-blank-p, cal-tex-cursor-week2):
+ * calendar/calendar.el (calendar-generate-window):
+ * calendar/time-date.el (time-to-days):
+ Remove unused local variables.
+
+2011-04-18 Chong Yidong <cyd@stupidchicken.com>
+
+ * emacs-lisp/tabulated-list.el (tabulated-list-mode): Use a custom
+ glyphless-char-display table.
+ (tabulated-list-glyphless-char-display): New var.
+
+2011-04-18 Sam Steingold <sds@gnu.org>
+
+ * vc/add-log.el (change-log-font-lock-keywords): Add "Thanks to"
+ to acknowledgments.
+
+2011-04-17 Glenn Morris <rgm@gnu.org>
+
+ * calendar/diary-lib.el (diary-sexp-entry):
+ * calendar/holidays.el (holiday-sexp):
+ Set debug-on-error rather than the removed stack-trace-on-error.
+
+2011-04-16 Glenn Morris <rgm@gnu.org>
+
+ * progmodes/f90.el: Use lexical-binding.
+ (f90-get-correct-indent): Remove unnecessary local variable `cont'.
+
+2011-04-15 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * mail/sendmail.el (mail-mode-map): Use completion-at-point.
+ (mail-mode): Setup mailalias completion here instead.
+ * mail/mailalias.el: Use lexical-binding.
+ (pattern, mailalias-done): Declare dynamic.
+ (mail-completion-at-point-function): New function, from mail-complete.
+ (mail-complete): Use it.
+ (mail-completion-expand): New function.
+ (mail-get-names): Use it.
+ (mail-directory, mail-directory-process, mail-directory-stream):
+ Don't use `pattern' for lexically bound arg.
+
+ * emacs-lisp/lisp-mode.el (eval-defun-2): Use eval-sexp-add-defvars.
+
+ * htmlfontify.el (hfy-etags-cmd): Remove inoperant eval-and-compile.
+ (hfy-e2x-etags-cmd, hfy-etags-cmd-alist-default)
+ (hfy-etags-cmd-alist): Don't eval-and-compile any more.
+
+ * emacs-lisp/bytecomp.el (byte-temp-output-buffer-show)
+ (byte-save-window-excursion, byte-temp-output-buffer-setup)
+ (byte-interactive-p): Define them again, for use when inlining
+ old code.
- * net/tramp-cache.el (tramp-flush-connection-property): Add trace
- message.
+2011-04-15 Juanma Barranquero <lekktu@gmail.com>
- * net/tramp-smb.el (tramp-smb-errors): Add error messages.
- (tramp-smb-file-name-handler-alist): Add handler for
- `copy-directory', `expand-file-name', `set-file-modes'.
- (tramp-smb-handle-copy-directory)
- (tramp-smb-handle-expand-file-name)
- (tramp-smb-handle-set-file-modes): New defuns.
- (tramp-smb-handle-copy-file): Handle KEEP-DATE.
- (tramp-smb-handle-file-attributes): Simplify check for retrieving
- entry.
- (tramp-smb-handle-insert-directory): Don't flush the cache.
- (tramp-smb-maybe-open-connection): Check for samba client and
- server versions.
+ * loadup.el: Use `string-to-number', not `string-to-int'.
-2009-10-07 Eli Zaretskii <eliz@gnu.org>
+2011-04-15 Stefan Monnier <monnier@iro.umontreal.ca>
- * emacs-lisp/autoload.el (batch-update-autoloads): Fix last change
- to not error out of search for "^lisp=" fails.
+ * progmodes/gud.el (gud-gdb): Use completion-at-point instead of
+ gud-gdb-complete-command.
+ (gud-gdb-completions): New function, from gud-gdb-complete-command.
+ (gud-gdb-completion-at-point): New function.
+ (gud-gdb-completions): Remove.
-2009-10-07 Juanma Barranquero <lekktu@gmail.com>
+2011-04-14 Michael Albinus <michael.albinus@gmx.de>
- * makefile.w32-in (WINS_UPDATES): New macro.
- (custom-deps, finder-data, autoloads): Use it.
+ * net/tramp-sh.el (tramp-sh-handle-file-attributes): Handle the case
+ when the scripts fail. Use `tramp-do-file-attributes-with-ls' then.
+ (tramp-do-copy-or-rename-file-out-of-band): Do not check any longer
+ whether `executable-find' is bound.
-2009-10-07 Glenn Morris <rgm@gnu.org>
+ * net/tramp-smb.el (tramp-smb-handle-copy-file): Fix docstring.
- * Makefile.in (autoloads): Revert previous change.
- * emacs-lisp/autoload.el (batch-update-autoloads): Rather than having
- the list of preloaded files passed on the command-line, get
- it from src/Makefile.
+2011-04-14 Stefan Monnier <monnier@iro.umontreal.ca>
- * calendar/calendar.el (calendar-basic-setup): In the wide frame case,
- show the original buffer rather than a random one.
+ * minibuffer.el (completion-in-region-mode-predicate)
+ (completion-in-region-mode--predicate): New vars.
+ (completion-in-region, completion-in-region--postch)
+ (completion-in-region-mode): Use them.
+ (completion--capf-wrapper): Also return the hook function.
+ (completion-at-point, completion-help-at-point):
+ Adjust and provide a predicate.
-2009-10-07 Markus Rost <rost@math.uni-bielefeld.de>
+ Preserve arg names for advice of subr and lexical functions (bug#8457).
+ * help-fns.el (help-function-arglist): Consolidate the subr and
+ new-byte-code cases. Add argument `preserve-names' to extract names
+ from the docstring when needed.
+ * emacs-lisp/advice.el (ad-define-subr-args, ad-undefine-subr-args)
+ (ad-subr-args-defined-p, ad-get-subr-args, ad-subr-arglist): Remove.
+ (ad-arglist): Use help-function-arglist's new arg.
+ (ad-definition-type): Use cond.
- * help.el (describe-no-warranty): Place point in a slightly better
- position in the GPLv3 text.
+2011-04-13 Juanma Barranquero <lekktu@gmail.com>
-2009-10-06 Sam Steingold <sds@gnu.org>
+ * autorevert.el (auto-revert-handler):
+ Bind `remote-file-name-inhibit-cache', not `tramp-cache-inhibit-cache',
+ which was removed in 2010-10-02T13:21:43Z!michael.albinus@gmx.de.
+ Don't quote lambda.
- * net/tramp-compat.el (tramp-compat-process-running-p): Check that
- the comm attribute is present before calling regexp-quote.
+ * image-mode.el (image-transform-set-scale):
+ Fix change in 2011-04-09T20:28:01Z!cyd@stupidchicken.com.
-2009-10-06 Juanma Barranquero <lekktu@gmail.com>
+2011-04-12 Lars Magne Ingebrigtsen <larsi@gnus.org>
- * play/animate.el (animate-string): For good effect, make sure
- `indent-tabs-mode' and `show-trailing-whitespace' are nil.
+ * net/network-stream.el (network-stream-open-starttls): Only do
+ opportunistic STARTTLS upgrades if we have built-in gnutls support.
+ Upgrades via gnutls-cli are too slow to be done opportunistically.
- * play/animate.el (animate-sequence, animate-birthday-present):
- * misc.el (butterfly): Don't set `indent-tabs-mode'.
+2011-04-12 Juanma Barranquero <lekktu@gmail.com>
-2009-10-06 Glenn Morris <rgm@gnu.org>
+ * dframe.el (dframe-current-frame): Remove spurious quote.
- * emacs-lisp/byte-run.el (define-obsolete-face-alias): Doc fix.
+2011-04-12 Glenn Morris <rgm@gnu.org>
- * emacs-lisp/autoload.el (autoload-excludes): New variable.
- (autoload-generate-file-autoloads): Skip files in autoload-excludes.
- (batch-update-autoloads): Process a string value of autoload-excludes,
- set during the build process.
- * Makefile.in (autoloads): Skip preloaded files. (Bug#4446)
+ * calendar/cal-tex.el (cal-tex-end-document):
+ Try to automatically use latin1 input if needed.
- * net/tramp.el (tramp-handle-start-file-process): Move tramp-error call
- inside with-parsed... macro so that `v' is defined.
+ * calendar/cal-hebrew.el (diary-hebrew-rosh-hodesh):
+ Don't try to cons a mark onto an empty element.
- * progmodes/f90.el (f90-end-of-block, f90-beginning-of-block):
- * progmodes/fortran.el (fortran-end-of-block)
- (fortran-beginning-of-block):
- Also push mark in the macro case.
+2011-04-11 Leo Liu <sdl.web@gmail.com>
- * emerge.el (emerge-show-file-name):
- * calc/calc.el (calc-quit):
- * calc/calc-misc.el (calc-big-or-small):
- * calc/calc-graph.el (calc-graph-view):
- * calc/calc-ext.el (calc-reset):
- * calendar/calendar.el (calendar-basic-setup):
- Use window-full-height-p.
+ * ido.el (ido-buffer-internal): Allow method 'kill for virtual
+ buffers.
+ (ido-kill-buffer-at-head): Support killing virtual buffers.
- * mail/rmailedit.el (rmail-cease-edit): If there is a Content-Type
- header we don't understand, don't insert another. (Bug#4624)
- If changing mime charset, insert the new one in the right place.
+2011-04-10 Chong Yidong <cyd@stupidchicken.com>
-2009-10-06 Matthew Junker <matthew.junker@sbcglobal.net> (tiny change)
+ * minibuffer.el (completion-show-inline-help): New var.
+ (completion--do-completion, minibuffer-complete)
+ (minibuffer-force-complete, minibuffer-complete-word):
+ Inhibit minibuffer messages if completion-show-inline-help is nil.
- * calendar/cal-tex.el (cal-tex-cursor-month-landscape)
- (cal-tex-cursor-month): Correctly increment the end date for diary and
- holiday listing. (Bug#4626)
+ * icomplete.el (icomplete-mode): Bind completion-show-inline-help
+ to avoid interference from inline help (Bug#5849).
-2009-10-05 Stefan Monnier <monnier@iro.umontreal.ca>
+2011-04-10 Leo Liu <sdl.web@gmail.com>
- * help-fns.el (describe-function-1): Don't burp if the function is not
- a symbol.
+ * emacs-lisp/tabulated-list.el (tabulated-list-print-entry):
+ Fix typo.
-2009-10-05 Juanma Barranquero <lekktu@gmail.com>
+2011-04-09 Chong Yidong <cyd@stupidchicken.com>
- * emacs-lisp/chart.el (chart-face-pixmap-list, chart-new-buffer, chart)
- (chart-axis-range, chart-axis-names, chart-sequece, chart-bar)
- (chart-draw, chart-axis-draw, chart-sort, chart-sort-matchlist)
- (chart-draw-line, chart-bar-quickie): Fix typos in docstrings.
+ * image-mode.el (image-toggle-display-image): Signal an error if
+ not in Image mode.
+ (image-transform-mode, image-transform-resize)
+ (image-transform-set-rotation): Doc fix.
+ (image-transform-set-resize): Delete.
+ (image-transform-set-scale, image-transform-fit-to-height)
+ (image-transform-fit-to-width): Handle image-toggle-display-image
+ and image-transform-resize directly.
- * emacs-lisp/eieio.el (generic-p, eieiomt-next, eieio-generic-form)
- (eieio-default-superclass): Reflow docstrings.
- (this, class-option-assoc, defclass, eieio-class-un-autoload)
- (eieio-unbind-method-implementations, defmethod)
- (eieio-validate-slot-value, eieio-validate-class-slot-value)
- (oref-default, eieio-oref-default, eieio-oset, eieio-oset-default)
- (with-slots, eieio-add-new-slot, object-assoc, object-remove-from-list)
- (eieio-slot-originating-class-p, eieio-slot-name-index)
- (eieio-pre-method-execution-hooks, eieio-initarg-to-attribute)
- (constructor, initialize-instance, no-next-method, object-print)
- (object-write, eieio-override-prin1, eieio-edebug-prin1-to-string):
- Fix typos in docstrings.
- (eieio-defclass, eieio-perform-slot-validation-for-default, defgeneric)
- (child-of-class-p, object-slots, slot-boundp, slot-exists-p)
- (next-method-p): Doc fixes.
- (eieio-add-new-slot, call-next-method, eieiomt-add, change-class):
- Fix typos in error messages.
- (eieio-defmethod): Fix typo in description of generic method.
-
- * emacs-lisp/eieio-base.el (eieio-instance-inheritor, slot-unbound)
- (eieio-persistent-save-interactive, slot-missing):
- Fix typos in docstrings.
- (eieio-instance-inheritor-slot-boundp): Doc fix.
+2011-04-08 Sho Nakatani <lay.sakura@gmail.com>
- * emacs-lisp/eieio-comp.el (byte-compile-file-form-defmethod)
- (byte-compile-defmethod-param-convert): Fix typos in docstrings.
+ * doc-view.el (doc-view-fit-width-to-window)
+ (doc-view-fit-height-to-window, doc-view-fit-page-to-window):
+ New functions for fitting the shown image to the Emacs window size.
+ (doc-view-mode-map): Add bindings for the new functions.
- * emacs-lisp/eieio-custom.el (eieio-done-customizing)
- (eieio-custom-object-apply-reset):
- Fix typos in docstrings and error messages.
+2011-04-08 Juanma Barranquero <lekktu@gmail.com>
- * emacs-lisp/eieio-datadebug.el (data-debug-show):
+ * vc-annotate.el (vc-annotate-show-log-revision-at-line):
Fix typo in docstring.
- * emacs-lisp/eieio-opt.el (top): Fix typo in error message.
- (eieio-browse-tree): Doc fix.
- (eieio-all-generic-functions, eieio-class-speedbar): Reflow docstrings.
- (eieio-help-mode-augmentation-maybee, eieio-class-speedbar-make-map):
- Fix typos in docstrings.
-
- * emacs-lisp/eieio-speedbar.el (eieio-speedbar-file-button): Doc fix.
- (eieio-speedbar-key-map, eieio-speedbar-create-engine)
- (eieio-speedbar-buttons, eieio-speedbar, eieio-speedbar-object-children)
- (eieio-speedbar-make-tag-line, eieio-speedbar-object-expand):
- Reflow docstrings.
-
-2009-10-05 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc-hg.el (log-view-vc-backend): Declare for compiler.
- (vc-hg-outgoing-mode, vc-hg-incoming-mode):
- Set log-view-vc-backend so that diff can work.
-
- * log-view.el (log-view-diff): Use vc-diff-internal instead of
- vc-version-diff.
- (vc-diff-internal): Autoload this instead of vc-version-diff.
-
-2009-10-05 Eli Zaretskii <eliz@gnu.org>
-
- * simple.el (eval-expression): Doc fix.
-
- * progmodes/cwarn.el (cwarn-mode): Doc fix.
-
-2009-10-05 Michael Albinus <michael.albinus@gmx.de>
-
- * files.el (directory-files-no-dot-files-regexp): New defconst.
- (delete-directory): Use it.
- (copy-directory): Use it. Remove parameter PRESERVE-UID-GID.
-
- * net/tramp.el (tramp-verbose): Fix docstring.
- (tramp-methods): Add recursive option to `tramp-copy-args'.
- Add `tramp-copy-recursive'. Valid for "rcp", "scp", "scp1", "scp2",
- "scp1_old", "scp2_old", "rsync", "rsyncc".
- (tramp-default-method): Check also for `auth-source-user-or-password'.
- (tramp-file-name-handler-alist, tramp-file-name-for-operation):
- Add handler for `copy-directory'.
- (tramp-handle-copy-directory): New defun.
- (tramp-do-copy-or-rename-file-out-of-band): Handle directory case.
- (tramp-handle-start-file-process): Raise an error when PROGRAM is nil.
- Optimize sent command.
-
-2009-10-05 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * calendar/diary-lib.el (diary-show-all-entries): Re-fit the calendar
- window if necessary.
-
- * calendar/calendar.el (calendar-basic-setup): Don't call
- switch-to-buffer in a dedicated window.
-
-2009-10-05 Karl Fogel <kfogel@red-bean.com>
-
- * bookmark.el (bookmark-handle-bookmark): If bookmark has no file,
- don't do anything related to relocating, just return nil.
- (bookmark-error-no-filename): New error.
- (bookmark-default-handler): Signal `bookmark-error-no-filename' if
- bookmark has no file. Don't even attempt to handle things that
- are not files; the whole point of custom handlers is to keep that
- knowledge elsewhere anyway. Tighten some comments.
- (bookmark-file-or-variation-thereof): Remove now-unused function.
- (bookmark-location): Doc string fix.
- (Bug#4250)
-
-2009-10-04 Karl Fogel <kfogel@red-bean.com>
-
- * bookmark.el (bookmark-handle-bookmark): When relocating a bookmark,
- don't use a file dialog, because they usually don't know how to read
- a directory target from the user. (Bug#4230)
- Also, make sure the prompt can display directories as well as files.
-
-2009-10-04 Karl Fogel <kfogel@red-bean.com>
-
- * bookmark.el (bookmark-set, bookmark-buffer-name):
- Improve doc strings. (Bug#1193)
-
-2009-10-04 Karl Fogel <kfogel@red-bean.com>
-
- * bookmark.el (bookmark-get-bookmark, bookmark-get-bookmark-record)
- (bookmark-set-name, bookmark-prop-get, bookmark-prop-set)
- (bookmark-get-annotation, bookmark-set-annotation)
- (bookmark-get-filename, bookmark-set-filename, bookmark-get-position)
- (bookmark-set-position, bookmark-get-front-context-string)
- (bookmark-set-front-context-string, bookmark-get-rear-context-string)
- (bookmark-set-rear-context-string, bookmark-location, bookmark-jump)
- (bookmark-jump-other-window, bookmark-handle-bookmark)
- (bookmark-relocate, bookmark-insert-location, bookmark-rename)
- (bookmark-insert, bookmark-delete, bookmark-time-to-save-p)
- (bookmark-edit-annotation-mode, bookmark-edit-annotation):
- Improve doc strings to say whether bookmark can be a string or
- a record or both, and make other consistency and clarity fixes.
- (bookmark-get-handler, bookmark--jump-via, bookmark-write-file)
- (bookmark-default-annotation-text, bookmark-yank-word)
- (bookmark-maybe-load-default-file, bookmark-maybe-sort-alist)
- (bookmark-import-new-list, bookmark-maybe-rename)
- (bookmark-bmenu-show-filenames, bookmark-bmenu-hide-filenames)
- (bookmark-bmenu-bookmark): Give these doc strings.
- (bookmark-bmenu-check-position): Give this a doc string, but also
- add a FIXME comment about how the function may be pointless.
- (bookmark-default-handler): Rework doc string and change a
- parameter name, to clarify that this takes a bookmark record
- not a bookmark name.
- (bookmark-set): Change a parameter name to indicate its meaning,
- and improve the doc string a bit.
- (Bug#4188)
-
-2009-10-04 Karl Fogel <kfogel@red-bean.com>
-
- * bookmark.el (bookmark-alist): Document the new `handler' element
- in the param alist.
- (bookmark-make-record-function): Adjust documentation for above.
- (Bug#4193)
-
-2009-10-04 Karl Fogel <kfogel@red-bean.com>
-
- * info.el (Info-bookmark-make-record): Document this function.
- (Info-bookmark-jump): Document with a doc string, not just a comment.
- (Bug#4203)
-
-2009-10-04 Michael Albinus <michael.albinus@gmx.de>
-
- * files.el (copy-directory): New defun.
-
- * dired-aux.el (dired-copy-file-recursive): Use it.
-
-2009-10-04 Juanma Barranquero <lekktu@gmail.com>
-
- * files-x.el (modify-dir-local-variable)
- (copy-dir-locals-to-file-locals-prop-line): Fix typos in
- docstrings.
-
- * recentf.el (recentf-unload-function): New function.
-
-2009-10-04 Glenn Morris <rgm@gnu.org>
-
- * window.el (window-full-height-p): Add doc string.
-
-2009-10-04 Martin Rudalics <rudalics@gmx.at>
-
- * window.el (window-full-height-p): New function. (Bug#4543)
-
-2009-10-03 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc.el: Remove commented out code.
- (vc-derived-from-dir-mode): Remove, unused.
- (vc-version-diff, vc-diff): Consistently pass t to vc-deduce-fileset.
-
-2009-10-03 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp-ftp.el (tramp-ftp-file-name-handler):
- Disable `file-name-handler-alist' when loading 'ange-ftp. Otherwise,
- there could be recursive loading when `default-directory' is a
- remote file name. (Bug#4614)
-
-2009-10-03 Glenn Morris <rgm@gnu.org>
-
- * calendar/calendar.el (calendar-basic-setup): Handle the case where
- the frame is wide.
- (calendar-generate-window): Test for shrinkability rather than width.
-
- * mail/rmail.el (rmail-generate-viewer-buffer): Be more careful about
- reusing existing buffers, in case we happen to visit two files with the
- same basename. (Bug#4593)
-
-2009-10-02 Eli Zaretskii <eliz@gnu.org>
-
- * makefile.w32-in (update-subdirs-CMD): Add cedet to $(WINS_SUBDIR).
- (WINS_CEDET_SUBDIRS): List of subdirectories of cedet.
- (bootstrap-clean-CMD, bootstrap-clean-SH): Remove *.elc files in
- subdirs of cedet as well.
- (AUTOGENEL): Add loaddefs.el files in cedet subdirectories.
-
-2009-10-02 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * emacs-lisp/eldoc.el (eldoc-get-fnsym-args-string):
- Obey advertised-signature-table.
-
- * help-fns.el (help-function-arglist): Don't check
- advertised-signature-table.
- (describe-function-1): Do it here instead so it also applies to subrs.
-
-2009-10-02 Michael Albinus <michael.albinus@gmx.de>
-
- * simple.el (start-file-process): Say in the doc-string, that file
- handlers might not support pty association, if PROGRAM is nil.
-
- * net/ange-ftp.el (ange-ftp-generate-passwd-key): Check, whether
- HOST and USER are strings. They are nil, when there are
- incomplete entries in ~/.netrc, for example.
- (ange-ftp-delete-directory): Implement RECURSIVE case. Change to
- root directory ("device busy" error otherwise).
-
- * net/tramp-smb.el (tramp-smb-handle-make-directory-internal):
- Flush file properties of created directory.
-
-2009-10-02 Eli Zaretskii <eliz@gnu.org>
-
- * makefile.w32-in (WINS_BASIC): Remove cedet.
- (WINS_CEDET): Add cedet.
- (update-subdirs-SH): Use $(WINS_SUBDIR), not $(WINS).
-
-2009-10-02 Kevin Ryde <user42@zip.com.au>
-
- * net/browse-url.el (browse-url): Pass any symbol in
- browse-url-browser-function to `apply', since if you've mistakenly put
- an unbound symbol then the error is clearer. (Bug#4531)
-
-2009-10-02 Juanma Barranquero <lekktu@gmail.com>
-
- * allout.el (allout-init, allout-back-to-current-heading)
- (allout-beginning-of-current-entry, allout-ascend-to-depth)
- (allout-ascend, allout-up-current-level, allout-end-of-level)
- (allout-previous-visible-heading, allout-forward-current-level)
- (allout-backward-current-level, allout-show-children):
- * apropos.el (apropos-describe-plist):
- * bookmark.el (bookmark-maybe-historicize-string, bookmark-bmenu-list):
- * comint.el (comint-strip-ctrl-m, comint-goto-process-mark):
- * completion.el (add-completion, add-permanent-completion):
- * descr-text.el (describe-text-category, describe-char):
- * desktop.el (desktop-lazy-abort):
- * dired-x.el (dired-omit-expunge, dired-x-bind-find-file):
- * dired.el (dired-build-subdir-alist):
- * ediff.el (ediff-version):
- * elide-head.el (elide-head, elide-head-show):
- * emerge.el (emerge-version):
- * env.el (getenv):
- * face-remap.el (variable-pitch-mode):
- * faces.el (describe-face):
- * ffap.el (ffap-next-url, find-file-at-point, ffap-at-mouse)
- (dired-at-point):
- * files.el (find-file-existing, auto-save-mode):
- * font-lock.el (font-lock-fontify-buffer):
- * help-fns.el (describe-function, describe-variable)
- (describe-syntax, describe-categories):
- * help.el (view-lossage, describe-bindings, describe-key)
- (describe-mode):
- * hexl.el (hexl-current-address):
- * hi-lock.el (hi-lock-mode, hi-lock-find-patterns):
- * info.el (Info-goto-emacs-key-command-node):
- * log-edit.el (log-edit-insert-cvs-template)
- (log-edit-insert-cvs-rcstemplate):
- * menu-bar.el (menu-bar-mode):
- * mouse.el (mouse-appearance-menu):
- * newcomment.el (comment-indent-new-line):
- * pgg.el (pgg-save-coding-system, pgg-encrypt-region)
- (pgg-encrypt-symmetric-region, pgg-encrypt-symmetric)
- (pgg-encrypt, pgg-decrypt-region, pgg-decrypt)
- (pgg-sign-region, pgg-sign, pgg-verify-region, pgg-verify):
- * recentf.el (recentf-mode):
- * savehist.el (savehist-mode, savehist-save):
- * shadowfile.el (shadow-copy-files):
- * simple.el (kill-ring-save, next-line, previous-line)
- (normal-erase-is-backspace-mode):
- * strokes.el (strokes-update-window-configuration)
- (strokes-load-user-strokes, strokes-prompt-user-save-strokes)
- (strokes-xpm-for-stroke):
- * time.el (emacs-uptime, emacs-init-time):
- * tutorial.el (tutorial--describe-nonstandard-key)
- (tutorial--detailed-help):
- * type-break.el (type-break-mode)
- (type-break-mode-line-message-mode, type-break-query-mode)
- (type-break-guesstimate-keystroke-threshold):
- * vc.el (vc-version-diff, vc-diff, vc-root-diff):
- * version.el (emacs-version):
- * vt-control.el (vt-keypad-on, vt-keypad-off, vt-numlock):
- * winner.el (winner-mode):
- * calendar/timeclock.el (timeclock-in, timeclock-out)
- (timeclock-status-string, timeclock-change)
- (timeclock-workday-remaining-string)
- (timeclock-workday-elapsed-string)
- (timeclock-when-to-leave-string):
- * calendar/todo-mode.el (todo-add-category):
- * emacs-lisp/advice.el (ad-enable-regexp, ad-disable-regexp):
- * emacs-lisp/autoload.el (update-file-autoloads):
- * emacs-lisp/checkdoc.el (checkdoc-current-buffer)
- (checkdoc-start, checkdoc-continue, checkdoc-rogue-spaces)
- (checkdoc-message-text, checkdoc-defun):
- * emacs-lisp/debug.el (debugger-list-functions):
- * emacs-lisp/easy-mmode.el (easy-mmode-define-navigation):
- * emacs-lisp/eieio-opt.el (eieio-describe-class)
- (eieio-describe-generic):
- * emacs-lisp/lisp-mnt.el (lm-synopsis):
- * emacs-lisp/shadow.el (list-load-path-shadows):
- * emulation/cua-base.el (cua-mode):
- * emulation/edt.el (edt-set-scroll-margins):
- * emulation/tpu-edt.el (tpu-toggle-newline-and-indent)
- (tpu-toggle-regexp, tpu-toggle-search-direction)
- (tpu-toggle-rectangle, tpu-toggle-control-keys):
- * emulation/tpu-extras.el (tpu-set-scroll-margins):
- * emulation/viper-cmd.el (viper-set-searchstyle-toggling-macros)
- (viper-set-parsing-style-toggling-macro)
- (viper-set-emacs-state-searchstyle-macros):
- * emulation/viper.el (viper-set-hooks):
- * eshell/esh-mode.el (eshell-truncate-buffer):
- * international/mule-cmds.el (prefer-coding-system)
- (describe-input-method, describe-language-environment):
- * international/mule-diag.el (list-character-sets)
- (describe-character-set, describe-coding-system)
- (describe-fontset, list-fontsets, list-input-methods):
- * mail/sendmail.el (mail-signature):
- * net/ange-ftp.el (ange-ftp-copy-file):
- * net/browse-url.el (browse-url):
- * net/eudc.el (eudc-set-server, eudc-get-attribute-list):
- * net/quickurl.el (quickurl-add-url):
- * net/rcirc.el (names, topic):
- * net/xesam.el (xesam-mode):
- * play/5x5.el (5x5-new-game):
- * play/yow.el (apropos-zippy):
- * progmodes/ada-mode.el (ada-mode-version):
- * progmodes/f90.el (f90-beginning-of-subprogram, f90-end-of-subprogram)
- (f90-end-of-block)
- (f90-beginning-of-block):
- * progmodes/fortran.el (fortran-end-of-block)
- (fortran-beginning-of-block):
- * progmodes/js.el (js-syntactic-context, js-gc, js-eval):
- * progmodes/python.el (python-describe-symbol, python-shell):
- * term/ns-win.el (ns-print-buffer):
- * textmodes/bibtex.el (bibtex-end-of-entry, bibtex-url):
- * textmodes/flyspell.el (flyspell-mode-on):
- * textmodes/page-ext.el (set-page-delimiter, pages-directory)
- (pages-directory-for-addresses):
- * textmodes/table.el (table-recognize-cell)
- (table-query-dimension, table-generate-source)
- (table-insert-sequence, table--warn-incompatibility):
- * textmodes/tex-mode.el (tex-validate-buffer):
- * textmodes/texinfmt.el (texinfmt-version)
- (texinfo-format-buffer):
- Use `called-interactively-p' instead of `interactive-p'.
-
-2009-10-02 Juanma Barranquero <lekktu@gmail.com>
-
- * image-mode.el (image-toggle-display):
- * emacs-lisp/elp.el (elp-instrument-function):
- * emacs-lisp/advice.el (ad-make-advised-definition):
- * emacs-lisp/easy-mmode.el (define-minor-mode):
- * net/browse-url.el (browse-url-maybe-new-window):
- * progmodes/sh-script.el (sh-learn-buffer-indent):
- Pass new argument 'any to `called-interactively-p'.
-
-2009-10-01 Juanma Barranquero <lekktu@gmail.com>
-
- * 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 from Unicode 5.2.0 data.
-
-2009-10-01 Glenn Morris <rgm@gnu.org>
-
- * Makefile.in (ELCFILES): Regenerate.
-
-2009-10-01 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * subr.el (interactive-p): Mark obsolete.
- (called-interactively-p): Make the optional-ness of `kind' obsolete.
- * emacs-lisp/bytecomp.el (byte-compile-fdefinition): Make it obey
- advertised-signature-table for subroutines as well.
-
- * emacs-lisp/byte-run.el (advertised-signature-table): New var.
- (set-advertised-calling-convention): New function.
- (make-obsolete, define-obsolete-function-alias)
- (make-obsolete-variable, define-obsolete-variable-alias):
- Make the optional-ness of `when' obsolete.
- (define-obsolete-face-alias): Make `when' non-optional.
- * help-fns.el (help-function-arglist):
- * emacs-lisp/bytecomp.el (byte-compile-fdefinition):
- Use advertised-signature-table.
-
-2009-10-01 Michael Albinus <michael.albinus@gmx.de>
-
- * files.el (delete-directory): New defun. The original function
- in fileio.c has been renamed to `delete-directory-internal'.
-
- * dired.el (dired-delete-file): Call `delete-directory' with
- RECURSIVE parameter.
-
- * net/ange-ftp.el (ange-ftp-delete-directory): Add optional
- parameter RECURSIVE. Implementation is missing.
-
- * net/tramp.el (tramp-handle-make-directory): Flush upper
- directory's file properties.
- (tramp-handle-delete-directory): Handle optional parameter RECURSIVE.
- (tramp-handle-dired-recursive-delete-directory): Flush directory
- properties after the remove command only.
-
- * net/tramp-fish.el (tramp-fish-handle-delete-directory):
- Handle optional parameter RECURSIVE.
-
- * net/tramp-gvfs.el (tramp-gvfs-handle-delete-directory):
- Handle optional parameter RECURSIVE.
-
- * net/tramp-smb.el (tramp-smb-errors): Add error message for
- connection timeout.
- (tramp-smb-handle-delete-directory): Handle optional parameter
- RECURSIVE.
-
-2009-10-01 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * emacs-lisp/bytecomp.el (byte-compile-defmacro-declaration): New fun.
- (byte-compile-file-form-defmumble, byte-compile-defmacro): Use it.
- (byte-compile-defmacro): Use backquotes.
-
- * files.el (cd-absolute): Don't abbreviate-file-name (bug#4599).
-
- * vc-dispatcher.el (vc-resynch-window): Don't revert a buffer which
- has no associated file.
- (vc-resynch-buffer): Use vc-dir-buffers.
-
-2009-10-01 Glenn Morris <rgm@gnu.org>
-
- * emacs-lisp/chart.el (chart-zap-chars, chart-bar-quickie)
- (chart-file-count):
- * emacs-lisp/eieio-comp.el (byte-compile-defmethod-param-convert):
- * emacs-lisp/eieio-datadebug.el (data-debug-insert-object-button):
- * emacs-lisp/eieio-opt.el (eieio-describe-class):
- * emacs-lisp/eieio-speedbar.el (eieio-speedbar-create):
- * emacs-lisp/eieio.el (defclass, eieio-defclass-autoload)
- (eieio-copy-parents-into-subclass, make-instance, class-children)
- (eieio-generic-form):
-
- * vc-cvs.el (vc-cvs-parse-entry): Be more careful with the
- match-data. (Bug#4555).
-
- * emacs-lisp/check-declare.el (check-declare-scan): Read the declaration
- rather than parsing it as a regexp. This relaxes the layout
- requirements and makes errors easier to detect.
- (check-declare-verify): Check file is regular.
- (check-declare-directory): Doc fix.
- * subr.el (declare-function): Doc fix.
-
- * ibuffer.el (ibuffer-format-qualifier):
- * isearch.el (hi-lock-regexp-okay):
- * calc/calc.el (math-zerop):
- * mail/uce.el (rmail-msgbeg, rmail-msgend):
- * term/w32-win.el (setup-default-fontset, set-fontset-font):
- Remove unused declarations.
-
-2009-09-30 Glenn Morris <rgm@gnu.org>
-
- * emacs-lisp/authors.el (authors-ignored-files): Add "js2-mode.el".
-
- * emacs-lisp/elint.el (elint-init-form): Report declarations where the
- filename is not a string.
-
-2009-09-29 Chong Yidong <cyd@stupidchicken.com>
-
- * files.el (safe-local-eval-forms): Fix typo.
-
-2009-09-29 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * vc-hooks.el (vc-dir-buffers): New var.
- (vc-state-refresh): New function.
- (vc-state): Use it.
- (vc-after-save): Always ask the backend to recompute the new state.
- Always call vc-dir if necessary, using vc-dir-buffers.
- * vc-dir.el (vc-dir-prepare-status-buffer, vc-dir-resynch-file):
- Use vc-dir-buffers.
- (vc-dir-mode): Use vc-dir-buffers rather than after-save-hook.
- (vc-dir-prepare-status-buffer, vc-dir-update)
- (vc-dir-resync-directory-files, vc-dir-resynch-file, vc-dir-mode):
- Don't call expand-file-name on default-directory.
-
-2009-09-29 Juanma Barranquero <lekktu@gmail.com>
-
- * speedbar.el (speedbar-item-delete):
- * calc/calc-prog.el (calc-kbd-if):
- * language/hanja-util.el (hanja-init-load): Fix typos in messages.
-
- * epa.el (epa-key-list-mode-map):
- * hi-lock.el (hi-lock-menu): Fix typos in menus.
-
- * progmodes/hideshow.el (hs-allow-nesting): Reflow docstring.
- (hs-show-hook): Fix typo in docstring.
-
-2009-09-29 Glenn Morris <rgm@gnu.org>
-
- * emacs-lisp/check-declare.el (check-declare-locate): Remove pointless
- file-name-nondirectory call preventing location of cedet files.
- (check-declare-verify): Use literal search rather than re-search.
- Add basic defmethod and defclass, and define-overloadable-function.
-
- * net/tramp-smb.el (tramp-smb-handle-directory-files-and-attributes):
- Use tramp-compat-file-attributes rather than nonexistent
- tramp-compat-handle-file-attributes.
-
- * Makefile.in (lisptagsfiles4): New.
- (AUTOGENEL): Add cedet loaddefs files.
- (TAGS, TAGS-LISP): Use $lisptagsfiles4.
- (update-elclist, compile-always, backup-compiled-files)
- (bootstrap-clean): Add yet another directory level.
- (update-elclist): Use LC_COLLATE rather than COLLATE.
- (ELCFILES): Update, via `make update-elclist'.
-
-2009-09-29 Juanma Barranquero <lekktu@gmail.com>
-
- * makefile.w32-in (WINS_CEDET, WINS_BASIC, WINS_SUBDIR): New macros.
- (WINS_ALMOST): Set from WINS_BASIC and WINS_CEDET.
- (update-subdirs-CMD): Use WINS_SUBDIR, not WINS_ALMOST.
-
-2009-09-28 Andreas Schwab <schwab@linux-m68k.org>
-
- * Makefile.in (lisptagsfiles3): Define.
- (TAGS, TAGS-LISP): Use it.
- (update-elclist): Add third directory level to look for elc files.
- (compile-always): Likewise.
- (backup-compiled-files): Likewise.
- (bootstrap-clean): Likewise.
- (ELCFILES): Update.
-
-2009-09-28 Chong Yidong <cyd@stupidchicken.com>
-
- * Makefile.in (ELCFILES): Add CEDET files.
-
-2009-09-28 Michael Albinus <michael.albinus@gmx.de>
-
- * Makefile.in (ELCFILES): Add net/tramp-imap.elc.
-
- * net/tramp.el (top): Require tramp-imap.
+2011-04-08 Eli Zaretskii <eliz@gnu.org>
- * net/tramp-smb.el (tramp-smb-handle-directory-files-and-attributes):
- Use `tramp-compat-handle-file-attributes'.
+ * files.el (file-size-human-readable): Produce one digit after
+ decimal, like "ls -lh" does.
-2009-09-28 Teodor Zlatanov <tzz@lifelogs.com>
+ * ls-lisp.el (ls-lisp-format-file-size): Allow for 7 characters in
+ the file size representation.
- * net/tramp-imap.el: New package.
+ * simple.el (list-processes): If async subprocesses are not
+ available, error out with a clear error message.
-2009-09-27 Vinicius Jose Latorre <viniciusjl@ig.com.br>
+2011-04-08 Chong Yidong <cyd@stupidchicken.com>
- * whitespace.el (whitespace-trailing-regexp)
- (whitespace-empty-at-bob-regexp, whitespace-empty-at-eob-regexp):
- Fix doc string.
+ * help.el (help-form-show): New function, to be called from C.
+ Put help-form output in a buffer named differently than *Help*.
-2009-09-27 Chong Yidong <cyd@stupidchicken.com>
+2011-04-08 Eli Zaretskii <eliz@gnu.org>
- * menu-bar.el: Remove menu-bar-ediff-misc-menu from the Tools
- menu.
+ * files.el (file-size-human-readable): New function.
- * ediff-hook.el: Move menu-bar-ediff-misc-menu into
- menu-bar-ediff-menu.
+ * ls-lisp.el (ls-lisp-format-file-size): Use it, instead of
+ computing the representation inline. Don't require `cl'.
- * emacs-lisp/lisp-mode.el: Add doc-string-elt property to
- define-overloadable-function.
+2011-04-08 Glenn Morris <rgm@gnu.org>
- * progmodes/autoconf.el: Provide autoconf as well, so that this
- file can be `require'd.
+ * man.el (Man-page-header-regexp): Solaris < 2.6 no longer supported.
- * emacs-lisp/cl-macs.el (deftype): Add to cl-loaddefs.
+ * net/browse-url.el (browse-url-firefox):
+ Test system-type, not system-configuration.
- * emacs-lisp/autoload.el (generated-autoload-feature)
- (generated-autoload-load-name): New vars.
- (autoload-rubric, autoload-generate-file-autoloads): Use them.
- (make-autoload): Recognize define-overloadable-function and
- defclass forms (for EIEIO).
+ * vc/log-edit.el (log-edit-empty-buffer-p): New function.
+ (log-edit-insert-cvs-template, log-edit-insert-cvs-rcstemplate):
+ Use log-edit-empty-buffer-p. (Bug#7598)
- * Makefile.in (update-subdirs): Exclude cedet directory.
+ * net/rlogin.el (rlogin-process-connection-type): Simplify.
+ (rlogin-mode-map): Initialize in the defvar.
+ (rlogin): Use ignore-errors.
-2009-09-27 Adrian Robert <Adrian.B.Robert@gmail.com>
+ * replace.el (occur-mode-map): Some fixes for menu items.
- * term/ns-win.el: Don't set the region face background. (Bug#4381)
+2011-04-07 Aaron S. Hawley <aaron.s.hawley@gmail.com>
- * faces.el: Default light-background background for region face to
- ns_selection_color under NS.
+ * play/morse.el (denato-region): Handle varying case. (Bug#8386)
-2009-09-27 Teodor Zlatanov <tzz@lifelogs.com>
+2011-04-06 Chong Yidong <cyd@stupidchicken.com>
- * net/imap-hash.el: New library, see NEWS.
+ * emacs-lisp/cconv.el (cconv--analyse-use): Ignore "ignored" when
+ issuing unused warnings.
- * Makefile.in (ELCFILES): Add imap-hash.el.
+ * emacs-lisp/tabulated-list.el (tabulated-list-print): Use lambda
+ macro directly.
-2009-09-27 Stefan Monnier <monnier@iro.umontreal.ca>
+ * simple.el: Lisp reimplement of list-processes. Based on an
+ earlier reimplementation by Leo Liu, but using tabulated-list.el.
+ (process-menu-mode): New major mode.
+ (list-processes--refresh, list-processes):
+ (process-menu-visit-buffer): New functions.
- * help.el (help-for-help-internal): Don't purecopy the text (bug#4560).
- * isearch.el (isearch-help-for-help-internal): Purecopy the second arg.
- * help-macro.el (make-help-screen): Avoid using an ambiguous function
- definition where the docstring could be taken for the return value.
+ * files.el (save-buffers-kill-emacs): Don't assume any return
+ value of list-processes, which is undocumented anyway.
-2009-09-26 Glenn Morris <rgm@gnu.org>
+2011-04-06 Chong Yidong <cyd@stupidchicken.com>
- * mail/rmailmm.el (rmail-mime-show-images, rmail-mime-bulk-handler):
- Add option to only show images below a certain size.
- (rmail-mime-multipart-handler): Remove unnecessary save-match-data and
- save-excursion calls.
+ * emacs-lisp/tabulated-list.el: New file.
-2009-09-26 Eli Zaretskii <eliz@gnu.org>
+ * emacs-lisp/package.el: Use Tabulated List mode.
+ (package-menu-mode-map): Inherit from tabulated-list-mode-map.
+ (package-menu-mode): Derive from tabulated-list-mode. Set up the
+ table format using Tabulated List mode variables.
+ (package--push): New macro, replacing package-list-maybe-add.
+ (package-menu--generate): Use package--push. Renamed from
+ package--generate-package-list.
+ (package-menu-refresh, list-packages): Use it.
+ (package-menu--print-info): Rename from package-print-package.
+ Return insertion data instead of inserting it directly.
+ (package-menu-describe-package, package-menu-execute):
+ Use tabulated-list-get-id.
+ (package-menu-mark-delete, package-menu-mark-install)
+ (package-menu-mark-unmark, package-menu-backup-unmark)
+ (package-menu-mark-obsolete-for-deletion):
+ Use tabulated-list-put-tag.
+ (package--list-packages, package-menu-revert)
+ (package-menu-get-package, package-menu-get-version)
+ (package-menu-sort-by-column): Functions deleted.
+ (package-menu-package-list, package-menu-sort-key): Vars deleted.
+ (package-menu--status-predicate, package-menu--version-predicate)
+ (package-menu--name-predicate)
+ (package-menu--description-predicate): Handle arguments in the
+ Tabulated List format.
+ (package-list-packages-no-fetch): Call list-packages.
- * makefile.w32-in (WINS_ALMOST): Add cedet (with its
- subdirectories) and eieio.
-
-2009-09-26 Alan Mackenzie <acm@muc.de>
-
- * progmodes/cc-engine.el (c-beginning-of-statement-1):
- Correct buggy bracketing. (Bug#4289)
-
- * progmodes/cc-langs.el (c-nonlabel-token-key): Allow quoted
- character constants (as case labels). (Bug#4289)
-
-2009-09-25 Juri Linkov <juri@jurta.org>
-
- * files.el (safe-local-eval-forms): Allow time-stamp in
- before-save-hook (Bug#4554).
-
-2009-09-25 Drew Adams <drew.adams@oracle.com>
-
- * menu-bar.el (list-buffers-directory): Doc fix.
-
-2009-09-25 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * log-edit.el (log-edit-changelog-entries): Avoid inf-loops.
- Try and avoid copying twice the same paragraph.
- (log-edit-changelog-paragraph, log-edit-changelog-subparagraph):
- Remove save-excursion.
- (log-edit-changelog-entry): Do it here instead.
-
-2009-09-25 Juanma Barranquero <lekktu@gmail.com>
+2011-04-06 Juanma Barranquero <lekktu@gmail.com>
- * bs.el (bs--get-file-name): Use `list-buffers-directory'
- when available, instead of hardcoding mode names. Doc fix.
+ * files.el (after-find-file-from-revert-buffer): Remove variable.
+ (after-find-file): Don't bind it.
+ (revert-buffer-in-progress-p): New variable.
+ (revert-buffer): Bind it.
+ Pass nil for `after-find-file-from-revert-buffer'.
- * menu-bar.el (list-buffers-directory): Add docstring.
- Make automatically buffer-local.
+ * saveplace.el (save-place-find-file-hook): Use new variable
+ `rever-buffer-in-progress-p', not `after-find-file-from-revert-buffer'.
- * dired.el (dired-mode):
- * files.el (cd-absolute):
- * pcvs.el (cvs-temp-buffer):
- * pcvs-util.el (cvs-get-buffer-create):
- * shell.el (shell-mode):
- * vc-dir.el (vc-dir-mode):
- Don't make `list-buffers-directory' buffer local.
+2011-04-06 Glenn Morris <rgm@gnu.org>
-2009-09-25 Devon Sean McCullough <emacs-hacker@Jovi.Net>
+ * Makefile.in (AUTOGEN_VCS): New variable.
+ (autoloads): Use $AUTOGEN_VCS.
- * comint.el (comint-exec, comint-run, make-comint):
- Doc fixes (Bug#4542).
+ * calendar/cal-move.el (calendar-scroll-toolkit-scroll): New function.
+ * calendar/calendar.el (calendar-mode-map):
+ Check for toolkit scroll bars. (Bug#8305)
-2009-09-25 Glenn Morris <rgm@gnu.org>
+2011-04-05 Chong Yidong <cyd@stupidchicken.com>
- * mail/rmailmm.el (rmail-mime): New custom group.
- Move all defcustoms in this file into this group.
- (rmail-mime-media-type-handlers-alist): Revert previous change.
- (rmail-mime-show-images): New option.
- (rmail-mime-total-number-of-bulk-attachments): Remove variable and all
- references to it, since it wasn't actually used for anything.
- (rmail-mime-insert-image): New function.
- (rmail-mime-image): Use rmail-mime-insert-image.
- (rmail-mime-bulk-handler): Remove optional `image' argument, instead
- obey the value of `rmail-mime-show-images' option. Print the size of
- attachments.
+ * minibuffer.el (completion-in-region--postch)
+ (completion-in-region-mode): Remove unnecessary messages.
-2009-09-25 David Engster <deng@randomsample.de>
-
- * progmodes/hideshow.el (hs-show-block): Run `hs-show-hook'. (Bug#4548)
-
-2009-09-24 Vinicius Jose Latorre <viniciusjl@ig.com.br>
-
- * whitespace.el: Does not highlight trailing spaces While point is
- at end of line. Does not highligt spaces at beginning of buffer
- while point is at beginning of buffer. Does not highlight spaces
- at end of buffer while point is at end of buffer. (Bug#4177)
- New version 12.0.
- (whitespace-display-mappings): Adjust initialization.
- (whitespace-point, whitespace-font-lock-refontify): New vars.
- (whitespace-color-on, whitespace-color-off): Adjust code.
- (whitespace-trailing-regexp, whitespace-empty-at-bob-regexp)
- (whitespace-empty-at-eob-regexp, whitespace-space-regexp)
- (whitespace-tab-regexp, whitespace-post-command-hook): New funs.
-
-2009-09-24 Chong Yidong <cyd@stupidchicken.com>
-
- * nxml/nxml-mode.el: Alias xml-mode to nxml-mode.
-
- * textmodes/sgml-mode.el: Remove xml-mode alias.
-
- * files.el (auto-mode-alist, conf-mode-maybe)
- (magic-fallback-mode-alist): Revert 2009-09-18 and 2009-09-21 changes.
-
-2009-09-24 Alan Mackenzie <acm@muc.de>
-
- * progmodes/cc-cmds.el (c-scan-conditionals): A new function like
- c-forward-conditionals, but it doesn't move point and doesn't set
- the mark.
- (c-up-conditional, c-up-conditional-with-else, c-down-conditional)
- (c-down-conditional-with-else, c-backward-conditional)
- (c-forward-conditional): Refactor to use c-scan-conditionals.
-
-2009-09-24 Juanma Barranquero <lekktu@gmail.com>
-
- * help-fns.el (help-downcase-arguments): New option, defaulting to nil.
- (help-default-arg-highlight): Remove.
- (help-highlight-arg): New function.
- (help-do-arg-highlight): Use it.
- Suggested by Drew Adams <drew.adams@oracle.com>. (Bug#4510, bug#4520)
-
-2009-09-24 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * term.el (term-set-scroll-region, term-handle-ansi-escape):
- Undo last change, which didn't fix the problem and introduced others.
-
-2009-09-24 Nick Roberts <nickrob@snap.net.nz>
-
- * progmodes/gdb-mi.el: Don't require speedbar.
- (gdb-jsonify-buffer): Handle case where "=" is part of value string.
-
-2009-09-24 Glenn Morris <rgm@gnu.org>
-
- * calendar/diary-lib.el (diary-fancy-display): Always run the hook.
-
- * term/ns-win.el (ns-reg-to-script): Define for compiler.
-
- * mail/rmailmm.el (rmail-mime-multipart-handler): Accept the case where
- there is no newline after the final mime boundary. (Bug#4539)
- Move markers on insertion so that any buttons inserted don't end up in
- the next part of a multipart message.
- (rmail-mime-media-type-handlers-alist): Doc fix. Add image handler.
- (rmail-mime-bulk-handler): Optionally handle images.
- (rmail-mime-image): New button action.
- (rmail-mime-image-handler): New function.
- (rmail-mime-mode): New mode.
- (rmail-mime): Doc fix. Use rmail-mime-mode (for font-lock).
-
-2009-09-24 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * minibuffer.el (minibuffer-force-complete): Cycle the list, rather
- than just dropping elements from it (bug#4504).
-
- * term.el (term-set-scroll-region): Don't move cursor any more.
- (term-handle-ansi-escape): Call term-goto here instead.
- Suggested by Ivan Kanis <apple@kanis.eu>.
-
- * term.el: Require CL.
- (term-ansi-reset): New function.
- (term-mode, term-emulate-terminal, term-handle-colors-array): Use it.
- (term-handle-colors-array): Simplify.
-
-2009-09-24 Juanma Barranquero <lekktu@gmail.com>
-
- * allout.el (allout-overlay-interior-modification-handler)
- (allout-obtain-passphrase):
- * epa-file.el (epa-file-write-region):
- * ps-print.el (ps-begin-job):
- * vc-hooks.el (vc-toggle-read-only):
- * vc-rcs.el (vc-rcs-rollback):
- * vc-sccs.el (vc-sccs-rollback):
- * vc.el (vc-deduce-fileset, vc-next-action, vc-register-with)
- (vc-version-diff, vc-revert, vc-rollback):
- * wdired.el (wdired-check-kill-buffer):
- * emacs-lisp/authors.el (authors):
- * net/socks.el (socks-open-connection):
- * net/zeroconf.el (zeroconf-service-add-hook):
- * obsolete/vc-mcvs.el (vc-mcvs-register):
- * progmodes/gdb-mi.el (def-gdb-thread-buffer-gud-command)
- (gdb-select-frame):
- * progmodes/grep.el (lgrep, rgrep):
- * progmodes/idlw-help.el (idlwave-help-check-locations)
- (idlwave-help-html-link, idlwave-help-assistant-open-link):
- * textmodes/ispell.el (ispell-find-aspell-dictionaries):
- * textmodes/reftex-toc.el (reftex-toc-promote-prepare)
- (reftex-toc-rename-label): Fix typos in error messages.
-
- * dired-aux.el (dired-do-shell-command): Reflow docstring.
- (dired-copy-how-to-fn): Doc fix.
- (dired-files-attributes, dired-read-shell-command):
- Fix typos in docstrings.
+2011-04-05 Juanma Barranquero <lekktu@gmail.com>
- * dired-x.el (dired-enable-local-variables, dired-filename-at-point)
- (dired-x-find-file-other-window): Reflow docstrings.
- (dired-omit-marker-char, dired-read-shell-command)
- (dired-x-submit-report): Fix typos in docstrings.
-
- * shell.el (shell-mode-hook):
- * view.el (View-scroll-line-forward):
- * progmodes/inf-lisp.el (inferior-lisp-mode-hook):
- Fix typos in docstrings.
+ * font-lock.el (font-lock-refresh-defaults):
+ Don't bind `hi-lock--inhibit-font-lock-hook', removed in
+ 2010-10-09T04:09:19Z!cyd@stupidchicken.com and 2010-10-11T23:57:49Z!lekktu@gmail.com (2010-10-12).
- * net/dig.el (dig-invoke): Fix typo in docstring.
- (query-dig): Reflow docstring.
-
- * progmodes/idlwave.el (idlwave-create-user-catalog-file)
- (idlwave-quoted, idlwave-rinfo-max-source-lines): Doc fixes.
- (idlwave-abbrev-move, idlwave-auto-routine-info-updates)
- (idlwave-begin-block-reg, idlwave-begin-unit-reg)
- (idlwave-beginning-of-subprogram, idlwave-block-jump-out)
- (idlwave-block-match-regexp, idlwave-calculate-paren-indent)
- (idlwave-check-abbrev, idlwave-class-file-or-buffer)
- (idlwave-class-found-in, idlwave-complete, idlwave-complete-in-buffer)
- (idlwave-completion-map, idlwave-current-indent)
- (idlwave-custom-ampersand-surround, idlwave-customize)
- (idlwave-default-font-lock-items, idlwave-default-insert-timestamp)
- (idlwave-define-abbrev, idlwave-determine-class-special)
- (idlwave-do-action, idlwave-doc-header, idlwave-doc-modification)
- (idlwave-end-block-reg, idlwave-end-of-statement)
- (idlwave-end-of-statement0, idlwave-end-of-subprogram)
- (idlwave-end-unit-reg, idlwave-entry-find-keyword)
- (idlwave-explicit-class-listed, idlwave-file-header)
- (idlwave-fill-paragraph, idlwave-find-class-definition)
- (idlwave-fix-keywords, idlwave-hang-indent-regexp, idlwave-hard-tab)
- (idlwave-idlwave_routine_info-compiled, idlwave-in-comment)
- (idlwave-in-quote, idlwave-indent-action-table)
- (idlwave-indent-expand-table, idlwave-indent-line)
- (idlwave-indent-subprogram, idlwave-indent-to-open-paren)
- (idlwave-is-comment-line, idlwave-is-comment-or-empty-line)
- (idlwave-is-continuation-line, idlwave-is-pointer-dereference)
- (idlwave-kill-autoloaded-buffers, idlwave-lib-p, idlwave-look-at)
- (idlwave-make-tags, idlwave-mode, idlwave-mode-abbrev-table)
- (idlwave-mouse-active-rinfo, idlwave-newline, idlwave-no-change-comment)
- (idlwave-outlawed-buffers, idlwave-popup-select)
- (idlwave-previous-statement, idlwave-rescan-catalog-directories)
- (idlwave-routine-entry-compare, idlwave-routine-info.pro)
- (idlwave-scan-all-buffers-for-routine-info, idlwave-scan-class-info)
- (idlwave-shell-automatic-start, idlwave-shell-explicit-file-name)
- (idlwave-show-begin, idlwave-split-line, idlwave-split-link-target)
- (idlwave-statement-type, idlwave-struct-skip)
- (idlwave-substitute-link-target, idlwave-toggle-comment-region)
- (idlwave-update-current-buffer-info, idlwave-use-library-catalogs)
- (idlwave-what-module-find-class): Fix typos in docstrings.
- (idlwave-all-method-classes, idlwave-calc-hanging-indent)
- (idlwave-calculate-cont-indent, idlwave-expand-equal)
- (idlwave-find-module, idlwave-find-structure-definition)
- (idlwave-init-rinfo-when-idle-after, idlwave-insert-source-location)
- (idlwave-list-load-path-shadows, idlwave-next-statement)
- (idlwave-routine-entry-compare-twins, idlwave-routine-info)
- (idlwave-routines, idlwave-sintern-rinfo-list, idlwave-statement-match)
- (idlwave-template): Reflow docstrings.
-
- * progmodes/idlw-shell.el (idlwave-shell-syntax-error): Doc fix.
- (idlwave-shell-batch-command, idlwave-shell-bp-alist)
- (idlwave-shell-bp-get, idlwave-shell-bp-overlays)
- (idlwave-shell-bp-query, idlwave-shell-break-here, idlwave-shell-buffer)
- (idlwave-shell-display-line, idlwave-shell-display-wframe)
- (idlwave-shell-electric-debug-mode, idlwave-shell-examine-select)
- (idlwave-shell-file-name-chars, idlwave-shell-filter-bp)
- (idlwave-shell-goto-frame, idlwave-shell-halt-messages-re)
- (idlwave-shell-highlighting-and-faces, idlwave-shell-idl-wframe)
- (idlwave-shell-mode-hook, idlwave-shell-mode-line-info)
- (idlwave-shell-mode-map, idlwave-shell-module-source-filter)
- (idlwave-shell-mouse-help, idlwave-shell-mouse-print)
- (idlwave-shell-pc-frame, idlwave-shell-pending-commands)
- (idlwave-shell-print, idlwave-shell-quit, idlwave-shell-redisplay)
- (idlwave-shell-scan-for-state, idlwave-shell-send-command)
- (idlwave-shell-sentinel-hook, idlwave-shell-separate-examine-output)
- (idlwave-shell-shell-command, idlwave-shell-sources-alist)
- (idlwave-shell-sources-bp, idlwave-shell-sources-filter)
- (idlwave-shell-step, idlwave-shell-use-breakpoint-glyph)
- (idlwave-toolbar-add-everywhere, idlwave-toolbar-toggle):
+ * info.el (Info-directory-list, Info-read-node-name-2)
+ (Info-split-parameter-string): Doc fixes.
+ (Info-virtual-nodes): Reflow docstring.
+ (Info-find-file, Info-directory-toc-nodes, Info-history-toc-nodes)
+ (Info-apropos-toc-nodes, info-finder, Info-get-token)
+ (Info-find-emacs-command-nodes, Info-speedbar-key-map):
Fix typos in docstrings.
- (idlwave-shell-bp, idlwave-shell-clear-current-bp)
- (idlwave-shell-hide-output, idlwave-shell-mode)
- (idlwave-shell-run-region, idlwave-shell-set-bp-in-module):
- Reflow docstrings.
-
- * textmodes/bibtex.el (bibtex-sort-entry-class): Fix group name.
-
-2009-09-24 Ivan Kanis <apple@kanis.eu>
-
- * term.el (term-bold-attribute): New var.
- (term-handle-colors-array): Use it.
-
-2009-09-23 Nick Roberts <nickrob@snap.net.nz>
-
- * progmodes/gdb-mi.el (gdb-version): New variable.
- (gdb-non-stop-handler): Set gdb-version.
- (gdb-gud-context-command, gdb-current-context-command, gdb-stopped):
- Condition "--thread" option on gdb-version.
- (gdb-invalidate-threads): Remove unused argument.
-
-2009-09-23 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * textmodes/flyspell.el (sgml-mode-flyspell-verify): Pass limit args
- to looking-back to avoid ridiculous slow down in large files (bug#4511).
-
-2009-09-23 Glenn Morris <rgm@gnu.org>
-
- * mail/rmail.el (rmail-reply): Don't try to add a References header when
- replying to mail without References or Message-Id. (Bug#4525)
-
-2009-09-23 Adrian Robert <Adrian.B.Robert@gmail.com>
-
- * term/ns-win.el (ns-reg-to-script): New variable.
-
-2009-09-23 Daiki Ueno <ueno@unixuser.org>
-
- * epg.el (epg-wait-for-status): Preserve existing 'error results.
-
-2009-09-22 Sam Steingold <sds@gnu.org>
-
- * vc-hg.el (vc-hg-print-log): Fix shortlog arg passing.
- (vc-hg-outgoing, vc-hg-incoming): Bump okstatus in `vc-hg-command'
- to 1 because hg returns status 1 when nothing is found.
- Bind `vc-short-log' for the sake of `vc-hg-log-view-mode'.
-
-2009-09-22 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * textmodes/fill.el: Convert to utf-8 encoding.
- (fill-french-nobreak-p): Remove redundant » and « inherited from our
- pre-unicode days.
-
- * add-log.el (change-log-fill-forward-paragraph): New function.
- (change-log-mode): Use it so fill-region DTRT.
- Set fill-indent-according-to-mode here rather than in
- change-log-fill-paragraph.
- (change-log-fill-paragraph): Remove.
-
-2009-09-22 Juanma Barranquero <lekktu@gmail.com>
-
- * info.el (Info-try-follow-nearest-node): Use the URL extracted by
- `Info-get-token', instead of `browse-url-url-at-point'. (Bug#4508)
-
-2009-09-22 Glenn Morris <rgm@gnu.org>
-
- * calendar/calendar.el (calendar-mode-map): Make mouse-1 and 3 clicks on
- the scroll-bar scroll the calendar window rather than the buffer.
-
- * calendar/cal-menu.el (cal-menu-scroll-menu): Add a sub-section with
- commands that move point (as opposed to scrolling).
-
- * emulation/tpu-edt.el (tpu-copy-keyfile): Fix condition-case handler.
-
- * emacs-lisp/elint.el (elint): New custom group.
- (elint-log-buffer): Make it a defcustom.
- (elint-scan-preloaded, elint-ignored-warnings)
- (elint-directory-skip-re): New options.
- (elint-builtin-variables): Doc fix.
- (elint-preloaded-env): New variable.
- (elint-unknown-builtin-args): Add an entry for encode-time.
- (elint-extra-errors): Make it a variable rather than a constant.
- (elint-preloaded-skip-re): New constant.
- (elint-directory): Skip files matching elint-directory-skip-re.
- (elint-features): New variable, local to linted buffers.
- (elint-update-env): Initialize elint-features. Possibly add
- elint-preloaded-env to the buffer's environment.
- (elint-get-top-forms): Bind elint-current-pos, for log messages.
- Skip quoted forms.
- (elint-init-form): New function, extracted from elint-init-env.
- Make non-list forms a warning rather than an error.
- Add the mode-map for define-derived-mode. Handle define-minor-mode,
- easy-menu-define, put that adds an error-condition, and provide.
- When requiring cl, also require cl-macs. Really require cl, to handle
- some cl macros. Store required libraries in the list elint-features,
- so as not to re-load them. Treat cc-require like require.
- (elint-init-env): Call elint-init-form to do the work.
- Handle eval-and-compile and such like.
- (elint-add-required-env): Do not clear messages.
- (elint-special-forms): Add handlers for function, defalias, if, when,
- unless, and, or.
- (elint-form): Add optional argument to ignore elint-special-forms,
- useful to prevent recursive calls from handlers. Doc fix.
- Respect elint-ignored-warnings.
- (elint-form): Respect elint-ignored-warnings.
- (elint-bound-variable, elint-bound-function): New variables.
- (elint-unbound-variable): Respect elint-bound-variable.
- (elint-get-args): Respect elint-bound-function.
- (elint-check-cond-form): Add some simple handling for (f)boundp and
- featurep tests.
- (elint-check-defalias-form): New handler.
- (elint-check-let-form): Make an empty let a warning rather than an
- error.
- (elint-check-setq-form): Make an empty setq a warning rather than an
- error. Respect elint-ignored-warnings.
- (elint-check-defvar-form): Accept null doc-strings.
- (elint-check-conditional-form): New handler. Does some simple-minded
- checking of featurep and (f)boundp tests.
- (elint-put-function-args): New function.
- (elint-initialize): Use elint-scan-doc-file rather than
- elint-find-builtin-variables. Use elint-put-function-args.
- Possibly scan preloaded-file-list.
- (elint-scan-doc-file): Rename from elint-find-builtin-variables and
- extend to handle functions as well.
-
-2009-09-22 Lennart Borgman <lennart.borgman@gmail.com>
-
- * linum.el (linum-delete-overlays, linum-update-window):
- Do not modify the right margin. (Bug#3971)
-
-2009-09-21 Chong Yidong <cyd@stupidchicken.com>
-
- * files.el (conf-mode-maybe, magic-fallback-mode-alist):
- Use nxml-mode instead of xml-mode.
-
-2009-09-21 Kevin Ryde <user42@zip.com.au>
-
- * net/dig.el: Add "Keywords: comm", as per net-utils.el. (Bug#4501)
-
-2009-09-21 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * net/dig.el (dig-mode): Use define-derived-mode.
-
-2009-09-20 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc-dispatcher.el (vc-do-command): Return the process object in
- the asynchronous case. Use when instead of if. Do not run
- vc-exec-after to display a message if not enabled. (Bug#4463)
-
- * vc-git.el (vc-git-dir-extra-headers): Add keymap and mouse-face
- properties to the stash strings.
- (vc-git-stash-list): Return a list of strings.
- (vc-git-stash-get-at-point, vc-git-stash-delete-at-point)
- (vc-git-stash-show-at-point): New functions.
- (vc-git-stash-map): New keymap.
-
- * register.el (ctl-x-r-map): Define the keys here instead of
- using autoload.
-
-2009-09-20 Thierry Volpiatto <thierry.volpiatto@gmail.com> (tiny change)
-
- * bookmark.el (bookmark-write-file): Avoid calling `pp' with large
- list, to workaround performance problem (bug#4485).
-
-2009-09-20 Nick Roberts <nickrob@snap.net.nz>
-
- * progmodes/gud.el (gud-sentinel): Revert indavertant change.
-
-2009-09-20 Daiki Ueno <ueno@unixuser.org>
+ (Info-revert-buffer-function, Info-search, Info-isearch-pop-state)
+ (Info-speedbar-hierarchy-buttons, Info-speedbar-goto-node)
+ (Info-speedbar-buttons, Info-desktop-buffer-misc-data)
+ (Info-restore-desktop-buffer): Mark unused parameters.
+ (Info-directory-find-file, Info-directory-find-node)
+ (Info-history-find-file, Info-history-find-node, Info-toc-find-node)
+ (Info-virtual-index-find-node, Info-apropos-find-file)
+ (Info-apropos-find-node, Info-finder-find-file, Info-finder-find-node):
+ Mark unused parameters; fix typos in docstrings.
+ (Info-virtual-index): Remove unused local variable `nodename'.
- * epa-file.el (epa-file-cache-passphrase-for-symmetric-encryption):
- Document that this option is not recommended to use.
+2011-04-05 Deniz Dogan <deniz@dogan.se>
-2009-09-19 Glenn Morris <rgm@gnu.org>
+ * net/rcirc.el: Update my e-mail address.
+ (rcirc-mode-map): Remove M-o binding.
- * calc/calc-graph.el (calc-graph-lookup): Avoid assignment to free
- variable `var'.
+2011-04-05 Chong Yidong <cyd@stupidchicken.com>
- * calc/calc-alg.el (var):
- * calc/calcalg2.el (var): Define for compiler.
+ * startup.el (command-line): Save the cursor's theme-face
+ directly, instead of using face-override-spec.
-2009-09-19 Chong Yidong <cyd@stupidchicken.com>
+ * custom.el (load-theme): Minor optimization in assigning faces.
- * emacs-lisp/advice.el (ad-get-argument, ad-set-argument):
- Doc fix (Bug#3932).
+2011-04-04 Juanma Barranquero <lekktu@gmail.com>
- * subr.el (baud-rate): Remove long-obsolete function (Bug#4372).
-
- * time-stamp.el (time-stamp-month-dd-yyyy)
- (time-stamp-dd/mm/yyyy, time-stamp-mon-dd-yyyy)
- (time-stamp-dd-mon-yy, time-stamp-yy/mm/dd)
- (time-stamp-yyyy/mm/dd, time-stamp-yyyy-mm-dd)
- (time-stamp-yymmdd, time-stamp-hh:mm:ss, time-stamp-hhmm):
- Remove functions that have been obsolete since 1995 (Bug#4436).
-
- * progmodes/sh-script.el (sh-learn-buffer-indent): Pop to the
- indent buffer only if called interactively (Bug#4452).
-
-2009-09-19 Juanma Barranquero <lekktu@gmail.com>
- 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.
- (server-ensure-safe-dir): Accept FAT32 directories as "safe",
- but warn against using them.
-
-2009-09-19 Nick Roberts <nickrob@snap.net.nz>
-
- * progmodes/gdb-mi.el (gdb-var-update-handler-1): Include case of
- older GDB where there is no has_more field.
-
-2009-09-19 Glenn Morris <rgm@gnu.org>
-
- * pgg-pgp.el (pgg-pgp-encrypt-region): Add missing mapconcat separator.
-
-2009-09-18 Chong Yidong <cyd@stupidchicken.com>
-
- * files.el (auto-mode-alist): Change default for XML files to nXML
- mode (Bug#4169).
-
-2009-09-18 Juanma Barranquero <lekktu@gmail.com>
-
- * server.el (server-ensure-safe-dir): Pass 'integer
- to `file-attributes', as suggested.
-
-2009-09-18 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * dired-aux.el (dired-query-alist): Remove spurious backslash.
- (dired-query): Use read-key.
-
-2009-09-18 Adrian Robert <Adrian.B.Robert@gmail.com>
-
- * cus-start.el (ns-use-qd-smoothing): Remove.
-
-2009-09-18 Glenn Morris <rgm@gnu.org>
+ * help-fns.el (describe-variable): Complete all variables having
+ documentation, including keywords.
+ http://lists.gnu.org/archive/html/emacs-devel/2011-04/msg00112.html
- * allout.el (top-level): Remove unnecessary progn.
+2011-04-04 Juanma Barranquero <lekktu@gmail.com>
- * progmodes/js.el (js-end-of-defun): Remove malformed and unneeded let.
+ Convert to lexical-binding.
- * emacs-lisp/derived.el (define-derived-mode): Fix paren typo in
- definition of abbrev table.
+ * bs.el (bs-refresh, bs-sort-buffer-interns-are-last)
+ (bs--get-marked-string, bs--get-modified-string)
+ (bs--get-readonly-string, bs--get-size-string, bs--get-name)
+ (bs--get-mode-name, bs--get-file-name): Mark unused arguments.
+ (bs--configuration-name-for-prefix-arg): Rename argument PREFIX-ARG.
- * speedbar.el (speedbar-track-mouse):
- * net/eudc-bob.el (eudc-bob-pipe-object-to-external-program):
- * net/eudc.el (eudc-expand-inline):
- * net/newst-backend.el (newsticker--cache-read-feed):
- * nxml/nxml-outln.el (nxml-end-of-heading): Fix typos in
- condition-case handlers.
+ * ehelp.el (electric-help-execute-extended)
+ (electric-help-ctrl-x-prefix):
+ * hexl.el (hexl-revert-buffer-function):
+ * linum.el (linum-after-change, linum-after-scroll):
+ * emacs-lisp/re-builder.el (reb-auto-update): Mark unused arguments.
-2009-09-18 Nick Roberts <nickrob@snap.net.nz>
+ * help-fns.el (help-describe-category-set): Remove unused ERR variable.
- * progmodes/gdb-mi.el (gdb-frame-address): New variable.
- (gdb-var-list): Add an element for has_more field.
- (gdb-non-stop-handler): Enable pretty printing for STL containers.
- (gdb-var-create-handler, gdb-var-list-children-handler-1)
- (gdb-var-update-handler-1): Parse output of dynamic variable
- objects (STL containers).
- (gdb-var-delete-1): Pass var1 as an explicit second argument.
- (gdb-get-field): Delete alias. Use bindat-get-field directly.
+2011-04-04 Daiki Ueno <ueno@unixuser.org>
- * progmodes/gud.el (gud-speedbar-item-info): Adjust for change to
- gdb-var-list.
- (gud-speedbar-buttons): Make node expandable if expression "has more"
- children.
+ * epa-dired.el:
+ * epa-mail.el:
+ * epa-hook.el:
+ * epa-file.el:
+ * epa.el:
+ * epg.el: Use lexical binding.
-2009-09-17 Juanma Barranquero <lekktu@gmail.com>
+2011-04-03 Chong Yidong <cyd@stupidchicken.com>
- * startup.el (emacs-quick-startup): Remove variable and all uses.
- (command-line): Set `inhibit-x-resources' instead.
- (command-line-1): Use `inhibit-x-resources' instead.
+ * dired-aux.el (dired-create-files): Add docstring (Bug#7970).
-2009-09-17 Chong Yidong <cyd@stupidchicken.com>
+ * textmodes/flyspell.el (flyspell-word): Recognize default
+ dictionary case for flyspell-mark-duplications-exceptions.
+ Use regexp matching for languages.
+ (flyspell-mark-duplications-exceptions): Add "that" and "had" for
+ default dictionary (Bug#7926).
- * subr.el: Fix last change to avoid using the `unless' macro,
- which breaks bootstrapping.
+2011-04-02 Chong Yidong <cyd@stupidchicken.com>
-2009-09-17 Stefan Monnier <monnier@iro.umontreal.ca>
+ * emacs-lisp/package.el (package--with-work-buffer):
+ Recognize https URLs.
- * subr.el (push, pop, dolist, dotimes, declare): Don't overwrite CL's
- extended definitions, in case we reload subr.el after having
- loaded CL.
- (eval-next-after-load): Mark as obsolete.
+ * net/network-stream.el: Move from gnus/proto-stream.el.
+ Change prefix to network-stream throughout.
+ (open-protocol-stream): Merge into open-network-stream, leaving
+ open-protocol-stream as an alias. Handle nil BUFFER args.
-2009-09-17 Juri Linkov <juri@jurta.org>
+ * subr.el (open-network-stream): Move to net/network-stream.el.
- * menu-bar.el (menu-bar-search-menu, menu-bar-edit-menu)
- (menu-bar-options-menu, menu-bar-showhide-fringe-menu)
- (menu-bar-showhide-menu, menu-bar-tools-menu)
- (menu-bar-describe-menu, menu-bar-help-menu)
- (minibuffer-local-completion-map, minibuffer-local-map):
- Fix list quoting.
+2011-04-02 Glenn Morris <rgm@gnu.org>
-2009-09-17 Glenn Morris <rgm@gnu.org>
+ * find-dired.el (find-exec-terminator): New option.
+ (find-ls-option): Test for -ls support.
+ (find-ls-subdir-switches): Test for -b in find-ls-option.
+ (find-dired, find-grep-dired): Doc fixes.
+ (find-dired): Use find-exec-terminator.
- * emacs-lisp/bytecomp.el (byte-compile-form): Always check the function
- arguments, whether or not it has a handler.
+ * find-dired.el (find-ls-option, find-ls-subdir-switches)
+ (find-grep-options): Do not autoload these defcustoms, remove purecopy.
+ (find-name-arg): Remove purecopy.
- * ansi-color.el (ansi-color-get-face-1): Fix typo in handler.
+ * progmodes/grep.el (grep-find-use-xargs): Doc fix.
+ (grep-compute-defaults): Check for `-exec COMMAND +' support.
+ Set grep-find-use-xargs, grep-find-command, and grep-find-template
+ accordingly. Don't add the null-device if not needed.
- * simple.el (hard-newline): Give it a doc-string.
+ * files.el (save-some-buffers): Doc fix.
- * emacs-lisp/lisp-mode.el (emacs-lisp-mode-syntax-table):
- (lisp-mode-syntax-table): Give them doc-strings.
+2011-04-02 Eli Zaretskii <eliz@gnu.org>
-2009-09-17 Dan Nicolaescu <dann@ics.uci.edu>
+ * makefile.w32-in (EMACS): Default to ../src/$(BLD)/emacs.exe.
- * menu-bar.el (menu-bar-file-menu, menu-bar-file-menu)
- (menu-bar-i-search-menu, menu-bar-edit-menu, menu-bar-custom-menu)
- (menu-bar-options-menu, menu-bar-showhide-menu)
- (menu-bar-showhide-fringe-ind-menu, menu-bar-showhide-fringe-menu)
- (menu-bar-showhide-scroll-bar-menu, menu-bar-showhide-menu)
- (menu-bar-options-menu, menu-bar-line-wrapping-menu)
- (menu-bar-options-menu, menu-bar-tools-menu)
- (menu-bar-describe-menu, menu-bar-search-documentation-menu)
- (menu-bar-help-menu):
- (menu-bar-make-mm-toggle, menu-bar-make-toggle): Purecopy the
- string arguments.
+2011-04-01 Juanma Barranquero <lekktu@gmail.com>
- * ediff-hook.el (menu-bar-ediff-menu, menu-bar-ediff-merge-menu)
- (menu-bar-epatch-menu, menu-bar-ediff-misc-menu): Add purecopy
- calls for the menu names and :help.
+ * progmodes/idlwave.el (idlwave-one-key-select, idlwave-list-abbrevs):
+ Use `dolist' rather than `mapcar'.
-2009-09-17 Stefan Monnier <monnier@iro.umontreal.ca>
+2011-04-01 Stefan Monnier <monnier@iro.umontreal.ca>
- * mouse.el (minor-mode-menu-from-indicator): Pay attention
- to :minor-mode-function (bug#4455).
+ Add lexical binding.
-2009-09-16 Stefan Monnier <monnier@iro.umontreal.ca>
+ * subr.el (apply-partially): Use new closures rather than CL.
+ (--dolist-tail--, --dotimes-limit--): Don't declare dynamic.
+ (dolist, dotimes): Use slightly different expansion for lexical code.
+ (functionp): Move to C.
+ (letrec): New macro.
+ (with-wrapper-hook): Use it and apply-partially instead of CL.
+ (eval-after-load): Preserve lexical-binding.
+ (save-window-excursion, with-output-to-temp-buffer): Turn them
+ into macros.
- * startup.el (command-line): Initialize the window-system after
- processing the command-line.
+ * simple.el (with-wrapper-hook, apply-partially): Move to subr.el.
- * textmodes/page.el (what-page): Make sure we don't inf-loop if
- page-delimiter matches the empty string.
+ * help-fns.el (help-split-fundoc): Return nil if there's nothing else
+ than the arglist.
+ (help-add-fundoc-usage): Don't add `Not documented'.
+ (help-function-arglist): Handle closures, subroutines, and new
+ byte-code-functions.
+ (help-make-usage): Remove leading underscores.
+ (describe-function-1): Handle closures.
+ (describe-variable): Use special-variable-p for completion.
-2009-09-16 Glenn Morris <rgm@gnu.org>
+ * files.el (lexical-binding): Declare safe.
- * emacs-lisp/bytecomp.el (byte-compile-not-obsolete-vars): Rename from
- byte-compile-not-obsolete-var. It's a list now.
- (byte-compile-not-obsolete-funcs): New variable.
- (byte-compile-warn-obsolete): Don't warn about functions if they are in
- byte-compile-not-obsolete-funcs.
- (byte-compile-variable-ref, byte-compile-defvar): Update for
- byte-compile-not-obsolete-vars name-change and list nature.
- (byte-compile-maybe-guarded): Suppress warnings about obsolete functions
- and variables behind (f)boundp tests.
- * net/tramp-compat.el (byte-compile-not-obsolete-vars): Set if bound.
+ * emacs-lisp/pcase.el: Don't use destructuring-bind.
+ (pcase--memoize): Rename from pcase-memoize. Change weakness.
+ (pcase): Add `let' pattern.
+ Change memoization so it actually works.
+ (pcase-mutually-exclusive-predicates): Add byte-code-function-p.
+ (pcase--u1) <guard, pred>: Fix possible shadowing problem.
+ <let>: New case.
-2009-09-15 Dan Nicolaescu <dann@ics.uci.edu>
+ * emacs-lisp/macroexp.el: Use lexical binding.
+ (macroexpand-all-1): Check obsolete macros. Expand compiler-macros.
+ Don't convert ' to #' without checking that it's indeed quoting
+ a lambda.
- * vc-git.el (vc-git-log-view-mode): Undo inadvertent change.
+ * emacs-lisp/lisp-mode.el (eval-last-sexp-1):
+ Use eval-sexp-add-defvars.
+ (eval-sexp-add-defvars): New fun.
-2009-09-15 Stefan Monnier <monnier@iro.umontreal.ca>
+ * emacs-lisp/float-sup.el (pi): Don't declare as dynamically bound.
- * Makefile.in (compile-onefile): Use byte-compile-refresh-preloaded.
- * emacs-lisp/bytecomp.el (byte-compile-refresh-preloaded):
+ * emacs-lisp/eieio.el (byte-compile-file-form-defmethod):
Don't autoload.
-
-2009-09-15 Stephen Eglen <stephen@gnu.org>
-
- * iswitchb.el (iswitchb-read-buffer): When selecting a match from
- the virtual-buffers, use the name of the buffer specified by
- find-file-noselect, as the match may be a symlink. (This was a
- problem if the target and the symlink had different names.)
-
-2009-09-15 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * custom.el (custom-initialize-default, custom-initialize-set): CSE.
-
- * desktop.el (desktop-path): Check user-emacs-directory.
-
- * emacs-lisp/bytecomp.el (byte-compile-refresh-preloaded): New function.
-
- * loadup.el: Use after-load-functions to GC after loading each file.
- Remove the explicit GC calls that used to be sprinkled around.
-
- * subr.el (after-load-functions): New hook.
- (do-after-load-evaluation): Run it. Use string-match-p to detect
- `obsolete' packages, rather than painfully extracting the relevant
- directory name.
-
-2009-09-15 Glenn Morris <rgm@gnu.org>
-
- * apropos.el (apropos-documentation-check-doc-file): Avoid assignment to
- free variable `doc'.
-
- * dired.el (dired-mode-map): Add menu entry for async shell command.
-
- * help-fns.el (find-lisp-object-file-name): When looking for autoloaded
- variables, also consider the .elc files, since the .el files are
- normally gzipped (subsequent code locates the .el.gz from the .elc).
-
- * calc/calc-prog.el (arglist): Define for compiler.
-
- * calendar/diary-lib.el (diary-display-function): Change the default to
- fancy display.
- (body): Define for compiler.
-
- * emacs-lisp/bytecomp.el (byte-compile-keep-pending)
- (byte-compile-file-form, byte-compile-lambda)
- (byte-compile-top-level-body, byte-compile-form)
- (byte-compile-variable-ref, byte-compile-setq)
- (byte-compile-setq-default, byte-compile-body)
- (byte-compile-body-do-effect, byte-compile-and, byte-compile-or)
- (batch-byte-compile): Give some more local variables with common names
- a "bytecomp-" prefix to avoid masking warnings about free variables.
-
- * startup.el (command-line-1): Give local variables with common names a
- distinguishing prefix, so as not to hide free variable warnings during
- bootstrap.
-
- * mail/rmailmm.el (rmail-mime-save): If file exists, don't try to be
- clever and add a suffix to make a unique name, just let the user decide
- whether or not to overwrite it. If the input is a directory, write the
- default filename to that directory. (Bug#4388)
- (rmail-mime-bulk-handler): Ensure the save button's 'directory property
- is a filename-as-a-directory.
-
-2009-09-15 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * textmodes/page.el (what-page): Don't move to beginning of line.
- See <87tyz5ajte.fsf@x2.delysid.org> in emacs-devel.
-
-2009-09-15 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc-git.el (vc-git-dir-extra-headers): Show the remote location.
-
-2009-09-14 Dan Nicolaescu <dann@ics.uci.edu>
-
- * bindings.el (mode-line-mode-menu): Add purecopy calls for :help.
- * help.el (help-for-help-internal): Add purecopy calls for text.
-
- * vc.el (top): print-log method now takes an optional SHORTLOG
- argument. Add a new method: root.
- (vc-root-diff, vc-print-root-log): New functions.
- (vc-log-short-style): New variable.
- (vc-print-log-internal): Add support for showing short logs.
-
- * vc-hooks.el (vc-prefix-map, vc-menu-map): Add bindings for
- vc-print-root-log and vc-print-root-diff.
-
- * vc-bzr.el (vc-bzr-log-view-mode, vc-bzr-print-log):
- * vc-git.el (vc-git-print-log, vc-git-log-view-mode):
- * vc-hg.el (vc-hg-print-log, vc-hg-log-view-mode): Add support for
- short logs.
-
- * vc-cvs.el (vc-cvs-print-log):
- * vc-mtn.el (vc-mtn-print-log):
- * vc-rcs.el (vc-rcs-print-log):
- * vc-sccs.el (vc-sccs-print-log):
- * vc-svn.el (vc-svn-print-log): Add an optional argument shortlog
- that is ignored for now.
-
- * vc-mtn.el (vc-mtn-annotate-command):
- * vc-svn.el (vc-svn-annotate-command): Run asynchronously.
-
-2009-09-14 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * simple.el: Add mapping for backspace/delete/clear/tab/escape/return
- to function-key-map, and give them ascii-character property.
- * term/x-win.el (x-alternatives-map):
- * term/ns-win.el (ns-alternatives-map):
- * term/internal.el (msdos-key-remapping-map):
- * w32-fns.el (x-alternatives-map): Remove redundant mappings.
-
-2009-09-14 Glenn Morris <rgm@gnu.org>
-
- * emacs-lisp/elint.el (elint-add-required-env): Revert to not using
- temp-buffers (2009-09-12).
-
-2009-09-13 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * textmodes/ispell.el (ispell-command-loop): Improve last fix, using
- the new read-key function.
-
-2009-09-13 Chong Yidong <cyd@stupidchicken.com>
-
- * term/x-win.el (x-menu-bar-open): Only call accelerate-menu if it
- is defined (Bug#4405).
-
-2009-09-13 Vincent Belaïche <vincent.belaiche@gmail.com>
-
- * recentf.el (recentf-cleanup): Use a hash table to find
- duplicates (Bug#4407).
-
-2009-09-13 Per Starbäck <per@starback.se> (tiny change)
-
- * textmodes/ispell.el (ispell-command-loop): Convert keys such as
- kp-0 to ascii equivalents (Bug#4325).
-
-2009-09-13 Chong Yidong <cyd@stupidchicken.com>
-
- * progmodes/cperl-mode.el (cperl-init-faces): Revert last change.
-
- * eshell/em-hist.el:
- * eshell/em-dirs.el (eshell-complete-user-reference):
- Declare pcomplete functions and variables to avoid compiler warnings.
-
-2009-09-13 Leo <sdl.web@gmail.com> (tiny change)
-
- * eshell/em-script.el (eshell-login-script, eshell-rc-script):
- * eshell/em-dirs.el (eshell-last-dir-ring-file-name):
- * eshell/em-alias.el (eshell-aliases-file):
- * eshell/em-hist.el (eshell-history-file-name):
- Use expand-file-name instead of concat to make file names (Bug#4308).
-
-2009-09-13 Glenn Morris <rgm@gnu.org>
-
- * ediff-merg.el (ediff-do-merge):
- * filesets.el (filesets-run-cmd):
- * emulation/ws-mode.el (ws-show-markers, ws-move-block, ws-delete-block)
- (ws-find-marker-0, ws-find-marker-1, ws-find-marker-2, ws-find-marker-3)
- (ws-find-marker-4, ws-find-marker-5, ws-find-marker-6, ws-find-marker-7)
- (ws-find-marker-8, ws-find-marker-9, ws-goto-block-begin)
- (ws-goto-block-end, ws-goto-last-cursorposition, ws-copy-block):
- Replace empty `let's with `progn'.
-
-2009-09-13 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * mail/sendmail.el (send-mail-function):
- * tooltip.el (tooltip-mode):
- * simple.el (transient-mark-mode):
- * rfn-eshadow.el (file-name-shadow-mode):
- * frame.el (blink-cursor-mode):
- * font-core.el (global-font-lock-mode):
- * files.el (temporary-file-directory)
- (small-temporary-file-directory, auto-save-file-name-transforms):
- * epa-hook.el (auto-encryption-mode):
- * composite.el (global-auto-composition-mode):
- Use custom-initialize-delay.
- * startup.el (command-line): Don't explicitly call
- custom-reevaluate-setting for all the above vars.
- * custom.el (custom-initialize-safe-set)
- (custom-initialize-safe-default): Delete.
-
-2009-09-12 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * term/x-win.el (x-initialize-window-system):
- * term/w32-win.el (w32-initialize-window-system):
- * term/ns-win.el (ns-initialize-window-system): Don't call
- mouse-wheel-mode since it's enabled globally by default already.
-
- * mwheel.el (mouse-wheel-mode): Make sure the new defvar doesn't
- actually define the variable, but only silences the byte-compiler.
- (mouse-wheel-change-button): Check whether mouse-wheel-mode is bound
- before looking it up.
- (mouse-wheel-scroll-amount): Also reset the bindings if this value
- is changed.
-
-2009-09-12 Glenn Morris <rgm@gnu.org>
-
- * emacs-lisp/elint.el (elint-file): Make max-lisp-eval-depth at least
- 1000.
- (elint-add-required-env): Don't beep on error.
- (elint-forms): In case of error, return ENV unchanged.
- (elint-init-env): Skip non-list forms.
- (elint-log): Handle unknown file positions.
-
-2009-09-12 Daiki Ueno <ueno@unixuser.org>
-
- * epg.el (epg-make-context): Add autoload cookie.
- (epg-list-keys, epg-cancel, epg-start-decrypt, epg-decrypt-file)
- (epg-decrypt-string, epg-start-verify, epg-verify-file)
- (epg-verify-string, epg-start-sign, epg-sign-file)
- (epg-sign-string, epg-start-encrypt, epg-encrypt-file)
- (epg-encrypt-string, epg-start-export-keys)
- (epg-export-keys-to-file, epg-export-keys-to-string)
- (epg-start-import-keys, epg-import-keys-from-file)
- (epg-import-keys-from-string, epg-start-receive-keys)
- (epg-receive-keys, epg-import-keys-from-server)
- (epg-start-delete-keys, epg-delete-keys, epg-start-sign-keys)
- (epg-sign-keys, epg-start-generate-key)
- (epg-generate-key-from-file, epg-generate-key-from-string):
- Remove autoload cookie.
-
-2009-09-12 Eli Zaretskii <eliz@gnu.org>
-
- * dos-fns.el (dos-reevaluate-defcustoms): Comment out the
- reevaluation of trash-directory.
-
- * mwheel.el: Fix last change.
- (mouse-wheel-mode): New defvar.
- (mouse-wheel-mode): Remove autoload cookie.
-
-2009-09-12 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * mwheel.el (mwheel-installed-bindings): New var.
- (mouse-wheel-mode): Use it, so as to make sure we really remove all
- the bindings we set last time. Use custom-initialize-delay.
- * loadup.el: Load mwheel after term/*-win.el.
- * startup.el (command-line): Don't reevaluate mouse-wheel-down-event
- and mouse-wheel-up-event now that their first evaluation is done
- sufficiently late to be correct.
-
- * startup.el (tutorial-directory): Make it a defcustom.
- Use custom-initialize-delay rather than eval-at-startup to set it.
- * image.el (image-load-path): Make it a defcustom.
- Use custom-initialize-delay rather than eval-at-startup to set it.
- * subr.el (eval-at-startup): Remove.
- * font-lock.el (lisp-font-lock-keywords-2): Remove eval-at-startup.
-
- * subr.el (do-after-load-evaluation): Warn the user after loading an
- obsolete package.
-
-2009-09-12 Glenn Morris <rgm@gnu.org>
-
- * proced.el (proced-mark-alt): Remove alias.
- (proced-mode-map): Remove proced-mark-alt.
-
- * emacs-lisp/lisp-mode.el (emacs-lisp-mode-map): Add menu entries to
- Elint file and directory. Remove initialization entry.
-
- * emacs-lisp/elint.el (elint-file, elint-directory): New autoloaded
- commands.
- (elint-current-buffer): Set mode-line-process.
- (elint-init-env): Handle define-derived-mode.
- Fix declare-function with unspecified arglist. Guard against odd
- defalias statements (eg iso-insert's 8859-1-map).
- (elint-add-required-env): Use a temp buffer.
- (elint-form): Just print the function/macro name, not the whole form.
- Return env unchanged if we fail to parse a macro.
- (elint-forms): Guard against parse errors.
- (elint-output): New function, to handle batch mode.
- (elint-log-message): Add optional argument. Use elint-output.
- (elint-set-mode-line): New function.
-
-2009-09-12 Andreas Politz <politza@fh-trier.de> (tiny change)
-
- * emacs-lisp/elp.el (elp-not-profilable): Add more
- functions (Bug#4233).
-
-2009-09-12 Chong Yidong <cyd@stupidchicken.com>
-
- * emulation/pc-select.el (scroll-down-mark, scroll-down-nomark)
- (scroll-up-mark, scroll-up-nomark): Doc fix (Bug#4190).
-
-2009-09-11 Nick Roberts <nickrob@snap.net.nz>
-
- * progmodes/gdb-mi.el (gdb-var-list-children-regexp): Delete.
- (gdb-var-list-children): Use json parsing.
-
-2009-09-11 Daniel Colascione <dan.colascione@gmail.com>
-
- * progmodes/js.el (js--proper-indentation): Handle the case where
- char-before is null. Reported by Deniz Dogan.
-
-2009-09-11 Juanma Barranquero <lekktu@gmail.com>
-
- * emacs-lisp/cl-macs.el (help-add-fundoc-usage): Declare.
-
-2009-09-11 Daiki Ueno <ueno@unixuser.org>
-
- * epg.el (epg-cipher-algorithm-alist): Add CAMELLIA.
- (epg-digest-algorithm-alist): Add SHA224.
- (epg-context-set-passphrase-callback)
- (epg-context-set-progress-callback): Add description about
- callback function.
-
-2009-09-11 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * custom.el (custom-delayed-init-variables): New var.
- (custom-initialize-delay): New function.
- * startup.el (command-line): "Re"evaluate all vars in
- custom-delayed-init-variables. Don't reevaluate abbrev-file-name
- explicitly any more.
- * abbrev.el (abbrev-file-name): Use custom-initialize-delay
- to avoid creating a ~/.emacs.d at build-time (bug#4347).
-
- * proced.el (proced-mode-map): Prefer "m" for proced-mark (bug#4362).
-
-2009-09-11 Nick Roberts <nickrob@snap.net.nz>
-
- * progmodes/gdb-mi.el (gdb-var-update-regexp): Delete.
- (gdb-var-update-handler): Use json parsing.
-
-2009-09-11 Juanma Barranquero <lekktu@gmail.com>
-
- * vc-annotate.el (vc-annotate): Use the main file's coding-system to
- decode annotated text, regardless of language environment. (Bug#2741)
-
-2009-09-11 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * Makefile.in (autoloads): Make rmail.el writable as well.
-
-2009-09-11 Glenn Morris <rgm@gnu.org>
-
- * dired-aux.el, dired-x.el: Put autoloads in dired.el rather than
- loaddefs.el.
- * dired.el: Regenerate with extracted autoloads.
- * Makefile.in (autoloads): Make dired.el writable.
-
- * ibuf-ext.el: Put autoloads in ibuffer.el rather than loaddefs.el.
- * ibuffer.el: Regenerate with extracted autoloads.
- * Makefile.in (autoloads): Make ibuffer.el writable.
-
- * paths.el (prune-directory-list, gnus-nntp-service, rmail-file-name):
- * version.el (emacs-copyright, emacs-major-version)
- (emacs-minor-version): Reformat doc-strings for make-docfile.
-
- * apropos.el (apropos-documentation-check-doc-file): Exclude unbound
- functions and variables, since they must be stuff specific to some other
- platform.
- (apropos-print): Make mouse-click message less specific about button.
-
- * emacs-lisp/cl-macs.el (define-compiler-macro): Add a property
- that records where a macro was defined.
- * help-fns.el (describe-function-1): Mention if a function has a
- compiler-macro.
- * help-mode.el (help-function-cmacro): New button.
-
- * locate.el (top-level): Always require dired.
- (locate-mode-map): Initialize inside the defvar.
-
- * net/ange-ftp.el (dired-compress-file): Declare.
- (ange-ftp-dired-compress-file): Add doc string.
-
- * term/ns-win.el (x-display-name, x-setup-function-keys):
- Unify doc-strings with X versions.
-
-2009-09-11 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * emulation/crisp.el (crisp-mode-map): Move initialization
- into declaration.
- (crisp-mode): Use define-minor-mode.
-
- * progmodes/xscheme.el (xscheme-evaluation-commands):
- Put a :advertised-binding property rather than using
- advertised-xscheme-send-previous-expression.
- (advertised-xscheme-send-previous-expression): Declare obsolete.
- * emulation/crisp.el (crisp-mode-map): Use `undo' rather than
- `advertised-undo'.
- (crisp-mode): Add corresponding bindings to
- undo's :advertised-binding instead.
- * dired.el (dired-mode-map): Put a :advertised-binding property rather
- than using dired-advertised-find-file.
- (dired-advertised-find-file):
- * simple.el (advertised-undo):
- * wid-edit.el (advertised-widget-backward): Declare obsolete.
- (widget-keymap): Put a :advertised-binding property rather
- than using advertised-widget-backward.
- * bindings.el (ctl-x-map): Put a :advertised-binding property rather
- than using advertised-undo.
- * tutorial.el (tutorial--default-keys): Adjust accordingly.
-
-2009-09-10 Simon South <ssouth@slowcomputing.org>
-
- * progmodes/delphi.el (delphi-tab): Indent region when Transient
- Mark mode is enabled and region is active; otherwise indent or
- insert TAB as usual.
- (delphi-mode): Update description of TAB-key binding.
-
-2009-09-10 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * subr.el (define-key-rebound-commands): Mark obsolete.
- * startup.el (precompute-menubar-bindings): Remove.
- (normal-top-level): Remove obsolete code that tried to precompute
- menubar bindings.
- * loadup.el (define-key-rebound-commands): Don't bother fiddling with
- define-key-rebound-commands and precompute-menubar-bindings.
-
-2009-09-10 Teodor Zlatanov <tzz@lifelogs.com>
-
- * net/imap.el (imap-interactive-login): Better messages.
- (imap-open): Fix bug with renamed buffer on reconnect.
- (imap-authenticate): Add buffer-local imap-last-authenticator variable
- for easier debugging and cleaner code. On successful (guessed based on
- server capabilities) secondary authentication, set imap-state
- correctly.
- (imap-last-authenticator): Define imap-last-authenticator as a variable
- to avoid warnings.
-
-2009-09-10 Glenn Morris <rgm@gnu.org>
-
- * pcvs.el (cvs-mode-find-file): Use forward-line rather than goto-line.
-
- * emacs-lisp/bytecomp.el (byte-compile-function-environment): Doc fix.
- (byte-compile-file-form-autoload): Don't warn about unknown functions
- where the autoload statement comes after the use.
- (with-no-warnings): Give it a byte-hunk-handler like than of progn, so
- that any handlers inside the body (eg require) are in turn respected.
-
- * emacs-lisp/byte-opt.el (degrees-to-radians): Mark as free from side
- effects.
-
- * emacs-lisp/derived.el (define-derived-mode): Give the mode's map,
- and syntax and abbrev tables basic docs, if they don't have any.
-
- * emacs-lisp/easy-mmode.el (easy-mmode-defmap): Add doc-string.
-
- * international/mule-cmds.el (top-level): Require cl when compiling.
- (view-hello-file): Use default-value rather than
- default-enable-multibyte-characters.
-
- * progmodes/fortran.el: Move all safe and risky properties into the
- defcustoms.
-
- * mail/rmailedit.el, mail/rmailkwd.el, mail/rmailmm.el:
- * mail/rmailmsc.el, mail/rmailsort.el, mail/rmailsum.el:
- * mail/undigest.el:
- Put autoloads in rmail.el rather than loaddefs.el.
- * mail/rmail.el: Regenerate with extracted autoloads.
-
- * mail/rmailsum.el (rmail-user-mail-address-regexp): Move to rmail.el.
- * mail/rmail.el (rmail-user-mail-address-regexp): Move from rmailsum.el.
-
-2009-09-10 Nick Roberts <nickrob@snap.net.nz>
-
- Reported in thread for Bug#4375.
- * progmodes/gud.el (gud-tooltip-print-command): Use MI command
- "-data-evaluate-expression" instead of print.
- * progmodes/gdb-mi.el (gdb-tooltip-print-1): Ditto.
- (gdb-tooltip-print): Parse output from above MI command.
- (gdb): Revert 2009-08-11 change. User should detach inferior
- manually.
-
- Remove the word "separate" from IO functions as inferior
- output is now never displayed in the GUD buffer.
-
-2009-09-10 Juanma Barranquero <lekktu@gmail.com>
-
- * startup.el (command-line-normalize-file-name): On Windows and
- MS-DOS, also convert C:\/ and C:\\ (two backslashes) into C:/.
-
-2009-09-10 Juri Linkov <juri@jurta.org>
-
- * isearch.el (isearch-text-char-description): Propertize escape
- character sequences with the `escape-glyph' face. (Bug#4344)
-
- * simple.el (shell-command): Set asynchronous process filter to
- `comint-output-filter'. (Bug#4343)
-
- * progmodes/grep.el (grep-template): Add "<X>" to docstring.
- (grep-files-aliases): Add "all". Move "el" and "ch" to the top of
- the list. Move "asm" to the bottom.
- (grep-find-ignored-directories): Add `choice' with nil value
- to empty the list easily.
- (grep-find-ignored-files): New option.
- (grep-files-history): Set to nil by default instead of '("ch" "el").
- (grep-compute-defaults): Add "<X>" to `grep-template'.
- (grep-read-files): Bind new local variables `default-alias' and
- `default-extension'. Use a list of default values for the file prompt.
- (lgrep): Add `--exclude=' command line options composed from
- `grep-find-ignored-files'.
- (rgrep): Add `-name' command line options composed from
- `grep-find-ignored-files'. (Bug#4301)
-
-2009-09-09 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * diff-mode.el (diff-hunk-kill): Fix the search of the next hunk
- (bug#4368).
-
-2009-09-09 Katsumi Yamaoka <yamaoka@jpl.org>
-
- * calendar/time-date.el (autoload):
- Expand define-obsolete-function-alias into defalias and make-obsolete
- for old Emacsen that Gnus supports.
- (with-no-warnings): Define it for old Emacsen.
- (time-to-seconds): Don't use (featurep 'xemacs) to check if float-time
- is available.
- (time-to-number-of-days): Don't use (featurep 'xemacs) to check if
- float-time is available; suppress compile warning for time-to-seconds.
-
-2009-09-09 Teodor Zlatanov <tzz@lifelogs.com>
-
- * net/imap.el (imap-message-map): Docstring fix.
-
-2009-09-09 Glenn Morris <rgm@gnu.org>
-
- * ffap.el (ffap-file-at-point): Handle absolute (non-remote) files with
- line numbers too. (Bug#4374)
-
-2009-09-08 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * smerge-mode.el (smerge-remove-props, smerge-refine):
- Use with-silent-modifications (bug#4342).
-
- * subr.el (with-silent-modifications): New macro.
-
-2009-09-07 Juanma Barranquero <lekktu@gmail.com>
-
- * files.el (top-level): Require `cl' when compiling.
-
-2009-09-07 Glenn Morris <rgm@gnu.org>
-
- * files.el (auto-mode-alist): Use delphi-mode for .dpr files.
-
- * proced.el (proced-mode-map): Bind "d" to proced-mark-alt.
- (proced-mark-alt): New alias, to control the advertised key. (Bug#4362)
-
-2009-09-06 Nick Roberts <nickrob@snap.net.nz>
-
- * vc-git.el (vc-git-annotate-command): Use separator to parse
- arguments correctly.
-
-2009-09-06 Eli Zaretskii <eliz@gnu.org>
-
- * proced.el (proced-mode): Doc fix.
-
-2009-09-06 Julian Scheid <julians37@gmail.com> (tiny change)
-
- * net/tramp.el (tramp-perl-file-attributes): Print "nil" when
- lstat fails.
- (tramp-do-file-attributes-with-ls): Check for file existence at
- remote end.
- (tramp-do-file-attributes-with-stat): Likewise.
- (tramp-convert-file-attributes): Return nil when attr is nil.
-
-2009-09-05 Glenn Morris <rgm@gnu.org>
-
- * calendar/diary-lib.el (diary-entry): Add help-echo and follow-link
- properties to this button.
- (diary-fancy-display): Don't extend the button to the final newline.
- (diary-fancy-display-mode): Continue to define "q" as a local key.
-
- * calendar/cal-china.el (holiday-chinese): Make it slightly more
- efficient.
-
- * font-lock.el (lisp-font-lock-keywords-2): Add letf.
-
- * emacs-lisp/bytecomp.el (emacs-lisp-file-regexp): Doc fix.
- (byte-compile-dest-file-function): New option.
- (byte-compile-dest-file): Doc fix.
- Obey byte-compile-dest-file-function.
- (byte-compile-cl-file-p): New function.
- (byte-compile-eval): Only suppress noruntime warnings about cl functions
- if the cl-functions warning is enabled. Use byte-compile-cl-file-p.
- (byte-compile-eval): Check for non-nil byte-compile-cl-functions rather
- than for file being previously loaded.
- (byte-compile-find-cl-functions): Use byte-compile-cl-file-p.
- (byte-compile-file-form-require): Handle the case where requiring a file
- indirectly causes CL to be loaded.
-
-2009-09-05 Karl Fogel <kfogel@red-bean.com>
-
- * files.el (find-alternate-file): Run `kill-buffer-hook' manually
- before killing the old buffer, since by the time `kill-buffer' is
- run so many buffer variables have been set to nil that it may not
- behave as expected. (Bug#4061)
-
-2009-09-05 Karl Fogel <kfogel@red-bean.com>
-
- * files.el (find-alternate-file): If the old buffer is modified
- and visiting a file, behave similarly to `kill-buffer' when
- killing it, thus reverting to the pre-1.878 behavior; see
- http://lists.gnu.org/archive/html/emacs-devel/2009-09/msg00101.html
- for discussion. Also, consult `buffer-file-name' as a variable
- not as a function, for consistency with the rest of the code.
-
-2009-09-04 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-handle-insert-directory): Handle "--dired"
- also when adding a new directory.
-
- * net/tramp-compat.el (tramp-compat-line-beginning-position):
- New defun.
-
-2009-09-04 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * files.el (locate-file-completion-table): Make it provide boundary
- information, so partial-completion works better.
-
-2009-09-04 Leo <sdl.web@gmail.com> (tiny change)
-
- * mail/footnote.el (Footnote-text-under-cursor):
- Check footnote-text-marker-alist before using it (bug#4324).
-
-2009-09-04 Glenn Morris <rgm@gnu.org>
-
- * play/5x5.el, play/decipher.el, play/gametree.el, play/handwrite.el:
- * play/hanoi.el, play/landmark.el, play/mpuz.el, play/pong.el:
- * play/solitaire.el, play/tetris.el:
- Remove leading * from defcustom and defface docs.
-
- * calendar/diary-lib.el (diary-fancy-display): Only switch modes if
- necessary.
- (diary-fancy-overriding-map): New variable.
- (diary-fancy-display-mode): Set minor-mode-overriding-map-alist.
- Use view-mode.
-
- * vc-rcs.el (vc-rcs-annotate-command): Use forward-line rather than
- goto-line.
-
-2009-09-03 Glenn Morris <rgm@gnu.org>
-
- * arc-mode.el (archive-mode):
- * dos-fns.el (set-default-process-coding-system):
- * man.el (Man-getpage-in-background):
- * menu-bar.el (menu-bar-describe-menu):
- * server.el (server-process-filter):
- * startup.el (command-line):
- * tar-mode.el (tar-header-block-tokenize, tar-extract):
- * w32-fns.el (set-default-process-coding-system):
- * x-dnd.el (x-dnd-handle-file-name):
- * international/mule-cmds.el (mule-menu-keymap)
- (set-default-coding-systems, language-info-alist, set-language-info)
- (set-language-environment, standard-display-european-internal)
- (set-locale-environment):
- * international/mule-diag.el (mule-diag):
- * mail/emacsbug.el (report-emacs-bug):
- * mail/rmail.el (rmail-mode):
- * mail/sendmail.el (mail-setup):
- Use default-value rather than default-enable-multibyte-characters.
-
- * progmodes/f90.el: Move all safe properties into the defcustoms.
- (f90-get-correct-indent, f90-indent-region, f90-abbrev-start): Use memq.
-
- * calendar/appt.el (appt-check):
- * calendar/diary-lib.el (diary-set-header, diary-live-p)
- (diary-check-diary-file, diary-list-entries)
- (diary-include-other-diary-files, diary-simple-display)
- (diary-fancy-display, diary-print-entries)
- (diary-mark-included-diary-files, diary-make-entry):
- Don't call substitute-in-file-name on diary-file.
-
-2009-09-03 Eduard Wiebe <usenet@pusto.de>
- Stefan Monnier <monnier@iro.umontreal.ca>
-
- * mail/footnote.el (footnote-prefix): Make it a defcustom.
- (footnote-mode-map): Move initialization into the declaration.
- (footnote-minor-mode-map): Define it rather than changing global-map.
- (footnote-mode): Use define-minor-mode.
-
-2009-09-02 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-handle-file-attributes-with-ls)
- (tramp-do-file-attributes-with-perl)
- (tramp-do-file-attributes-with-stat): Rename from
- `tramp-handle-file-attributes-with-*'.
- (tramp-handle-file-attributes): Use them.
- (tramp-do-directory-files-and-attributes-with-perl)
- (tramp-do-directory-files-and-attributes-with-stat): Rename from
- `tramp-handle-directory-files-and-attributes-with-*'.
- (tramp-handle-directory-files-and-attributes): Use them.
- (tramp-method-out-of-band-p): Additional parameter SIZE.
- (tramp-do-copy-or-rename-file, tramp-handle-file-local-copy)
- (tramp-handle-write-region): Use it.
- (tramp-handle-insert-directory): Use "?\ " for compatibility reasons.
- (tramp-handle-vc-registered): Check, whether the first run did
- return files to be tested.
- (tramp-advice-make-auto-save-file-name): Do not call directly
- `tramp-handle-make-auto-save-file-name', because this would bypass
- the locking mechanism.
-
- * net/tramp-compat.el (top): Autoload used functions from tramp.el.
- (file-remote-p, process-file, start-file-process, set-file-times)
- (tramp-compat-file-attributes): Compatibility functions shall not
- call directly `tramp-handle-*', because this would bypass the
- locking mechanism.
- (tramp-compat-number-sequence): New defun.
-
-2009-09-02 Glenn Morris <rgm@gnu.org>
-
- * calendar/time-date.el (time-to-seconds): In Emacs, make it an obsolete
- alias for float-time.
- (time-to-number-of-days): In Emacs, use float-time.
- * net/newst-backend.el (time-add): Suppress warnings from compat
- function.
- * time.el (emacs-uptime, emacs-init-time):
- * net/rcirc.el (rcirc-keepalive, rcirc-handler-ctcp-KEEPALIVE):
- Use float-time rather than time-to-seconds.
-
- * minibuffer.el (completion-initials-expand): Fix typo.
-
- * faces.el (modeline, modeline-inactive, modeline-highlight)
- (modeline-buffer-id):
- * info.el (info-menu-5): Mark these face aliases as obsolete.
-
-2009-09-01 Nick Roberts <nickrob@snap.net.nz>
-
- * progmodes/gdb-mi.el (gdb-current-context-command): Move the
- space ...
- (gdb-gud-context-call): ... to here for pre GDB 7.0 when there is
- no "--thread" option.
- (gdb-stopped): Don't print "Switched to thread" message when it is
- unchanged.
-
-2009-09-01 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * minibuffer.el (completion-try-completion)
- (completion-all-completions): Remove ill-defined (and
- mistakenly installed and luckily never used nor documented)
- `completion-styles' property.
- (completion-initials-expand, completion-initials-all-completions)
- (completion-initials-try-completion): New functions.
- (completion-styles-alist): Add doc to each entry.
- Add new `initials' entry.
-
-2009-09-01 Nick Roberts <nickrob@snap.net.nz>
-
- * progmodes/gdb-mi.el (gdb-var-create-handler): Remove redundant
- MI command -var-evaluate-expression.
- (gdb-var-list-children-regexp): Update from regexp-1 in gdb-ui.el
- and tweak for case of string child.
- (gdb-var-list-children-handler): Update from handler-1 in gdb-ui.el.
-
-2009-09-01 Glenn Morris <rgm@gnu.org>
-
- * add-log.el (change-log-date-face, change-log-name-face)
- (change-log-email-face, change-log-file-face, change-log-list-face)
- (change-log-conditionals-face, change-log-function-face)
- (change-log-acknowledgement-face):
- * cus-edit.el (custom-invalid-face, custom-rogue-face)
- (custom-modified-face, custom-set-face, custom-changed-face)
- (custom-saved-face, custom-button-face, custom-button-pressed-face)
- (custom-documentation-face, custom-state-face, custom-comment-face)
- (custom-comment-tag-face, custom-variable-tag-face)
- (custom-variable-button-face, custom-face-tag-face)
- (custom-group-tag-face-1, custom-group-tag-face):
- * diff-mode.el (diff-header-face, diff-file-header-face)
- (diff-index-face, diff-hunk-header-face, diff-removed-face)
- (diff-added-face, diff-changed-face, diff-function-face)
- (diff-context-face, diff-nonexistent-face):
- * generic-x.el (show-tabs-tab-face, show-tabs-space-face):
- * hilit-chg.el (highlight-changes-face, highlight-changes-delete-face):
- * info.el (Info-title-1-face, Info-title-2-face, Info-title-3-face)
- (Info-title-4-face):
- * isearch.el (isearch-lazy-highlight-face):
- * log-view.el (log-view-file-face, log-view-message-face):
- * paren.el (show-paren-match-face, show-paren-mismatch-face):
- * pcvs-info.el (cvs-header-face, cvs-filename-face, cvs-unknown-face)
- (cvs-handled-face, cvs-need-action-face, cvs-marked-face)
- (cvs-msg-face):
- * smerge-mode.el (smerge-mine-face, smerge-other-face)
- (smerge-base-face, smerge-markers-face):
- * wid-edit.el (widget-documentation-face, widget-button-face)
- (widget-field-face, widget-single-line-field-face)
- (widget-inactive-face, widget-button-pressed-face):
- * woman.el (woman-italic-face, woman-bold-face, woman-unknown-face)
- (woman-addition-face):
- * eshell/em-ls.el (eshell-ls-directory-face, eshell-ls-symlink-face)
- (eshell-ls-executable-face, eshell-ls-readonly-face)
- (eshell-ls-unreadable-face, eshell-ls-special-face)
- (eshell-ls-missing-face, eshell-ls-archive-face)
- (eshell-ls-backup-face, eshell-ls-product-face)
- (eshell-ls-clutter-face):
- * eshell/em-prompt.el (eshell-prompt-face):
- * eshell/esh-test.el (eshell-test-ok-face, eshell-test-failed-face):
- * obsolete/old-whitespace.el (whitespace-highlight-face):
- * progmodes/antlr-mode.el (antlr-font-lock-default-face)
- (antlr-font-lock-keyword-face, antlr-font-lock-syntax-face)
- (antlr-font-lock-ruledef-face, antlr-font-lock-tokendef-face)
- (antlr-font-lock-ruleref-face, antlr-font-lock-tokenref-face)
- (antlr-font-lock-literal-face):
- * progmodes/ebrowse.el (ebrowse-tree-mark-face)
- (ebrowse-root-class-face, ebrowse-file-name-face)
- (ebrowse-default-face, ebrowse-member-attribute-face)
- (ebrowse-member-class-face, ebrowse-progress-face):
- * progmodes/make-mode.el (makefile-space-face):
- * progmodes/sh-script.el (sh-heredoc-face):
- * textmodes/flyspell.el (flyspell-incorrect-face)
- (flyspell-duplicate-face):
- * textmodes/tex-mode.el (tex-math-face, tex-verbatim-face):
- * textmodes/texinfo.el (texinfo-heading-face):
- Mark face aliases with "-face" suffix as obsolete.
-
- * mail/feedmail.el (file-name-buffer-file-type-alist): Define for
- compiler.
-
- * net/eudc-bob.el (eudc-bob-generic-menu, eudc-bob-image-menu)
- (eudc-bob-sound-menu): Use defvar rather than defconst, since
- easy-menu-define wants to modify these.
-
- * net/net-utils.el (nslookup): Use make-comint rather than comint-run.
-
- * net/browse-url.el (browse-url-file-url):
- * term/internal.el (dos-codepage-setup):
- Use default-value rather than default-enable-multibyte-characters.
-
- * progmodes/etags.el (etags-goto-tag-location):
- * progmodes/flymake.el (flymake-highlight-line)
- (flymake-goto-file-and-line, flymake-goto-line):
- * progmodes/gdb-mi.el (gdb-mouse-until, gdb-mouse-jump)
- (gdb-goto-breakpoint):
- * progmodes/idlw-shell.el (idlwave-shell-move-to-bp):
- * progmodes/python.el (python-find-function)
- (python-pdbtrack-track-stack-file):
- * progmodes/verilog-mode.el (verilog-surelint-off):
- * term/ns-win.el (ns-open-file-select-line):
- * textmodes/bibtex.el (bibtex-validate, bibtex-validate-globally):
- Use forward-line rather than goto-line.
-
- * textmodes/reftex-cite.el (reftex-offer-bib-menu):
- * textmodes/reftex-index.el (reftex-display-index):
- * textmodes/reftex-ref.el (reftex-offer-label-menu):
- * textmodes/reftex-toc.el (reftex-toc):
- Remove unnecessary bindings of default-major-mode (all are followed by
- major-mode check and possible mode switch).
-
-2009-08-31 Nick Roberts <nickrob@snap.net.nz>
-
- * progmodes/gdb-mi.el (gdb-breakpoints-list-handler-custom):
- Handle watchpoints (bug#4282).
- (def-gdb-thread-buffer-command): Enable thread to be selected by
- clicking without selecting threads buffer first.
- (gdb-current-context-command): Use selected frame so that "up",
- "down" etc work in the GUD buffer.
- (gdb-update): Find selected frame before rendering stack buffer.
- (gdb-frame-handler): Set gdb-frame-number for stack buffer.
-
-2009-08-31 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * progmodes/sym-comp.el (displayed-completions): Remove.
- (symbol-complete): Use minibuffer-complete.
-
-2009-08-31 Glenn Morris <rgm@gnu.org>
-
- * emacs-lisp/byte-run.el (define-obsolete-face-alias): New macro.
-
- * apropos.el (apropos-symbols-internal):
- Handle (obsolete) face aliases.
-
- * faces.el (describe-face): Adjust the output format to be more like
- describe-variable, and to mention (obsolete) face aliases.
- Adjust the whitespace so that help-setup-xref works.
-
- * calendar/calendar.el (calendar-today-face, diary-face, holiday-face):
- * calendar/diary-lib.el (diary-button-face):
- Mark these face aliases as obsolete.
-
- * calendar/calendar.el (calendar-today): Doc fix.
-
-2009-08-31 Nick Roberts <nickrob@snap.net.nz>
-
- * progmodes/gdb-mi.el (gdb-control-all-threads)
- (gdb-control-current-thread): Force tool bar update.
- (gdb-non-stop-handler): New function.
- (gdb-init-1): Use it to test if non-stop mode is supported.
- Remove unused gdbmi buffer type.
-
-2009-08-30 Kevin Rodgers <kevin.d.rodgers@gmail.com>
-
- * progmodes/grep.el (grep-read-files): Strip trailing <N> from
- buffer names not visiting a file (e.g. cloned buffers). (Bug#4210)
-
-2009-08-30 Nick Roberts <nickrob@snap.net.nz>
-
- * comint.el (comint-exec-1): Check command is non-null first.
- Part of gdb-mi.el change (2009-08-28).
-
-2009-08-30 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * emacs-lisp/lisp.el (lisp-complete-symbol): Use minibuffer-complete.
-
-2009-08-30 Juanma Barranquero <lekktu@gmail.com>
-
- * subr.el (do-after-load-evaluation): Fix last change: use `mapc'
- instead of `dolist' to avoid a recursive require when bootstrapping.
-
-2009-08-30 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * emacs-lisp/lisp.el (field-complete): Use minibuffer-complete.
-
- * net/ldap.el (ldap-search-internal): Use with-current-buffer and push.
-
- * net/imap.el (imap-send-command): Simplify.
- (imap-wait-for-tag): point-max -> buffer-size.
-
- * net/ange-ftp.el (internal-ange-ftp-mode): Use define-derived-mode.
-
- * emacs-lisp/easy-mmode.el (define-minor-mode): Don't use symbol-value
- with constant argument.
-
- * emacs-lisp/debug.el (debugger-setup-buffer): Make it multibyte.
-
- * emacs-lisp/cl.el (cl-macro-environment): Don't define it here.
-
- * emacs-lisp/checkdoc.el (checkdoc-force-history-flag):
- Change default, since most of our files don't have a history.
- (checkdoc-display-status-buffer): Don't use a hidden buffer to show to
- the user.
-
- * emacs-lisp/bytecomp.el (byte-compile-interactive-only-functions):
- Add comint-run.
-
- * calc/calc.el: Improve commenting convention.
- (calc-digit-map, toplevel): Simplify.
-
- * comint.el (comint-insert-input): Be careful to only set point if we
- don't delegate to some other command.
-
- * proced.el (proced-signal-list): Make it an alist.
- (proced-grammar-alist): Capitalize names.
- (proced-send-signal): Use a non-hidden buffer (since it's displayed).
- Disable undo manually and make it read-only.
- Use completion-annotate-function.
-
- * minibuffer.el (minibuffer-message): If the current buffer is not
- a minibuffer, insert the message in the echo area rather than at the
- end of the buffer.
- (completion-annotate-function): New variable.
- (minibuffer-completion-help): Use it.
- (completion--embedded-envvar-table): Environment vars are
- always case-sensitive.
-
-2009-08-30 Glenn Morris <rgm@gnu.org>
-
- * progmodes/fortran.el (fortran-start-prog-re): New constant, extracted
- from fortran-current-defun.
- (fortran-beginning-of-subprogram): Be more precise about finding the
- start, to avoid an infinite loop in end-of-defun. (Bug#4259)
- (fortran-end-of-subprogram): Simplify.
- (fortran-current-defun): Use fortran-start-prog-re.
-
-2009-08-29 Juanma Barranquero <lekktu@gmail.com>
-
- * subr.el (do-after-load-evaluation): Simplify.
-
-2009-08-29 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc.el (vc-print-log-internal): Move RCS/CVS specific code ...
-
- * vc-rcs.el (vc-rcs-print-log-cleanup): ... here. New function.
- (vc-rcs-print-log): Use it.
-
- * vc-cvs.el (vc-cvs-print-log): Use vc-rcs-print-log-cleanup.
-
-2009-08-29 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * paths.el (abbrev-file-name): Move to abbrev.el.
- * abbrev.el (abbrev-file-name): Move from paths.el.
- Obey user-emacs-directory.
- * calc/calc.el (calc-settings-file): Don't autoload and instead obey
- user-emacs-directory.
- * dos-fns.el (dos-reevaluate-defcustoms): Don't reevaluate
- abbrev-file-name and calc-settings-file any more.
- * startup.el (command-line): Recompute abbrev-file-name and
- abbreviated-home-dir.
- (normal-no-mouse-startup-screen): Improve the generic code and get rid
- of the special code for when C-h bindings haven't been changed.
- (display-startup-echo-area-message): Use with-current-buffer.
- (command-line-1): Use a list of strings, rather than a list of lists
- of strings for longopts.
-
- * files.el (get-free-disk-space): Use / for default-directory.
-
- * textmodes/ispell.el (ispell-accept-output, ispell-command-loop):
- Use with-current-buffer.
-
- * emacs-lisp/bytecomp.el (byte-compile-const-symbol-p):
- Recognize immutable variables like most-positive-fixnum.
- (byte-compile-setq-default): Check and warn if trying to assign
- to an immutable variable, or a non-variable.
-
- * progmodes/cc-vars.el (c-comment-continuation-stars):
- * progmodes/cc-engine.el (c-looking-at-bos):
- * progmodes/cc-cmds.el (c-toggle-auto-state)
- (c-forward-into-nomenclature, c-backward-into-nomenclature)
- (c-comment-line-break-function): Add version of obsolescence.
-
-2009-08-28 Juri Linkov <juri@jurta.org>
-
- * files.el (magic-fallback-mode-alist): Add ZIP magic number
- associated with `archive-mode'.
-
- * image.el (image-type-header-regexps): Use only JPEG magic number
- to determine JPEG images, and don't use `image-jpeg-p' because
- Emacs can display non-JFIF non-Exif JPEG images.
-
-2009-08-28 Juanma Barranquero <lekktu@gmail.com>
-
- * arc-mode.el (archive-mode):
- * emacs-lisp/re-builder.el (re-builder-unload-function):
- Protect against the default value of `major-mode' being nil.
-
-2009-08-28 Juanma Barranquero <lekktu@gmail.com>
-
- * international/ucs-normalize.el (ucs-normalize-sort, quick-check-list):
- Fix typos in docstrings.
-
- * progmodes/js.el (js--macro-decl-re): Doc fix.
- (js--plain-method-re, js--split-name): Refloc docstring.
- (js--class-styles, js--make-merged-item, js--splice-into-items):
- Fix typos in docstrings; reflow docstrings.
- (js--maybe-join, js--function-prologue-beginning, js--flush-caches)
- (js--variable-decl-matcher, js--inside-pitem-p)
- (js--parse-state-at-point, js--get-all-known-symbols)
- (js--symbol-history, js-find-symbol, js--js-references)
- (js--moz-interactor, js--js-encode-value, js--read-tab):
- Fix typos in docstrings.
-
-2009-08-28 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * textmodes/reftex.el (reftex-get-file-buffer-force):
- * progmodes/verilog-mode.el (verilog-batch-execute-func):
- * emulation/viper.el (viper-go-away, viper-set-hooks):
- * emacs-lisp/re-builder.el (re-builder-unload-function):
- * emacs-lisp/bytecomp.el (byte-compile-file):
- * ses.el (ses-unload-function):
- * hexl.el (hexl-find-file):
- * files.el (normal-mode):
- * ehelp.el (with-electric-help):
- * autoinsert.el (auto-insert-alist):
- * arc-mode.el (archive-mode):
- Use (default-value 'major-mode) instead of default-major-mode.
-
- * textmodes/ispell.el (ispell-check-version, ispell-send-string):
- * international/mule.el (load-with-code-conversion):
- * emacs-lisp/debug.el (debug):
- * ediff-vers.el (ediff-rcs-get-output-buffer):
- * dired.el (dired-internal-noselect): Don't let-bind
- default-major-mode around code that doesn't use it.
- E.g. buffer creation via get-buffer-create doesn't use it.
-
-2009-08-28 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (all): Replace "'(lambda" by "(lambda".
- (tramp-handle-file-local-copy): Unset `file-name-handler-alist'
- when writing the temp file. Otherwise, epa-file gets confused.
- (tramp-register-file-name-handlers): Make it a defun. Move also
- `epa-file-handler' to the front of `file-name-handler-alist'.
-
-2009-08-28 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * net/tramp.el (tramp-shell-prompt-pattern): Allow a prompt to
- start right after a ^M.
- (tramp-root-regexp, tramp-completion-file-name-regexp-unified)
- (tramp-completion-file-name-regexp-separate)
- (tramp-completion-file-name-regexp-url): Use \\` and \\'.
- (tramp-handle-file-attributes, tramp-set-file-uid-gid):
- Don't modify last-coding-system-used by accident.
- (tramp-completion-file-name-handler): Apply the checks here,
- instead during registration.
- (tramp-register-file-name-handlers): Rename from
- `tramp-register-file-name-handler'. Register both
- `tramp-file-name-handler' and `tramp-completion-file-name-handler'.
- (tramp-register-completion-file-name-handler): Remove. (Bug#4260)
-
-2009-08-28 Nick Roberts <nickrob@snap.net.nz>
-
- * progmodes/gdb-mi.el (gdb-use-separate-io-buffer):
- Remove variable ...
- (gdb-init-1, gdb-display-separate-io-buffer)
- (gdb-frame-separate-io-buffer, gdb-setup-windows): ... and
- references to it.
- (gdb-inferior-io-mode): Use make-comint-in-buffer.
- (gdb-inferior-filter): Use comint-output-filter to stop
- echoing and remove ^M characters.
-
-2009-08-28 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * emulation/viper-init.el (viper-restore-cursor-type):
- * emulation/cua-base.el (cua--update-indications):
- Replace default-cursor-type with (default-value 'cursor-type).
-
- * mail/sendmail.el (mail-recover-1):
- * international/mule-diag.el (describe-current-coding-system-briefly)
- (describe-current-coding-system):
- * international/mule-cmds.el (select-safe-coding-system)
- (select-message-coding-system)
- (set-language-environment-coding-systems, set-locale-environment):
- * hexl.el (hexl-insert-multibyte-char):
- * dos-w32.el (find-buffer-file-type-coding-system):
- * simple.el (what-cursor-position):
- Replace uses of default-buffer-file-coding-system
- with (default-value 'buffer-file-coding-system).
-
- * emacs-lisp/edebug.el (edebug-display, edebug-outside-excursion):
- Replace uses of default-cursor-in-non-selected-windows
- with (default-value 'cursor-in-non-selected-windows).
- Use with-current-buffer.
-
- * mail/feedmail.el: Use CL macros.
- (feedmail-run-the-queue, feedmail-send-it-immediately):
- * dos-w32.el (find-buffer-file-type): Replace uses of
- default-buffer-file-type with (default-value 'buffer-file-type).
-
-2009-08-28 Glenn Morris <rgm@gnu.org>
-
- * calendar/diary-lib.el (diary-list-entries, diary-goto-entry)
- (diary-show-all-entries, diary-mark-entries, diary-make-entry):
- Use default-value of major-mode rather than default-major-mode.
-
-2009-08-27 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * Makefile.in (update-elcfiles): Report left over elc files.
-
- * mail/mailalias.el (build-mail-aliases): Use with-temp-buffer,
- expand-file-name and with-current-buffer.
- (mail-get-names, mail-directory): Use with-current-buffer.
-
- * vc.el (vc-read-revision): New function.
- (vc-version-diff, vc-merge): Use it.
-
-2009-08-27 Sam Steingold <sds@gnu.org>
-
- * simple.el (kill-do-not-save-duplicates): New user option.
- (kill-new): When it is non-nil, and the new string is the same as
- the latest kill, set replace to t to avoid duplicates in kill-ring.
-
-2009-08-27 Julian Scheid <julians37@gmail.com> (tiny change)
-
- * net/tramp.el (tramp-handle-process-file): Do not flush all
- caches when `process-file-side-effects' is set.
- (tramp-handle-vc-registered): Use `tramp-get-file-exists-command'
- instead of `tramp-find-file-exists-command'.
- Unset `process-file-side-effects'.
-
-2009-08-27 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-methods): New method "rsyncc".
- (top): Add completion function for "rsyncc".
- (tramp-message-show-message): New defvar.
- (tramp-message, tramp-error): Use it.
- (tramp-do-copy-or-rename-file-directly): Extend check for direct
- remote copying.
- (tramp-do-copy-or-rename-file-out-of-band): Handle new
- `tramp-methods' entry `copy-env' of "rsyncc".
- (tramp-vc-registered-read-file-names): New defconst.
- (tramp-vc-registered-file-names): New defvar.
- (tramp-handle-vc-registered): Implement optimization strategy.
- (tramp-run-real-handler): Add `tramp-vc-file-name-handler'.
- (tramp-vc-file-name-handler): New defun.
- (tramp-get-ls-command, tramp-get-test-command)
- (tramp-get-file-exists-command, tramp-get-remote-ln)
- (tramp-get-remote-perl, tramp-get-remote-stat)
- (tramp-get-remote-id): Remove superfluous `with-current-buffer'.
-
- * net/tramp-cache.el (top): Autoload `tramp-time-less-p'.
- (tramp-cache-inhibit-cache): Extend doc string. It allows also
- timestamps.
- (tramp-get-file-property): Check for timestamps in
- `tramp-cache-inhibit-cache'.
- (tramp-set-file-property): Write timestamp.
-
-2009-08-27 ARISAWA Akihiro <ari@mbf.ocn.ne.jp> (tiny change)
-
- * language/japan-util.el (japanese-symbol-table): Add entries for
- cp932-2-byte.
-
- * international/characters.el: Add category `j' to cp932-2-byte.
-
-2009-08-27 Kenichi Handa <handa@m17n.org>
-
- * international/fontset.el (build-default-fontset-data): New macro.
- (setup-default-fontset): Use build-default-fontset-data for CJK,
- tibetan, ethiopic, and ipa.
-
-2009-08-27 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * cus-start.el (default-major-mode): Customize `major-mode' instead.
- (enable-multibyte-characters): Not customizable any more.
-
- * subr.el (default-mode-line-format, default-header-line-format)
- (default-line-spacing, default-abbrev-mode, default-ctl-arrow)
- (default-direction-reversed, default-truncate-lines)
- (default-left-margin, default-tab-width, default-case-fold-search)
- (default-left-margin-width, default-right-margin-width)
- (default-left-fringe-width, default-right-fringe-width)
- (default-fringes-outside-margins, default-scroll-bar-width)
- (default-vertical-scroll-bar, default-indicate-empty-lines)
- (default-indicate-buffer-boundaries, default-fringe-indicator-alist)
- (default-fringe-cursor-alist, default-scroll-up-aggressively)
- (default-scroll-down-aggressively, default-fill-column)
- (default-cursor-type, default-buffer-file-type)
- (default-cursor-in-non-selected-windows)
- (default-buffer-file-coding-system, default-major-mode)
- (default-enable-multibyte-characters): Mark as obsolete.
-
-2009-08-27 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc-dir.el (vc-dir-update): Remove debug helper.
-
- * vc-cvs.el (vc-cvs-update-changelog): Fix typo.
-
-2009-08-26 Sam Steingold <sds@gnu.org>
-
- * simple.el (save-interprogram-paste-before-kill): New user option.
- (kill-new): When `save-interprogram-paste-before-kill' is non-nil,
- save the interprogram-paste into kill-ring before overriding it
- with the Emacs kill.
-
-2009-08-26 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc.el (vc-trunk-p): Rename to vc-rcs-trunk-p and move to vc-rcs.el.
- (vc-minor-part): Rename to vc-rcs-minor-part and move to vc-rcs.el.
- (vc-default-previous-revision): Rename to vc-rcs-previous-revision
- and move to vc-rcs.el.
- (vc-default-next-revision): Rename to vc-rcs-next-revision and
- move to vc-rcs.el.
- (vc-cvs-update-changelog): Move to vc-cvs.el, use vc-call-backend.
- (vc-rcs-update-changelog): Remove.
- (vc-update-changelog-rcs2log): Rename to vc-rcs-update-changelog
- and move to vc-rcs.el.
-
- * vc-rcs.el (vc-rcs-latest-on-branch-p, vc-rcs-checkin)
- (vc-rcs-checkout, vc-rcs-rollback): Adjust for the vc-rcs-trunk-p
- renaming.
- (vc-rcs-trunk-p, vc-rcs-minor-part, vc-rcs-previous-revision)
- (vc-rcs-next-revision, vc-rcs-update-changelog): Move here from
- vc.el, renamed to be RCS specific.
-
- * vc-cvs.el (vc-cvs-previous-revision, vc-cvs-next-revision):
- New functions.
- (vc-cvs-update-changelog): Move here from vc.el.
-
- * vc-sccs.el (vc-sccs-previous-revision, vc-sccs-next-revision):
- New functions.
-
-2009-08-26 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * emacs-lisp/bytecomp.el (byte-compile-lapcode): Fix up last change.
-
-2009-08-26 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc-git.el (vc-git-register): Use "git add" for directories.
- (vc-git-stash, vc-git-stash-show): New functions.
- (vc-git-extra-menu-map): Bind them.
-
- * vc-dir.el (vc-dir-node-directory, vc-dir-update): Get the parent
- directory correctly in case the item is a directory itself.
-
- * vc.el: Document the desired behavior for reverted files in the
- `added' state.
- (vc-default-prettify-state-info): Remove function, unused.
-
- * vc-bzr.el (vc-bzr-prettify-state-info): Remove function, unused.
-
-2009-08-26 Glenn Morris <rgm@gnu.org>
-
- * bindings.el (standard-mode-line-format): Reposition dashes in
- which-func entry. (Bug#4217)
-
- * files.el (enable-local-variables, enable-local-eval)
- (safe-local-variable-values, safe-local-eval-forms): Mark as risky in
- the defcustoms.
- (auto-mode-alist, ignored-local-variables)
- (save-some-buffers-action-alist): Move risky declarations to the
- definitions.
- (dabbrev-case-fold-search, dabbrev-case-replace, display-time-string)
- (font-lock-defaults, format-alist, imenu--index-alist)
- (imenu-generic-expression, input-method-alist, minor-mode-alist)
- (mode-line-buffer-identification, mode-line-client, mode-line-modes)
- (mode-line-modified, mode-line-mule-info, mode-line-position)
- (mode-line-process, mode-line-remote, outline-level)
- (parse-time-rules, rmail-output-file-alist)
- (special-display-buffer-names, vc-mode):
- Move risky declarations to the relevant files.
- * bindings.el (mode-line-client, mode-line-mule-info, mode-line-remote)
- (mode-line-modified, mode-line-process, mode-line-position)
- (mode-line-modes, mode-line-buffer-identification, minor-mode-alist)
- * font-core.el (font-lock-defaults):
- * format.el (format-alist):
- * vc-hooks.el (vc-mode):
- * window.el (special-display-buffer-names):
- * international/mule-cmds.el (input-method-alist):
- Define riskiness here (dumped file) rather than in files.el.
- * dabbrev.el (dabbrev-case-fold-search, dabbrev-case-replace):
- * imenu.el (imenu-generic-expression, imenu--index-alist):
- * outline.el (outline-level):
- * time.el (display-time-string):
- * calendar/parse-time.el (parse-time-rules):
- * mail/rmailout.el (rmail-output-file-alist):
- Autoload riskiness here, rather than placing in files.el.
-
-2009-08-26 Andreas Schwab <schwab@linux-m68k.org>
-
- * emacs-lisp/bytecomp.el (byte-compile-lapcode): Signal overflow.
-
-2009-08-25 Michael Albinus <michael.albinus@gmx.de>
-
- * simple.el (process-file-side-effects): New defvar.
-
- * dired-aux.el (dired-show-file-type):
- * vc.el (vc-diff-internal):
- * vc-arch.el (vc-arch-diff):
- * vc-bzr.el (vc-bzr-sha1, vc-bzr-revision-completion-table):
- * vc-cvs.el (vc-cvs-state, vc-cvs-diff, vc-cvs-revision-table):
- * vc-git.el (vc-git-registered, vc-git-working-revision)
- (vc-git-find-revision, vc-git-diff, vc-git-revision-table)
- (vc-git--empty-db-p):
- * vc-hooks.el (vc-user-login-name):
- * vc-svn.el (vc-svn-registered, vc-svn-state)
- (vc-svn-dir-extra-headers, vc-svn-find-revision):
- * progmodes/grep.el (grep-probe): Let-bind
- `process-file-side-effects' with nil.
-
- * net/dbus.el (dbus-ping): Add optional parameter TIMEOUT.
-
- * net/tramp-gvfs.el (top): Use timeout of 100 msec pinging GVFS
- daemon. Replace ping by checking for running service for bluez
- and zeroconf. (Bug#4239)
-
-2009-08-25 Kevin Ryde <user42@zip.com.au>
-
- * net/dig.el (dig): Add autoload cookie.
-
-2009-08-25 Glenn Morris <rgm@gnu.org>
-
- * emacs-lisp/bytecomp.el (byte-compile-eval): Fix test for cl in
- load-history for absolute file-names.
- (byte-compile-file-form-require): Warn about use of the cl package.
-
- * format.el (format-alist): Doc fix.
-
- * play/bubbles.el (top-level): Don't require cl at run-time.
-
- * progmodes/verilog-mode.el (top-level): Don't require lucid (and hence
- run-time cl).
-
-2009-08-24 Dmitry Dzhus <dima@sphinx.net.ru>
-
- * progmodes/gdb-mi.el (gdb-mapcar*): Replacement for `mapcar*'
- from cl package.
- (gdb-table-add-row, gdb-table-string): Use `gdb-mapcar*'.
-
-2009-08-24 Jay Belanger <jay.p.belanger@gmail.com>
-
- * calc/calc-alg.el (math-trig-rewrite)
- (math-hyperbolic-trig-rewrite): New functions.
- (calc-simplify): Simplify trig functions when asked.
-
-2009-08-24 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * diff-mode.el (diff-find-source-location): Avoid goto-line.
-
-2009-08-24 Kenichi Handa <handa@m17n.org>
-
- * language/ind-util.el (mapthread): Delete it.
- (combinatorial): New function.
- (indian--puthash-cv): Use combinatorial instead of mapthread.
-
-2009-08-22 Kevin Ryde <user42@zip.com.au>
-
- * emacs-lisp/checkdoc.el (checkdoc-force-history-flag)
- (checkdoc-arguments-in-order-flag): Add safe-local-variable booleanp.
- (checkdoc-symbol-words): Add safe-local-variable for list of strings.
- Clarify docstring that the value is strings not symbols.
- (checkdoc-list-of-strings-p): New function.
-
-2009-08-22 Glenn Morris <rgm@gnu.org>
-
- * files.el (auto-mode-alist):
- * hippie-exp.el (he-concat-directory-file-name):
- * lpr.el (lpr-windows-system, printer-name):
- * ls-lisp.el (ls-lisp-emulation, ls-lisp-use-insert-directory-program):
- * ps-print.el (ps-windows-system):
- * startup.el (command-line):
- * emulation/viper-ex.el (viper-glob-function):
- * international/mule-cmds.el (set-language-environment-coding-systems):
- * net/ange-ftp.el (ange-ftp-write-region):
- * obsolete/fast-lock.el (fast-lock-cache-name):
- Remove code for defunct system-types emx, macos, mswindows, next-mach,
- unisoft-unix, vax-vms, win32, w32.
-
- * calendar/diary-lib.el (diary-mark-entries-1): Only mark all days of a
- given name if the pattern is not more specific.
-
- * calendar/lunar.el (lunar-phase-names): New option.
- (lunar-phase): Doc fix.
- (lunar-cycles-per-year): New constant.
- (lunar-index): New function.
- (lunar-phase-list, diary-lunar-phases): Use lunar-index.
- (lunar-phase-name): Use lunar-phase-names.
- (calendar-lunar-phases): Use format.
- (lunar-new-moon-on-or-after): Use lunar-cycles-per-year.
-
- * progmodes/cperl-mode.el (cperl-imenu-name-and-position):
- Copy imenu-example--name-and-position function here for own use.
- (cperl-xsub-scan): Use cperl-imenu-name-and-position.
-
- * bs.el (bs--redisplay):
- * cus-edit.el (custom-redraw):
- * ibuffer.el (ibuffer-bury-buffer):
- * server.el (server-goto-line-column):
- * startup.el (command-line-1):
- * strokes.el (strokes-xpm-for-stroke):
- * term.el (term-display-buffer-line):
- * view.el (View-goto-line):
- * calc/calc.el (calc-do, calc-trail-buffer):
- * play/gamegrid.el (gamegrid-add-score-insecure):
- * progmodes/ada-mode.el (ada-compile-goto-error):
- * progmodes/ada-xref.el (ada-xref-find-in-modified-ali):
- (ebrowse-select-1st-to-9nth):
- * progmodes/cperl-mode.el (cperl-time-fontification):
- * progmodes/ebrowse.el (ebrowse-toggle-file-name-display)
- * progmodes/gud.el (gud-display-line):
- (idlwave-shell-display-line):
- * progmodes/idlw-shell.el (idlwave-shell-goto-frame)
- * progmodes/make-mode.el (makefile-browser-toggle):
- (vhdl-speedbar-port-copy, vhdl-compose-components-package):
- * progmodes/vhdl-mode.el (vhdl-speedbar-find-file)
- * textmodes/picture.el (picture-draw-rectangle):
- * textmodes/reftex-index.el (reftex-index-goto-letter):
- (reftex-select-jump-to-previous):
- * textmodes/reftex-sel.el (reftex-find-start-point)
- * textmodes/reftex-toc.el (reftex-toc, reftex-toc-restore-region):
- (rst-straighten-deco-spacing, rst-section-tree, rst-toc):
- * textmodes/rst.el (rst-promote-region, rst-straighten-decorations)
- * textmodes/tex-mode.el (tex-compilation-parse-errors):
- * textmodes/two-column.el (2C-associated-buffer):
- Use forward-line rather than goto-line.
-
- * emulation/vi.el (vi-goto-line): Don't warn about non-interactive
- goto-line.
-
- * international/ucs-normalize.el (nfd, decomposition-translation-alist)
- (decomposition-char-recursively, alist-list-to-vector, quick-check-list)
- (quick-check-list-to-regexp): Declare.
-
- * progmodes/make-mode.el (makefile-browser-insert-selection):
- Use goto-char rather than goto-line.
-
- * progmodes/prolog.el (compilation-error-regexp-alist)
- (compilation-forget-errors): Declare.
-
-2009-08-22 Juri Linkov <juri@jurta.org>
-
- * progmodes/grep.el (lgrep, rgrep): At the beginning
- set `dir' to `default-directory' unless `dir' is a non-nil
- readable directory. (Bug#4052)
- (lgrep, rgrep): Change a weird way to report an error
- from using `read-string' to using `error'.
- Instead of using interactive arguments in the function body,
- add new argument `confirm'.
-
-2009-08-21 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * textmodes/remember.el (remember-buffer):
- * progmodes/cperl-mode.el (cperl-vc-header-alist):
- * calendar/icalendar.el (icalendar-convert-diary-to-ical)
- (icalendar-extract-ical-from-buffer):
- * net/newst-treeview.el (newsticker-groups-filename):
- * net/newst-backend.el (newsticker-cache-filename):
- * speedbar.el (speedbar-update-speed, speedbar-navigating-speed)
- (speedbar-ignored-path-expressions, speedbar-ignored-path-regexp)
- (speedbar-add-ignored-path-regexp, speedbar-line-path)
- (speedbar-buffers-line-path, speedbar-path-line)
- (speedbar-buffers-line-path):
- * epg.el (epg-passphrase-callback-function, epg-start-sign-keys)
- (epg-sign-keys):
- * epa.el (epa-display-verify-result):
- * progmodes/pascal.el (pascal-outline): Add version of obsolescence.
-
-2009-08-21 Glenn Morris <rgm@gnu.org>
-
- * progmodes/js.el (inferior-moz-process): Fix declaration.
-
- * imenu.el (imenu-example--name-and-position): Fix obsolescence message.
-
- * obsolete/rnewspost.el (news-mail-reply):
- Use goto-char rather than goto-line.
-
- * term/ns-win.el (ns-open-file-select-line):
- Use line-beginning-position rather than goto-line.
-
- * apropos.el (apropos-command):
- * ehelp.el (electric-helpify):
- * printing.el (pr-show-setup):
- * strokes.el (strokes-help):
- * tutorial.el (tutorial--describe-nonstandard-key)
- (tutorial--detailed-help):
- * woman.el (woman-mini-help, woman-display-extended-fonts):
- * calc/calc-help.el (calc-describe-key):
- * emulation/edt.el (edt-electric-helpify):
- * international/mule-diag.el (mule-diag):
- * play/yow.el (apropos-zippy):
- * progmodes/python.el (python-describe-symbol):
- * progmodes/vhdl-mode.el (vhdl-doc-variable, vhdl-doc-mode):
- * textmodes/table.el (*table--cell-describe-mode)
- (*table--cell-describe-bindings):
- Use help-print-return-message rather than the now obsolete alias.
-
- * calendar/cal-move.el (calendar-cursor-to-nearest-date)
- (calendar-cursor-to-visible-date):
- * play/5x5.el (5x5-position-cursor):
- * play/decipher.el (decipher):
- * play/gomoku.el (gomoku-goto-xy):
- * play/landmark.el (lm-goto-xy):
- * play/mpuz.el (mpuz-paint-errors, mpuz-paint-statistics)
- (mpuz-paint-digit):
- Use forward-line, not goto-line.
-
- * mail/rmail.el (rmail-obsolete): Delete custom group.
- (rmail-pop-password, rmail-pop-password-required): Make into aliases.
- (rmail-remote-password, rmail-remote-password-required):
- Remove unneeded :set-after and :set properties.
-
-2009-08-21 Michael Albinus <michael.albinus@gmx.de>
-
- * net/dbus.el (top): Initialize only when `dbusbind' is loaded.
-
-2009-08-21 Dan Nicolaescu <dann@ics.uci.edu>
-
- * loadup.el: Remove leftover macos code.
-
- * vc-git.el (vc-git-annotate-command): Run asynchronously.
- Explicitly pass the date format to git blame so that user local
- so that the output format can be parsed.
-
-2009-08-20 Michael Albinus <michael.albinus@gmx.de>
-
- * net/dbus.el (top): Don't check for (getenv
- "DBUS_SESSION_BUS_ADDRESS"). It's done in dbusbind.c now.
-
-2009-08-19 Magnus Henoch <magnus.henoch@gmail.com>
-
- * log-edit.el (log-edit-strip-single-file-name): New var.
- (log-edit-insert-changelog): Use it. Bug#3571
-
-2009-08-19 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * subr.el (read-passwd): Use read-key so keypad keys work as well.
- Bug#3287
-
- * help.el (help-print-return-message): Rename from
- print-help-return-message.
-
- * log-view.el (log-view-mode-map): Remove `q' binding, and unreliable
- cvs-mode-map parent hack.
- (log-view-mode): Derive from special-mode.
-
- * linum.el (linum-mode): window-size-change-functions is redundant.
- Adapt to new window-configuration-change-hook behavior.
- (linum-after-size, linum-after-config): Remove.
-
- * imenu.el (imenu-example--name-and-position)
- (imenu-example--lisp-extract-index-name)
- (imenu-example--create-lisp-index, imenu-example--create-c-index):
- Mark as obsolete.
-
- * progmodes/prolog.el (inferior-prolog-error-regexp-alist): New var.
- (inferior-prolog-mode): Use it.
- (inferior-prolog-load-file): Reset list of errors.
-
-2009-08-19 ARISAWA Akihiro <ari@mbf.ocn.ne.jp> (tiny change)
-
- * language/tibetan.el ("Tibetan"): Fix sample-text entry.
-
- * language/tai-viet.el ("TaiViet"): Fix sample-text entry.
-
-2009-08-19 Michael Albinus <michael.albinus@gmx.de>
-
- * net/dbus.el (top): Apply `dbus-init-bus' only if the session bus
- is running already.
-
-2009-08-19 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * subr.el (listify-key-sequence-1): Use normal syntax since those
- integers are nowadays always represented by the same (positive) number
- on all platforms.
- (read-key-empty-map): New const.
- (read-key-delay): New var.
- (read-key): New function.
- (force-mode-line-update): Use with-current-buffer.
- (locate-user-emacs-file): Don't forget to abbreviate the file name.
- (start-process-shell-command, start-file-process-shell-command):
- Discourage the use of command-args.
-
-2009-08-19 Glenn Morris <rgm@gnu.org>
-
- * emacs-lisp/authors.el (authors-fixed-entries): Remove cvtmail.
-
-2009-08-19 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * simple.el (choose-completion-string): Don't rely on
- minibuffer-completing-file-name and ad-hoc checks to decide whether
- to continue completion or not.
-
- * minibuffer.el (minibuffer-hide-completions): New function.
- (completion--do-completion): Use it.
- (completions-annotations): New face.
- (completion--insert-strings): Use it.
- (completion-pcm--delim-wild-regex): Add docstring.
- (completion-pcm--string->pattern): Add support for 0-width delimiters
- in completion-pcm--delim-wild-regex.
-
-2009-08-18 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * international/ucs-normalize.el (ucs-normalize-hfs-nfd-post-read-conversion):
- Remove unused var `buffer-modified-p'.
-
- * minibuffer.el (completion--do-completion): Move point for the #b001
- case as well (bug#4176).
- (minibuffer-complete, minibuffer-complete-word): Don't move point.
-
-2009-08-18 Michael Albinus <michael.albinus@gmx.de>
-
- * net/dbus.el (dbus-init-bus): Declare. Apply it for the :system
- and :session buses.
-
-2009-08-18 Kenichi Handa <handa@m17n.org>
-
- * international/ucs-normalize.el (ucs-normalize-version):
- Change to 1.1.
- (ucs-normalize-hfs-nfd-pre-write-conversion): New function.
- (utf-8-hfs): Make it perform normalization on encoding too.
-
- * textmodes/paragraphs.el: Change to utf-8. Adjust coding cookie.
- (sentence-end-without-space): Delete duplicated chars.
- (sentence-end-base): Likewise.
-
- * textmodes/sgml-mode.el: Change to utf-8. Adjust coding cookie.
- (html-mode): Delete duplicated chars from sentence-end-base.
-
- * textmodes/texinfo.el: Change to utf-8. Adjust coding cookie.
- (texinfo-mode): Delete duplicated chars from sentence-end-base.
-
-2009-08-17 Chong Yidong <cyd@stupidchicken.com>
-
- * files.el (hack-one-local-variable): If the mode function is for
- a minor mode, pass it an argument (Bug#4148).
-
-2009-08-17 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-register-completion-file-name-handler):
- Check also for (member 'partial-completion completion-styles).
-
-2009-08-16 Chong Yidong <cyd@stupidchicken.com>
-
- * progmodes/cperl-mode.el (cperl-electric-paren): Don't expand
- abbrev (Bug#3943).
-
-2009-08-16 Ilya Zakharevich <ilyaz@cpan.org>
-
- * progmodes/cperl-mode.el: Merge upstream 6.2.
- (cperl-mode-syntax-table): Modify syntax entry for ["'`].
- (cperl-forward-re): Check cperl-brace-recursing.
- (cperl-highlight-charclass): New function.
- (cperl-find-pods-heres): Use it.
- (cperl-fill-paragraph): Synch to save-excursion placement used upstream.
- (cperl-beautify-regexp-piece): Fix column calculation.
- (cperl-make-regexp-x): Handle case where point is between "q" and "rs".
- (cperl-beautify-level): Don't process entire regexp.
- (cperl-build-manpage, cperl-perldoc): Bind Man-switches before
- calling man.
- (cperl-tips-faces, cperl-mode, cperl-electric-backspace): Doc fix.
- (cperl-init-faces): Build a list in the normal way.
-
-2009-08-16 Chong Yidong <cyd@stupidchicken.com>
-
- * calendar/parse-time.el (parse-time-string-chars): Save match
- data.
-
-2009-08-16 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * progmodes/sql.el (sql-product-alist): Add :name tag to entries.
- (sql-product): Use it.
- (sql-mode-menu): Auto-generate the menu based on sql-product-alist.
- (sql-set-product): Add completion.
- (sql-highlight-oracle-keywords, sql-highlight-postgres-keywords)
- (sql-highlight-linter-keywords, sql-highlight-ms-keywords)
- (sql-highlight-ansi-keywords, sql-highlight-sybase-keywords)
- (sql-highlight-informix-keywords, sql-highlight-interbase-keywords)
- (sql-highlight-ingres-keywords, sql-highlight-solid-keywords)
- (sql-highlight-mysql-keywords, sql-highlight-sqlite-keywords)
- (sql-highlight-db2-keywords): Remove.
- (sql-find-sqli-buffer, sql-set-sqli-buffer-generally)
- (sql-highlight-product): Use derived-mode-p.
- (sql-set-sqli-buffer): Use with-current-buffer.
- (sql-connect-informix, sql-connect-ingres, sql-connect-oracle):
- Simplify.
-
- * emacs-lisp/lisp-mode.el (lisp-indent-region): Remove unused function.
-
- * term.el: Fix commenting convention, turn comments into docstrings.
-
-2009-08-16 E. Jay Berkenbilt <ejb@ql.org> (tiny change)
-
- * whitespace.el (whitespace-style): Doc fix (Bug#3661).
-
-2009-08-16 Jan Seeger <jan.seeger@thenybble.de> (tiny change)
-
- * calendar/parse-time.el (parse-time-string-chars): Compute using
- character classes, to handle non-ascii characters (Bug#3190).
-
-2009-08-16 Chong Yidong <cyd@stupidchicken.com>
-
- * progmodes/sh-script.el (sh-maybe-here-document): Avoid inserting
- another heredoc if the user adds another < (Bug#3226).
-
- * mwheel.el (mouse-wheel-down-event, mouse-wheel-up-event):
- Don't initialize based on window-system (Bug#4124).
-
- * facemenu.el (facemenu-read-color): Use a completion function
- that accepts any defined color, such as RGB triplets (Bug#3677).
-
- * files.el (get-free-disk-space): Change fallback default
- directory to /. Expand DIR argument before switching to fallback.
- Suggested by Kevin Ryde (Bug#2631, Bug#3911).
-
-2009-08-15 Chong Yidong <cyd@stupidchicken.com>
-
- * files.el (load-library): Doc fix.
-
-2009-08-15 Michael Kifer <kifer@cs.stonybrook.edu>
-
- * emulation/viper-cmd.el (viper-insert-isearch-string): New function.
- (viper-if-string): Redefine C-s in the minibuffer to insert the last
- incremental search string.
-
- * ediff-init.el (ediff-coding-system): Use escape-quoted in case of
- XEmacs.
-
- * ediff-merg.el (ediff-merge-region-is-non-clash-to-skip)
- (ediff-merge-region-is-non-clash)
- (ediff-skip-merge-region-if-changed-from-default-p): Use defun.
- Also check if the job is really a merge job.
-
- * ediff.el (ediff-current-file): New function.
-
-2009-08-15 Chong Yidong <cyd@stupidchicken.com>
-
- * progmodes/js.el: Edit docstrings throughout to follow Emacs
- conventions.
- (js-insert-and-indent): Delete function.
- (js-mode-map): Don't bind keys to js-insert-and-indent.
- (js-beginning-of-defun): Rename from js--beginning-of-defun.
- (js-end-of-defun): Rename from js--end-of-defun.
- (js-auto-indent-flag): Delete variable.
-
-2009-08-14 Chong Yidong <cyd@stupidchicken.com>
-
- * progmodes/js.el: Remove proclaim statement.
- Defvar which-func-imenu-joiner-function to silence compiler.
-
- * files.el (auto-mode-alist): Use js-mode for .js files.
-
- * progmodes/js2-mode.el: Remove file.
-
- * Makefile.in (ELCFILES): Add js.el, and remove js2-mode.el.
-
- * speedbar.el (speedbar-supported-extension-expressions): Add .js.
-
- * 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>
-
- * progmodes/js.el: New file.
-
-2009-08-14 Mark A. Hershberger <mah@everybody.org>
-
- * timezone.el (timezone-parse-date): Add ability to understand ISO
- basic format (minimal separators) dates in addition to the
- already-supported extended format dates.
-
-2009-08-14 Eli Zaretskii <eliz@gnu.org>
-
- * international/ucs-normalize.el: Add a `coding' file variable.
-
- * Makefile.in (ELCFILES): Add international/ucs-normalize.elc.
-
-2009-08-14 Sam Steingold <sds@gnu.org>
-
- * vc-cvs.el (vc-cvs-merge-news): Yet another fix of message parsing.
-
-2009-08-13 Chong Yidong <cyd@stupidchicken.com>
-
- * faces.el (help-argument-name): Define it here instead of
- help-fns.el, because in daemon mode help-fns.el may be loaded when
- faces are still uninitialized (Bug#1078).
-
- * help-fns.el (help-argument-name): Move defface to faces.el.
-
-2009-08-13 Nick Roberts <nickrob@snap.net.nz>
-
- * progmodes/gdb-mi.el (gdb-inferior-io-mode): Use start-process to
- create buffer with a pty but no process so that GDB can make the
- inferior the controlling process.
-
-2009-08-13 Taichi Kawabata <kawabata.taichi@gmail.com>
-
- * international/ucs-normalize.el: New file.
-
-2009-08-13 Richard Stallman <rms@gnu.org>
-
- * mail/rmail.el (rmail-get-attr-names):
- Accept an attribute header that is too short.
-
- * mail/rmail.el (rmail-forget-messages):
- Ignore nil elt in rmail-message-vector. Use dotimes.
-
- * progmodes/compile.el (compilation-goto-locus):
- Use next-error-move-function.
-
- * simple.el (next-error-move-function): New variable.
-
-2009-08-12 Juri Linkov <juri@jurta.org>
-
- * progmodes/grep.el (lgrep): Ensure that `default-directory' is
- always non-nil. (Bug#4052)
-
- * replace.el (read-regexp): Return empty string when
- `default-value' is nil.
- (keep-lines-read-args): Don't use empty string as the
- default value for `read-regexp'. (Bug#2495)
-
-2009-08-12 Juri Linkov <juri@jurta.org>
-
- * international/mule-cmds.el (ucs-insert): Change arguments
- from `arg' to `character', `count', `inherit' to be the same
- as in `insert-char'. Doc fix. (Bug#4039)
-
- * international/mule-conf.el (utf-16be-with-signature): Doc fix.
-
-2009-08-12 Juri Linkov <juri@jurta.org>
-
- * files-x.el: New file.
-
- * files.el: Move code that deals with adding/deleting
- file/directory-local variables to files-x.el.
-
- * Makefile.in (ELCFILES): Add files-x.elc.
-
-2009-08-11 Dmitry Dzhus <dima@sphinx.net.ru>
-
- * progmodes/gdb-mi.el (gdb-line-posns): New helper which helps not
- to use `goto-line'.
- (gdb-place-breakpoints, gdb-get-location): Rewritten without
- `goto-line'.
- (gdb-invalidate-disassembly): Do not refresh upon receiving
- 'update signal. Instead, update all disassembly buffers only after
- threads list.
- (gdb): Send -target-detach when buffer is killed (Bug#3794).
- (gdb-starting): Move -data-list-register-names...
- (gdb-stopped): ...here so it's sent when first thread stops.
- (gdb-registers-handler-custom): Do nothing if register names are
- unknown yet.
-
- * progmodes/gud.el (gud-stop-subjob): Rewritten without macros
- from `gdb-mi.el' to avoid extra tangling.
-
- * progmodes/gdb-mi.el (gdb-gud-context-call): Reverting previous
- change which breaks `gud-def' definitions used in `gdb'.
- (gdb-update-gud-running): No extra fuss for updating frame number.
-
-2009-08-10 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * international/mule-cmds.el (mule-keymap, mule-menu-keymap)
- (describe-language-environment-map, setup-language-environment-map)
- (set-coding-system-map): Move initialization into declaration.
- (set-language-info-alist): Last arg to define-key-after can be skipped.
-
- * international/quail.el (quail-completion-1): Simplify.
- (quail-define-rules): Use slightly more compact code.
- (quail-insert-decode-map): Propertize keys, compact columns.
-
- * emacs-lisp/bytecomp.el (byte-compile-interactive-only-functions):
- Add goto-line.
-
-2009-08-10 Miles Bader <miles@gnu.org>
-
- * progmodes/js2-mode.el (js2-warning, js2-error, js2-jsdoc-tag)
- (js2-jsdoc-type, js2-jsdoc-value, js2-function-param)
- (js2-instance-member, js2-private-member, js2-private-function-call)
- (js2-jsdoc-html-tag-name, js2-jsdoc-html-tag-delimiter)
- (js2-magic-paren, js2-external-variable):
- Remove "-face" suffix from face names.
- (js2-jsdoc-highlight-helper, js2-highlight-jsdoc)
- (js2-highlight-undeclared-vars, js2-peek-token)
- (js2-parse-function-params, js2-mode-show-errors)
- (js2-mode-show-warnings, js2-make-magic-delimiter)
- (js2-mode-highlight-magic-parens): Update to use new face names.
-
-2009-08-09 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-get-ls-command-with-dired): New defun.
- (tramp-handle-insert-directory): Handle "--dired". (Bug#4075)
-
-2009-08-09 Chong Yidong <cyd@stupidchicken.com>
-
- * subr.el: Provide hashtable-print-readable.
-
- * progmodes/hideshow.el (hs-special-modes-alist): Don't use
- hs-c-like-adjust-block-beginning.
- (hs-hide-block-at-point): Stop hiding at the beginning of
- hs-block-end-regexp (Bug#700).
-
-2009-08-09 Dmitry Dzhus <dima@sphinx.net.ru>
-
- * progmodes/gdb-mi.el (gdb-gud-context-call): Does not need to be
- a macro.
- (gdb-registers-handler-custom): Do not fail when register names
- are unavailable.
-
-2009-08-08 Dmitry Dzhus <dima@sphinx.net.ru>
-
- * progmodes/gdb-mi.el (gdb-control-all-threads)
- (gdb-control-current-thread): Interactive setters for
- `gdb-gud-control-all-threads' to use in menu.
- (gdb-show-run-p): Show «Go» when process is not active.
- (gud-tool-bar-map): Add non-stop/A,T indicator.
- Uses gud/thread.xpm and gud/all.xpm.
-
-2009-08-08 Yoni Rabkin <yoni@rabkins.net>
-
- * net/net-utils.el (net-utils-font-lock-keywords): New var.
- (nslookup-font-lock-keywords): Make it a variable.
- (net-utils-mode): New mode for viewing diagnostic network output.
- (net-utils-remove-ctrl-m-filter): Set inhibit-read-only.
- (net-utils-run-simple): New function.
- (ifconfig, iwconfig, netstat, arp, route): Use it.
-
-2009-08-08 Dmitry Dzhus <dima@sphinx.net.ru>
-
- * progmodes/gdb-mi.el (gdb-read-memory-custom)
- (gdb-memory-set-address, def-gdb-set-positive-number)
- (def-gdb-memory-format, def-gdb-memory-unit): Update memory buffer
- after changing settings.
- (gdb-invalidate-disassembly): Update when first shown.
- (gdb-edit-locals-value): Fix.
- (gdb-registers-handler-custom): Print registers in right order and
- allow changing register values (only for current thread yet).
- (gdb-breakpoints-mode-map): Don't assume threads buffer is present.
- (gdb-threads-mode-map): Don't assume breakpoints buffer is present.
- (gdb-disassembly-handler-custom, gdb-stack-list-frames-custom)
- (gdb-locals-handler-custom, gdb-registers-handler-custom):
- Thread info in mode name.
- (gdb-registers-mode-map): TAB to switch to locals.
-
-2009-08-08 Eli Zaretskii <eliz@gnu.org>
-
- * mail/rmail.el (rmail-add-mbox-headers)
- (rmail-set-message-counters-counter): Search for
- rmail-unix-mail-delimiter instead of just "From ". (Bug#4076)
-
-2009-08-08 Glenn Morris <rgm@gnu.org>
-
- * Makefile.in (ELCFILES): Update.
-
-2009-08-07 Eli Zaretskii <eliz@gnu.org>
-
- * mail/sendmail.el (mail-yank-original):
- Set buffer-file-coding-system from the one used by the message whose
- text is yanked.
-
- * calc/calc-graph.el (calc-graph-plot): Set calc-graph-last-device
- to "windows" when "pgnuplot" is used.
- (calc-graph-command, calc-gnuplot-command, calc-graph-init):
- Don't call accept-process-output if "pgnuplot" is used.
- (calc-graph-init): Don't send -display and -geometry to
- "pgnuplot". If "pgnuplot" is used, glean gnuplot version by
- running "pgnuplot -V" with shell-command-to-string.
-
- * calc/calc.el (calc-gnuplot-name) [windows-nt]: Use "pgnuplot" as
- the default.
-
-2009-08-07 Eli Zaretskii <eliz@gnu.org>
-
- * Makefile.in (ELCFILES): org/org-export-latex.elc renamed to
- org/org-latex.elc.
-
-2009-08-07 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc-dispatcher.el (vc-resynch-window): Update comment.
-
- * term.el (term-handle-ansi-escape): Add comments with the
- terminfo capabilities implemented.
-
-2009-08-06 Dmitry Dzhus <dima@sphinx.net.ru>
-
- * progmodes/gdb-mi.el (gdb-var-create-regexp): Remove.
- (gdb-var-create-handler): Rewritten using JSON parser.
- (gdb-propertize-header): Move earlier.
- (gdb-set-header): Remove to avoid duplication.
- (gdb-thread-list-handler-custom, gdb-invalidate-disassembly):
- Refresh disassembly buffers only after threads list have been
- update.
- (gdb-threads-header, gdb-registers-header): Per-buffer header line
- variables.
-
-2009-08-04 Juri Linkov <juri@jurta.org>
-
- * files.el: Commands to add/delete file/directory-local variables.
- (read-file-local-variable, read-file-local-variable-value)
- (read-file-local-variable-mode, modify-file-local-variable)
- (modify-file-local-variable-prop-line)
- (modify-dir-local-variable): New functions.
- (add-file-local-variable, delete-file-local-variable)
- (add-file-local-variable-prop-line, delete-file-local-variable-prop-line)
- (add-dir-local-variable, delete-dir-local-variable)
- (copy-file-locals-to-dir-locals, copy-dir-locals-to-file-locals)
- (copy-dir-locals-to-file-locals-prop-line): New commands.
-
-2009-08-04 Chong Yidong <cyd@stupidchicken.com>
-
- * abbrev.el (insert-abbrev-table-description): Prettify output.
- Suggested by Karl Chen.
-
-2009-08-04 Dmitry Dzhus <dima@sphinx.net.ru>
-
- * progmodes/gdb-mi.el (gdb-frame-number): Initialize with nil.
- (gdb-overlay-arrow-position): Rename to `gdb-disassembly-position'.
- (gdb-overlay-arrow-position, gdb-thread-position)
- (gdb-disassembly-position): Declare variables.
- (gdb-wait-for-pending): Function now.
- (gdb-add-subscriber, gdb-delete-subscriber, gdb-get-subscribers)
- (gdb-emit-signal, gdb-buf-publisher): Declare before first use so
- compilation goes smoothly.
- (gdb, gdb-non-stop, gdb-buffers): New customization groups.
- (gdb-non-stop-setting): New customization setting which replaces
- `gdb-non-stop' so changing it doesn't break active GDB session.
- (gdb-stack-buffer-locations, gdb-stack-buffer-addresses)
- (gdb-thread-buffer-verbose-names, gdb-thread-buffer-arguments)
- (gdb-thread-buffer-locations, gdb-thread-buffer-addresses)
- (gdb-show-threads-by-default): New customization options.
- (gdb-buffer-type, gdb-buffer-shows-main-thread-p): New helper
- routines.
- (gdb-get-buffer-create): Send buffers update signal when they are
- created.
- (gdb-invalidate-locals, gdb-invalidate-registers)
- (gdb-invalidate-breakpoints)
- (gdb-invalidate-threads, gdb-invalidate-disassembly)
- (gdb-invalidate-memory): Accept update signal.
- (gdb-current-context-command): Use --frame option.
- (gdb-update-gud-running, gdb-running, gdb-setq-thread-number):
- Implement `gdb-frame-number' selection logic.
- (gdb-show-run-p, gdb-show-stop-p): Helper functions which decide
- whether to show GUD toolbar buttons.
- (gdb-thread-exited): Unselect current thread when it exits.
- (gdb-stopped): Typo fixed (now really runs `gdb-stopped-hooks').
- (gdb-mark-line): Routine which sets overlay arrow or inverses
- video on fringeless displays.
- (gdb-table, gdb-table-add-row, gdb-table-string): Structure used
- to build aligned columns of data in GDB buffers and set text
- properties line-by-line.
- (gdb-invalidate-breakpoints)
- (gdb-breakpoints-list-handler-custom)
- (gdb-thread-list-handler-custom, gdb-disassembly-handler-custom)
- (gdb-stack-list-frames-custom, gdb-locals-handler-custom)
- (gdb-registers-handler-custom): Align data columns.
- (gdb-locals-handler-custom): Now prints data like in variable
- declarations.
- (gdb-jump-to, gdb-file-button, gdb-insert-file-location-button):
- Remove confusing buttons.
- (gdb-invalidate-threads): Append --frame.
- (gdb-threads-mode-map, gdb-breakpoints-mode-map): TAB to switch
- between breakpoints/threads buffers.
- (gdb-set-window-buffer): Now can ignore dedicated windows.
- (gdb-propertize-header): Use `gdb-set-window-buffer'.
- (def-gdb-thread-buffer-simple-command): Numerous typos fixed.
- (def-gdb-thread-buffer-gud-command): Replaces
- `def-gdb-thread-buffer-gdb-command' and uses standard GUD commands
- for fine thread control.
- (gdb-preempt-existing-or-display-buffer): New function used to
- display bound buffers without breaking window layout.
- (gdb-frame-location): Replaces `gdb-insert-frame-location'.
- (gdb-select-frame): New version of `gdb-frames-select' which now
- sets `gdb-frame-number' so commands may use --frame option instead
- of inner debugger state.
- (gdb-frame-handler): Do not set `gdb-frame-number'.
- (gdb-threads-mode-map): Select threads with mouse.
-
- * progmodes/gud.el (gdb-gud-context-call): Declare function to
- avoid compilation warning.
- (gud-menu-map, gud-minor-mode-map): Use `gdb-show-run-p` and
- `gdb-show-stop-p`.
-
- * progmodes/gdb-mi.el (gdb-get-buffer, gdb-get-buffer-create):
- Argument `key' renamed to `buffer-type'.
- (gdb-current-context-buffer-name): Do not add thread info to
- buffer name when no thread is selected.
- (gdbmi-record-list, gdb-shell): Try to handle GDB `shell'
- command (bug 3794).
- (gdb-thread-selected): Handle `=thread-selected' notification.
- (gdb-wait-for-pending): New macro to deal with congestion problems.
- (gdb-breakpoints-list-handler-custom): Don't fail on pending
- breakpoints.
- (gdb-invalidate-disassembly): Use 'fullname instead of 'file.
- This fixes problem similar to one described in bug 3947.
- (gud-menu-map): More menu items.
- (gdb-init-1): Reset `gdb-thread-number' to nil.
-
- * progmodes/gud.el (gud-stop-subjob, gud-menu-map): Respect GDB
- non-stop settings.
-
- * progmodes/gdb-mi.el (gdb-thread-number): Initialize with nil.
- (gdb-current-context-command): Do not append --thread if
- `gdb-thread-number' is nil.
- (gdb-running-threads-count, gdb-stopped-threads-count):
+ (eieio-defgeneric-form-primary-only-one): Use `byte-compile' rather
+ than the internal `byte-compile-lambda'.
+ (defmethod): Don't hide code under quotes.
+ (eieio-defmethod): New `code' argument.
+
+ * emacs-lisp/eieio-comp.el: Remove.
+
+ * emacs-lisp/edebug.el (edebug-eval-defun)
+ (edebug-eval-top-level-form): Use eval-sexp-add-defvars.
+ (edebug-toggle): Avoid `eval'.
+
+ * emacs-lisp/disass.el (disassemble-internal): Handle new
+ `closure' objects.
+ (disassemble-1): Handle new byte codes.
+
+ * emacs-lisp/cl.el (pushnew): Silence warning.
+
+ * emacs-lisp/cl-macs.el (cl-byte-compile-block)
+ (cl-byte-compile-throw): Remove.
+ (cl-block-wrapper, cl-block-throw): Use compiler-macros instead.
+
+ * emacs-lisp/cl-extra.el (cl-macroexpand-all): Properly quote CL
+ closures.
+
+ * emacs-lisp/cconv.el: New file.
+
+ * emacs-lisp/bytecomp.el: Use lexical binding instead of
+ a "bytecomp-" prefix. Macroexpand everything as a separate phase.
+ (byte-compile-initial-macro-environment):
+ Handle declare-function here.
+ (byte-compile--lexical-environment): New var.
+ (byte-stack-ref, byte-stack-set, byte-discardN)
+ (byte-discardN-preserve-tos): New lap codes.
+ (byte-interactive-p): Don't use any more.
+ (byte-compile-push-bytecodes, byte-compile-push-bytecode-const2):
+ New macros.
+ (byte-compile-lapcode): Use them and handle new lap codes.
+ (byte-compile-obsolete): Remove.
+ (byte-compile-arglist-signature): Handle new byte-code arg"lists".
+ (byte-compile-arglist-warn): Check late def of inlinable funs.
+ (byte-compile-cl-warn): Don't silence warnings for compiler-macros
+ since they should have been expanded by now.
+ (byte-compile--outbuffer): Rename from bytecomp-outbuffer.
+ (byte-compile-from-buffer): Remove unused second arg.
+ (byte-compile-preprocess): New function.
+ (byte-compile-toplevel-file-form): New function to distinguish
+ file-form calls from outside from file-form calls from hunk-handlers.
+ (byte-compile-file-form): Simplify.
+ (byte-compile-file-form-defsubst): Remove.
+ (byte-compile-file-form-defmumble): Simplify now that
+ byte-compile-lambda always returns a byte-code-function.
+ (byte-compile): Preprocess.
+ (byte-compile-byte-code-maker, byte-compile-byte-code-unmake):
+ Remove, not used any more.
+ (byte-compile-arglist-vars, byte-compile-make-lambda-lexenv)
+ (byte-compile-make-args-desc): New funs.
+ (byte-compile-lambda): Handle lexical functions. Always return
+ a byte-code-function.
+ (byte-compile-reserved-constants): New var, to make up room for
+ closed-over variables.
+ (byte-compile-constants-vector): Obey it.
+ (byte-compile-top-level): New args `lexenv' and `reserved-csts'.
+ (byte-compile-macroexpand-declare-function): New function.
+ (byte-compile-form): Call byte-compile-unfold-bcf to inline immediate
+ byte-code-functions.
+ (byte-compile-form): Check obsolescence here.
+ (byte-compile-inline-lapcode, byte-compile-unfold-bcf): New functions.
+ (byte-compile-variable-ref): Remove.
+ (byte-compile-dynamic-variable-op): New fun.
+ (byte-compile-dynamic-variable-bind, byte-compile-variable-ref)
+ (byte-compile-variable-set): New funs.
+ (byte-compile-discard): Add 2 args.
+ (byte-compile-stack-ref, byte-compile-stack-set)
+ (byte-compile-make-closure, byte-compile-get-closed-var): New funs.
+ (byte-compile-funarg, byte-compile-funarg-2): Remove, handled in
+ macroexpand-all instead.
+ (byte-compile-quote-form): Remove.
+ (byte-compile-push-binding-init, byte-compile-not-lexical-var-p)
+ (byte-compile-bind, byte-compile-unbind): New funs.
+ (byte-compile-let): Handle let* and lexical binding.
+ (byte-compile-let*): Remove.
+ (byte-compile-catch, byte-compile-unwind-protect)
+ (byte-compile-track-mouse, byte-compile-condition-case):
+ Handle a new :fun-body form, used for lexical scoping.
+ (byte-compile-save-window-excursion)
+ (byte-compile-with-output-to-temp-buffer): Remove.
+ (byte-compile-defun): Simplify.
+ (byte-compile-stack-adjustment): New fun.
+ (byte-compile-out): Use it.
+ (byte-compile-refresh-preloaded): Don't reload byte-compiler files.
+
+ * emacs-lisp/byte-run.el (make-obsolete): Don't set the `byte-compile'
+ handler any more.
+
+ * emacs-lisp/byte-opt.el: Use lexical binding.
+ (byte-inline-lapcode): Remove (to bytecomp).
+ (byte-compile-inline-expand): Pay attention to inlining to/from
+ lexically bound code.
+ (byte-compile-unfold-lambda): Don't handle byte-code-functions
+ any more.
+ (byte-optimize-form-code-walker): Don't handle save-window-excursion
+ any more and don't call compiler-macros.
+ (byte-compile-splice-in-already-compiled-code): Remove.
+ (byte-code): Don't inline any more.
+ (disassemble-offset): Receive `bytes' as argument rather than via
+ dynamic scoping.
+ (byte-compile-tag-number): Declare before first use.
+ (byte-decompile-bytecode-1): Handle new byte-codes, don't change
+ `return' even if make-spliceable.
+ (byte-compile-side-effect-and-error-free-ops): Add stack-ref, remove
+ obsolete interactive-p.
+ (byte-optimize-lapcode): Optimize new lap-codes.
+ Don't trip up on new form of `byte-constant' lap code.
+
+ * emacs-lisp/autoload.el (make-autoload): Don't burp on trivial macros.
+
+ * emacs-lisp/advice.el (ad-arglist): Use help-function-arglist.
+
+ * custom.el (custom-initialize-default, custom-declare-variable):
+ Use `defvar'.
+
+ * Makefile.in (BIG_STACK_DEPTH, BIG_STACK_OPTS, BYTE_COMPILE_FLAGS):
New variables.
- (gdb-non-stop, gdb-gud-control-all-threads, gdb-switch-reasons)
- (gdb-stopped-hooks, gdb-switch-when-another-stopped):
- New customization options.
- (gdb-gud-context-command, gdb-gud-context-call): New wrappers for
- GUD commands.
- (gdb): `gud-def' definitions changed to use `gdb-gud-context-call'.
- (gdb-init-1): Activate non-stop mode if `gdb-non-stop' is enabled.
- (gdb-setq-thread-number, gdb-update-gud-running): New functions to
- set `gdb-thread-number' and update `gud-running' properly.
- (gdb-running): Update threads list when new threads appear.
- (gdb-stopped): Support non-stop operation and new thread switching
- logic.
- (gdb-jsonify-buffer, gdb-json-read-buffer, gdb-json-string)
- (gdb-json-partial-output): New set of JSON routines.
- (def-gdb-auto-update-trigger): New `signal-list' optional
- argument.
- (gdb-thread-list-handler-custom): Update `gud-running',
- `gdb-stopped-threads-count' and `gdb-running-threads-count'.
- (def-gdb-thread-buffer-gdb-command, gdb-interrupt-thread)
- (gdb-continue-thread, gdb-step-thread): New commands for fine
- thread execution control.
- (gud-menu-map): New menu items to switch non-stop options.
- (gdb-reset): Cleanup `gdb-thread-position' overlay arrow marker.
- (gdb-send): Mimic RET properly (bug 3794).
-
- * progmodes/gdb-mi.el (gdb-rules-name-maker)
- (gdb-rules-buffer-mode, gdb-rules-update-trigger): Accessors for
- gdb-buffer-rules.
- (def-gdb-auto-update-handler): New nopreserve optional argument.
- (gdb-stack-list-frames-custom): Print stack from top to bottom.
-
- * progmodes/gdb-mi.el (gdb-pc-address): Remove unused variable.
- (gdb-threads-list, gdb-breakpoints-list): New assoc lists.
- (gdb-parent-mode): New mode to derive other GDB modes from.
- (gdb-display-disassembly-for-thread)
- (gdb-frame-disassembly-for-thread): New commands for threads
- buffer.
-
- * progmodes/gdb-mi.el (gdb-get-buffer, gdb-get-buffer-create)
- (gdb-init-1, gdb-bind-function-to-buffer, gdb-add-subscriber)
- (gdb-get-subscribers, gdb-emit-signal, gdb-buf-publisher)
- (gdb-update): We now store all GDB buffers in a list so that they
- can be updated by traversing a list instead of calling invalidate
- triggers explicitly.
- (def-gdb-trigger-and-handler): New macro to define trigger-handler
- pair for GDB buffer.
- (gdb-stack-buffer-name): Add thread information.
- (gdb-add-pending, gdb-pending-p, gdb-delete-pending): Macros to
- handle pending triggers.
- (gdb-threads-mode-map, def-gdb-thread-buffer-command)
- (def-gdb-thread-buffer-simple-command)
- (gdb-display-stack-for-thread, gdb-display-locals-for-thread)
- (gdb-display-registers-for-thread, gdb-frame-stack-for-thread)
- (gdb-frame-locals-for-thread, gdb-frame-registers-for-thread):
- New commands which show buffers bound to thread.
- (gdb-stack-list-locals-regexp): Remove unused regexp.
-
- * progmodes/gdb-mi.el (gdb-breakpoints-buffer-name)
- (gdb-locals-buffer-name, gdb-registers-buffer-name)
- (gdb-memory-buffer-name, gdb-stack-buffer-name): Do not switch
- to (gud-comint-buffer) in *-buffer-name functions
- because (gdb-get-target-string) already does that.
- (gdb-locals-handler-custom, gdb-registers-handler-custom)
- (gdb-changed-registers-handler): Rewritten without regexps.
-
- * progmodes/gdb-mi.el: Basic thread selection support.
- (gdb-thread-number): New variable.
- (gdb-current-context-command): New macro which adds --thread
- option to command.
- (gdb-threads-mode-map): Select thread with SPC.
- (gdb-thread-list-handler-custom): Mark current thread with overlay
- arrow. Synchronize GDB thread and Emacs thread.
- (gdb-select-thread): New command which selects current thread.
- (gdb-invalidate-frames, gdb-invalidate-locals)
- (gdb-invalidate-registers): Use --thread option.
-
-2009-08-04 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (top): Make check for tramp-gvfs loading more
- robust. (Bug#3977)
- (tramp-handle-insert-file-contents): `unwind-protect' must be
- inside `with-parsed-tramp-file-name'.
-
- * net/tramp-gvfs.el (top): Remove superfluous message when loading
- fails.
-
-2009-08-03 Nick Roberts <nickrob@snap.net.nz>
-
- * progmodes/gud.el (jdb): Set gud-jdb-classpath-string to current
- directory if CLASSPATH is not set.
-
-2009-08-03 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-rfn-eshadow-update-overlay-regexp):
- New defconst.
- (tramp-rfn-eshadow-update-overlay): Use it. (Bug#4004)
-
-2009-08-02 Kevin Ryde <user42@zip.com.au>
-
- * net/newst-backend.el (newsticker--raw-url-list-defaults):
- Update freshmeat link. Delete newsforge.com as it seems gone.
-
-2009-08-02 Chong Yidong <cyd@stupidchicken.com>
-
- * select.el (x-set-selection): Doc fix (Bug#4021).
-
- * w32-fns.el (x-set-selection): Doc fix (Bug#4021).
-
- * help-fns.el (describe-variable): Treat list return values from
- dir-locals-find-file properly (Bug#4005).
-
-2009-08-02 Julian Scheid <julians37@googlemail.com> (tiny change)
-
- * net/tramp.el (tramp-debug-message): Print also microseconds.
-
-2009-08-02 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-handle-insert-file-contents): Optimize, when BEG
- or END is non-nil.
- (tramp-handle-vc-registered): Use `tramp-cache-inhibit-cache'.
- (tramp-get-debug-buffer): Change `outline-regexp' according to new
- format.
-
- * net/tramp-cache.el (tramp-cache-inhibit-cache): New defvar.
- (tramp-get-file-property): Use it.
-
- * autorevert.el (auto-revert-handler):
- Allow `auto-revert-tail-mode' for remote files.
-
-2009-08-02 Jason Rumney <jasonr@gnu.org>
-
- * minibuffer.el (read-file-name): Treat confirm options to
- MUSTMATCH as nil when invoking x-file-dialog. (Bug#3969)
-
-2009-08-02 Chong Yidong <cyd@stupidchicken.com>
-
- * font-lock.el (font-lock-string-face, font-lock-builtin-face)
- (font-lock-variable-name-face, font-lock-constant-face):
- Darken the colors for light backgrounds.
-
-2009-08-01 Eli Zaretskii <eliz@gnu.org>
-
- * mail/rmailsum.el (rmail-header-summary): Ignore letter-case of
- month names. (Bug#3987)
-
-2009-07-31 Chong Yidong <cyd@stupidchicken.com>
-
- * simple.el (line-move-finish): Pass whole number to
- line-move-to-column.
- (line-move-visual): Perform hscroll to the recorded position.
-
-2009-07-30 Jay Belanger <jay.p.belanger@gmail.com>
-
- * calc/calc-mode.el (calc-matrix-brackets): Remove "P" from prompt.
-
-2009-07-29 Alan Mackenzie <acm@muc.de>
-
- * progmodes/cc-defs.el (c-version): Bump to 5.31.7.
-
-2009-07-29 Dmitry Dzhus <dima@sphinx.net.ru>
-
- * progmodes/gdb-mi.el (gdb-goto-breakpoint)
- (gdb-place-breakpoints): Use full path when setting breakpoints.
-
-2009-07-29 Jay Belanger <jay.p.belanger@gmail.com>
-
- * calc/calc.el (calc-mode-map): Add keybinding for
- `calc-transpose-lines'.
-
-2009-07-29 Vincent Belaïche <vincent.belaiche@gmail.com>
-
- * calc/calc-misc.el (calc-transpose-lines): New function.
-
-2009-07-28 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-do-copy-or-rename-file): Add messages.
- Simplify check for out-of-band methods.
- (tramp-do-copy-or-rename-file-out-of-band): Allow both files to be
- remote. Remove messages which are in `tramp-do-copy-or-rename-file'.
-
-2009-07-28 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc-git.el (vc-git-checkin): Fix typo.
-
-2009-07-28 Steve Yegge <steve.yegge@gmail.com>
-
- * progmodes/js2-mode.el: New file.
-
-2009-07-28 Nick Roberts <nickrob@snap.net.nz>
-
- * progmodes/gud.el (jdb): Add gud-pstar to dump object information.
- (gud-menu-map): Adjust tooltip accordingly.
-
-2009-07-27 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc-bzr.el (vc-bzr-print-log): Pass multiple arguments to bzr log.
- (vc-bzr-log-view-mode): Adjust log-view-file-re.
-
- * add-log.el (change-log-mode-map): Add a menu.
-
-2009-07-27 Michael Albinus <michael.albinus@gmx.de>
-
- * net/dbus.el (dbus-call-method-non-blocking): Handle the case the
- function returns nil.
- (dbus-handle-event): Handle special return value :ignore.
- Reported by Jan Moringen <jan.moringen@uni-bielefeld.de>.
-
-2009-07-26 Chong Yidong <cyd@stupidchicken.com>
-
- * view.el (view-mode-enable): Don't define Helper-return-blurb if
- it's not needed.
-
-2009-07-25 Eli Zaretskii <eliz@gnu.org>
-
- Fix Bug#3888:
-
- * w32-vars.el (x-select-enable-clipboard): Doc fix.
-
- * term/pc-win.el (x-display-name, x-colors)
- (x-select-enable-clipboard, x-select-text): Doc fix.
-
- * term/common-win.el (x-display-name, x-colors): Doc fix.
-
- * term/ns-win.el (x-select-text, x-setup-function-keys, x-colors)
- (xw-defined-colors): Doc fix.
-
- * w32-fns.el (x-select-text, x-setup-function-keys)
- (x-get-selection, x-set-selection): Doc fix.
-
- * term/x-win.el (x-select-text, x-setup-function-keys)
- (x-select-enable-clipboard, xw-defined-colors): Doc fix.
-
- * select.el (x-set-selection): Doc fix.
-
-2009-07-25 Michael Albinus <michael.albinus@gmx.de>
-
- * net/zeroconf.el (zeroconf-init): Check for "GetVersionString"
- instead of "IsNSSSupportAvailable". Avahi ought to work also when
- "IsNSSSupportAvailable" method is not available.
- Reported by Steve Youngs <steve@sxemacs.org>.
-
-2009-07-24 Kenichi Handa <handa@m17n.org>
-
- * international/characters.el: Fix setting of category ?C, ?|, ?K,
- and ?H. Fix setting of case for Latin Extended and Greek Extended.
- (build-unicode-category-table): Fix range checks.
-
-2009-07-24 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc-dispatcher.el (vc-resynch-buffers-in-directory): Make sure
- the buffer we try to sync is current when calling
- vc-resynch-buffer.
-
- * vc-dir.el (vc-dir-resynch-file): Make sure vc-dir-update does
- not show up to date files.
-
-2009-07-24 Glenn Morris <rgm@gnu.org>
-
- * emacs-lisp/elint.el (elint-current-buffer, elint-defun):
- Add autoload cookies. If necessary, initialize.
- (elint-log): Handle non-file buffers.
- (elint-initialize): Add optional argument to reinitialize.
- (elint-find-builtin-variables): Save excursion.
-
-2009-07-23 Dan Nicolaescu <dann@ics.uci.edu>
-
- * emacs-lisp/lisp-mode.el (emacs-lisp-mode-map): Add menu entries
- for Lint.
-
-2009-07-22 Dan Nicolaescu <dann@ics.uci.edu>
-
- * vc.el (vc-print-log-internal): New function, split out from ...
- (vc-print-log): ... here.
- (vc-dir-move-to-goal-column): Declare.
-
- * vc-git.el (vc-git-add-signoff): New variable.
- (vc-git-checkin): Use it.
- (vc-git-toggle-signoff): New function.
- (vc-git-extra-menu-map): Bind it to menu.
- (vc-git--run-command-string): Accept a nil FILE argument.
- (vc-git-stash-list): New function.
- (vc-git-dir-extra-headers): Use it.
-
-2009-07-23 Glenn Morris <rgm@gnu.org>
-
- * help-fns.el (describe-variable): Describe ignored and risky local
- variables in a similar way to that in which we describe safe ones.
-
- * emacs-lisp/bytecomp.el (byte-compile-from-buffer)
- (byte-compile-output-file-form, byte-compile-output-docform)
- (byte-compile-file-form-defmumble, byte-compile-output-as-comment):
- Give some more local variables with common names a "bytecomp-" prefix,
- so as not to shadow things during compilation.
- * emacs-lisp/cl-macs.el (load-time-value)
- * emacs-lisp/cl.el (cl-compiling-file): Update for the name-change
- `outbuffer' to `bytecomp-outbuffer'.
-
- * emacs-lisp/elint.el (elint-standard-variables): Remove most members,
- since the next two variables cover them automatically now.
- (elint-builtin-variables, elint-autoloaded-variables): New.
- (elint-unknown-builtin-args): Remove all members, since they can be
- parsed automatically now.
- (elint-extra-errors): New.
- (elint-env-add-env, elint-env-add-macro): Use cadr.
- (elint-current-buffer): Use or. Change final message.
- (elint-get-top-forms): Use line-end-position.
- (elint-init-env): Use cadr. Handle autoload, declare-function,
- and defalias.
- (elint-add-required-env): Doc fix. Use or. Standardize error.
- (regexp-assoc): Remove unused function.
- (elint-top-form): Set elint-current-pos, to record the start of the
- top-level form, for compilation-mode.
- (elint-form): Trap errors in macro expansion. Use dolist.
- (elint-unbound-variable): Use elint-builtin-variables and
- elint-autoloaded-variables.
- (elint-get-args): Use cadr, or.
- (elint-check-cond-form): Use dolist, cadr.
- (elint-check-condition-case-form): Doc fix. Use cadr.
- Use elint-extra-errors.
- (elint-log): New function.
- (elint-error, elint-warning): Use elint-log for a bytecomp-style format.
- Distinguish errors and warnings.
- (elint-log-message): Use with-current-buffer. Inhibit read-only.
- Use a bytecomp-style format.
- (elint-clear-log): Preserve default-directory. Inhibit read-only.
- (elint-get-log-buffer): Use compilation mode. Disable undo.
- Don't truncate lines.
- (elint-initialize): Set builtin and autoloaded variable lists.
- Only process elint-unknown-builtin-args if non-nil.
- (elint-find-builtin-variables, elint-find-autoloaded-variables):
- New functions.
- (elint-find-builtin-args): Doc fix. Handle "BODY...)".
-
-2009-07-22 Kevin Ryde <user42@zip.com.au>
-
- * net/newst-backend.el (newsticker--parse-atom-1.0)
- (newsticker--parse-rss-0.91, newsticker--parse-rss-0.92)
- (newsticker--parse-rss-1.0):
- * progmodes/idlwave.el (idlwave-mode):
- * progmodes/idlw-shell.el (idlwave-shell-mode):
- * progmodes/vera-mode.el (vera-mode):
- * progmodes/verilog-mode.el (verilog-auto-inst, verilog-auto):
- * progmodes/vhdl-mode.el (vhdl-mode):
- * textmodes/table.el (table-generate-source)
- (table--warn-incompatibility):
- Hyperlink urls in docstrings with URL `...'.
-
-2009-07-22 Glenn Morris <rgm@gnu.org>
-
- * emacs-lisp/advice.el, emacs-lisp/checkdoc.el:
- * emacs-lisp/debug.el, emacs-lisp/elp.el, emacs-lisp/gulp.el:
- * emacs-lisp/lisp.el, emacs-lisp/pp.el, emacs-lisp/trace.el:
- Remove leading * from defcustom docs.
-
- * simple.el (blink-matching-paren-distance): Bump to 100k. (Bug#3889)
-
- * emacs-lisp/shadow.el (shadows-compare-text-p): Remove leading * from
- defcustom doc.
- (list-load-path-shadows): Optionally, just return shadows as a string.
-
- * mail/emacsbug.el (report-emacs-bug): Include any load-path shadows.
-
-2009-07-21 Chong Yidong <cyd@stupidchicken.com>
-
- * mail/rmailedit.el (rmail-edit-mode):
- Use auto-save-include-big-deletions.
-
- * mail/rmail.el (rmail-variables):
- Use auto-save-include-big-deletions.
-
- * files.el (auto-save-mode): Revert 2009-07-21 and 2009-07-16
- changes.
+ (compile-onefile, .el.elc, compile-calc, recompile): Use them.
+ (COMPILE_FIRST): Add macroexp and cconv.
+ * makefile.w32-in: Mirror changes in Makefile.in.
-2009-07-21 Jay Belanger <jay.p.belanger@gmail.com>
+ * vc/cvs-status.el:
+ * vc/diff-mode.el:
+ * vc/log-edit.el:
+ * vc/log-view.el:
+ * vc/smerge-mode.el:
+ * textmodes/bibtex-style.el:
+ * textmodes/css.el:
+ * startup.el:
+ * uniquify.el:
+ * minibuffer.el:
+ * newcomment.el:
+ * reveal.el:
+ * server.el:
+ * mpc.el:
+ * emacs-lisp/smie.el:
+ * doc-view.el:
+ * dired.el:
+ * abbrev.el: Use lexical binding.
- * calc/calc.el (calc-undo-length): New variable.
- (calc-quit): Truncate rather than eliminate `calc-undo-list'.
+2011-04-01 Eli Zaretskii <eliz@gnu.org>
-2009-07-21 Richard Stallman <rms@gnu.org>
+ * info.el (info-display-manual): New function.
- * files.el (auto-save-mode): Handle buffer-save-size = -2
- for toggling mode.
+2011-03-31 Stefan Monnier <monnier@iro.umontreal.ca>
-2009-07-21 Glenn Morris <rgm@gnu.org>
+ * loadup.el: Load minibuffer after loaddefs, to use define-minor-mode.
- * textmodes/ispell.el (ispell-looking-back): Update declaration.
+2011-03-31 Tassilo Horn <tassilo@member.fsf.org>
- * calendar/todo-mode.el (calendar-current-date): Update declaration.
+ * net/rcirc.el (rcirc-handler-001): Only authenticate, if there's
+ an entry for that server in rcirc-authinfo. (Bug#8385)
- * ps-print.el (ps-jitify, ps-lazify): Remove aliases only used to
- silence compiler. Instead...
- (jit-lock-fontify-now, lazy-lock-fontify-region): ...Declare.
- (ps-print-ensure-fontified): Update for above function name changes.
+2011-03-31 Glenn Morris <rgm@gnu.org>
- * printing.el (pr-mh-get-msg-num, pr-mh-show)
- (pr-mh-start-of-uncleaned-message): Remove aliases only used to
- silence compiler. Instead...
- (mh-get-msg-num, mh-show, mh-start-of-uncleaned-message): ...Declare.
- (mh-show-buffer): Only define for compiler.
- (pr-mh-current-message): Update for above function name changes.
+ * progmodes/f90.el (f90-find-tag-default): Handle multiple `%'.
- * files.el (abort-if-file-too-large): Explicitly pass `filename'
- as an argument.
- (find-file-noselect, insert-file-1): Update for above change.
+ * generic-x.el (etc-fstab-generic-mode): Add ext4, sysfs keywords.
- * mail/rmail.el (rmail-retry-ignored-headers): Bump :version.
+2011-03-30 Christoph Scholtes <cschol2112@googlemail.com>
- * mail/mailclient.el (mailclient-send-it): Fix message.
+ * progmodes/python.el (python-default-interpreter)
+ (python-python-command-args, python-jython-command-args)
+ (python-which-shell, python-which-args, python-which-bufname)
+ (python-file-queue, python-comint-output-filter-function)
+ (python-toggle-shells, python-shell): Remove obsolete defcustoms,
+ variables and functions.
- * emacs-lisp/edebug.el (cl-debug-env): Only define for compiler.
- (edebug-eval): Check cl-debug-env is bound.
- (print-level, print-circle): Don't redefine built-in variables.
+2011-03-30 Stefan Monnier <monnier@iro.umontreal.ca>
- * emacs-lisp/cust-print.el: Remove leading * from defcustom docs.
- (custom-print-vectors): Remove old comments from doc.
-
- * emerge.el (menu-bar-emerge-menu): Remove unused variable.
- (emerge-version): Make the variable an obsolete alias for the
- emacs-version variable. Make the function obsolete.
- (emerge-fast-keymap, emerge-edit-keymap): Make a separate menu for
- Emerge options, rather than merging in into the main Options menu.
- (emerge-options-menu): Adjust menu text. Use buttons for skip prefers
- and auto advance modes. Disable edit/fast items when not relevant.
-
-2009-07-20 Dan Nicolaescu <dann@ics.uci.edu>
-
- * term/vt420.el (terminal-init-vt420): Fix typo.
-
-2009-07-20 Sam Steingold <sds@gnu.org>
-
- * progmodes/ada-mode.el (compile-auto-highlight): Remove the
- variable (removed from compile.el on 2004-03-11).
-
-2009-07-20 Chong Yidong <cyd@stupidchicken.com>
-
- * files.el (hack-local-variables-filter): Fix last change.
-
-2009-07-19 Juri Linkov <juri@jurta.org>
-
- * files.el (ignored-local-variables): Add `dir-local-variables-alist'.
- (dir-local-variables-alist): New buffer-local variable.
- (hack-local-variables-filter): If variable is not dir-local,
- i.e. `dir-name' is nil, then remove it from `dir-local-variables-alist',
- because file-local overrides dir-local.
- (c-postprocess-file-styles) <declare-function>:
- Remove obsolete declaration.
- (hack-dir-local-variables): Add dir-local variable/value pair to
- `dir-local-variables-alist' and remove duplicates. Doc fix.
-
- * help-fns.el (describe-variable): Add information about
- file-local and dir-local variables.
-
-2009-07-19 Chong Yidong <cyd@stupidchicken.com>
-
- * files.el (hack-local-variables-filter): Rewrite.
-
-2009-07-19 Glenn Morris <rgm@gnu.org>
-
- * progmodes/verilog-mode.el (verilog-error-regexp-add-xemacs):
- Silence compiler by only defining on XEmacs.
-
- * international/mule.el (auto-coding-regexp-alist): Only match
- BABYL... at the start of buffer, not of lines. (Bug#3790)
-
- * calendar/cal-menu.el (cal-menu-set-date-title): Handle calls from
- non-calendar buffers (Bug#3862). Restore "not on a date" message.
- (cal-menu-context-mouse-menu): Doc fix.
-
- * desktop.el (desktop-buffers-not-to-save): Set :version tag.
-
- * simple.el (mail-user-agent): Doc fix. Set :version tag.
-
-2009-07-18 Juri Linkov <juri@jurta.org>
-
- * info.el: Virtual Info keyword finder.
- (add-to-list) <Info-virtual-files>: Add "\\`\\*Finder.*\\*\\'".
- (Info-finder-file): New variable.
- (Info-finder-find-file): New function.
- (finder-known-keywords, finder-package-info)
- (find-library-name, lm-commentary): Use defvar and
- declare-function to silence compiler warnings.
- (Info-finder-find-node): New function.
- (info-finder): New command.
-
- * subr.el (process-kill-buffer-query-function): New function.
- (add-hook)<kill-buffer-query-functions>: Add hook
- `process-kill-buffer-query-function'.
-
-2009-07-18 Alan Mackenzie <acm@muc.de>
-
- * progmodes/cc-mode.el (c-before-hack-hook)
- (c-postprocess-file-styles): Give invocation of `c-set-style'
- DONT-OVERRIDE parameter of t. Already set style variables will
- thus not be overridden by style settings given by `c-file-syle'.
-
- * files.el (hack-local-variables-filter): Remove entries with
- duplicate keys from `file-local-variables-alist'.
-
-2009-07-18 Eli Zaretskii <eliz@gnu.org>
-
- * simple.el (deactivate-mark, activate-mark, set-mark): Don't call
- x-set-selection if display-selections-p returns nil for the
- current frame.
-
-2009-07-18 Chong Yidong <cyd@stupidchicken.com>
-
- * simple.el (region-active-p, use-region-p): Doc fix (Bug#3873).
+ * minibuffer.el (completion-table-dynamic): Optimize `boundaries'.
+ (completion-in-region-mode): New minor mode.
+ (completion-in-region): Use it.
+ (completion-in-region--data, completion-in-region-mode-map): New vars.
+ (completion-in-region--postch): New function.
+ (completion--capf-misbehave-funs, completion--capf-safe-funs):
+ New vars.
+ (completion--capf-wrapper): New function.
+ (completion-at-point): Use it to track well-behavedness of
+ hook functions.
+ (completion-help-at-point): New command.
-2009-07-18 Eli Zaretskii <eliz@gnu.org>
+2011-03-30 Jason Merrill <jason@redhat.com> (tiny change)
- * desktop.el (desktop-buffers-not-to-save): Default value is nil.
- Accept nil in addition to a regexp.
- (desktop-files-not-to-save): Add "(ftp)$" to the default regexp.
- Accept nil in addition to a regexp.
- (desktop-save-buffer-p): Don't use desktop-buffers-not-to-save for
- buffers that have an associated file. Handle nil values of
- desktop-buffers-not-to-save and desktop-files-not-to-save.
- (Bug#3833)
+ * vc/add-log.el (add-change-log-entry): Don't use whitespace
+ syntax class to search for whitespace on a single line
+ (Message-ID: <4D938140.4030905@redhat.com>).
- * term/pc-win.el (x-selection-owner-p, x-own-selection-internal)
- (x-disown-selection-internal): New functions.
+2011-03-30 Leo Liu <sdl.web@gmail.com>
-2009-07-18 Nick Roberts <nickrob@snap.net.nz>
+ * abbrev.el (abbrev-edit-save-to-file, abbrev-edit-save-buffer):
+ New commands.
+ (edit-abbrevs-map): Bind them here.
+ (write-abbrev-file): New optinal arg VERBOSE. (Bug#5937)
- * progmodes/gdb-mi.el (speedbar-frame): Declare to avoid compiler
- warning.
- (gdb-breakpoints-header): Move forward to avoid compiler warning.
- (gdb-make-header-line-mouse-map): Remove duplicate definition.
+2011-03-29 Ken Manheimer <ken.manheimer@gmail.com>
-2009-07-18 David De La Harpe Golden <david@harpegolden.net>
+ * allout.el (allout-hide-by-annotation, allout-flag-region):
+ Reduce possibility of overlay leakage by making them volatile.
- * simple.el (set-mark): Revert last change.
+ * allout-widgets.el (allout-widgets-tally): Define as nil so the
+ hash is not shared between buffers. Mode initialization is
+ responsible for giving it a useful starting value.
+ (allout-item-span): Reduce possibility of overlay leakage by
+ making them volatile.
+ (allout-widgets-count-buttons-in-region): Add diagnostic function
+ for tracking down button overlay leaks.
-2009-07-17 Tassilo Horn <tassilo@member.fsf.org>
+2011-03-29 Leo Liu <sdl.web@gmail.com>
- * doc-view.el (doc-view-initiate-display): Add yes-or-no-p if
- rendering of pngs is not possible instead of messaging a long
- description.
+ * ido.el (ido-read-internal): Use the default history var
+ minibuffer-history if no HISTORY is specified.
-2009-07-17 David De La Harpe Golden <david@harpegolden.net>
+2011-03-28 Brian T. Sniffen <bsniffen@akamai.com> (tiny change)
- * w32-fns.el (x-selection-owner-p): New function.
+ * net/imap.el (imap-shell-open, imap-process-connection-type):
+ Use imap-process-connection-type for 'shell' streams as well as
+ Kerberos, SSL, other subprocesses.
- * mouse.el (mouse-drag-track): Call deactivate-mark earlier.
- (mouse-yank-at-click, mouse-yank-primary):
- If select-active-regions is non-nil, deactivate the mark before
- insertion.
+2011-03-28 Leo Liu <sdl.web@gmail.com>
- * simple.el (deactivate-mark, set-mark): Only save selection if we
- own it.
+ * abbrev.el (abbrev-table-empty-p): New function.
+ (prepare-abbrev-list-buffer): Place empty abbrev tables after
+ nonempty ones. (Bug#5937)
-2009-07-17 Kenichi Handa <handa@m17n.org>
+2011-03-27 Jan Djärv <jan.h.d@swipnet.se>
- * case-table.el (describe-buffer-case-table): Fix for the case
- that KEY is a cons.
+ * cus-start.el (all): Add boolean ns-auto-hide-menu-bar.
-2009-07-16 Dan Nicolaescu <dann@ics.uci.edu>
+2011-03-27 Leo Liu <sdl.web@gmail.com>
- * vc-rcs.el (vc-rcs-find-file-hook):
- * vc-sccs.el (vc-sccs-find-file-hook): Fix cut and paste error.
+ * ansi-color.el (ansi-color-names-vector): Allow cons cell value
+ for foreground and background colors.
+ (ansi-color-make-color-map): Adapt.
-2009-07-16 Michael Albinus <michael.albinus@gmx.de>
+2011-03-25 Leo Liu <sdl.web@gmail.com>
- * net/tramp.el (tramp-wait-for-output): Handle the case when
- commands do not return a newline but a null byte before the shell
- prompt. (Bug#3858)
+ * midnight.el (midnight-time-float): Remove. Note it calculates
+ the microsecond component incorrectly and seconds-to-time does the
+ same job.
+ Remove redundant (require 'timer).
-2009-07-16 YAMAMOTO Mitsuharu <mituharu@math.s.chiba-u.ac.jp>
+ * ido.el (ido-read-internal): Simplify with read-from-minibuffer.
+ (ido-completions): Remove unused arguments. (Bug#8329)
- * term/ns-win.el (ns-set-alpha): Don't declare.
- (ns-set-background-alpha): Remove function.
+2011-03-24 Stefan Monnier <monnier@iro.umontreal.ca>
-2009-07-16 Kevin Ryde <user42@zip.com.au>
+ * minibuffer.el (completion--flush-all-sorted-completions):
+ Remove itself from hook.
+ (completion-at-point): Let the functions perform the completion
+ immediately and return nil or t.
+ * comint.el (comint-dynamic-complete-functions): Now identical to
+ completion-at-point-functions.
+ (comint-dynamic-list-input-ring): Remove unused var `index'.
+ (comint--match-partial-filename, comint--unquote&expand-filename):
+ New funs, split from comint-match-partial-filename.
+ (comint-dynamic-complete): Use completion-at-point.
+ (comint-dynamic-complete-filename): Use comint--match-partial-filename.
- * emacs-lisp/copyright.el (copyright-update): Save match-data across
- y-or-n-p, for safety.
+2011-03-24 Drew Adams <drew.adams@oracle.com>
-2009-07-16 Richard Stallman <rms@gnu.org>
+ * thingatpt.el: Support `defun'.
- * files.el (auto-save-mode): If buffer-saved-size is -2,
- don't clobber it.
+2011-03-23 Leo Liu <sdl.web@gmail.com>
- * mail/rmail.el (rmail-variables): Set buffer-saved-size to -2.
- (rmail-retry-ignored-headers): Add more uninteresting fields.
+ * abbrevlist.el: Move to obsolete/abbrevlist.el.
-2009-07-15 Jari Aalto <jari.aalto@cante.net>
+ * help-mode.el (help-mode-finish): Tweak regexp.
- * net/rcirc.el (rcirc): Use history variables.
- (rcirc-server-name-history, rcirc-nick-name-history)
- (rcirc-server-port-history): New variables.
+2011-03-23 Glenn Morris <rgm@gnu.org>
-2009-07-15 Kenichi Handa <handa@m17n.org>
+ * eshell/esh-opt.el (eshell-eval-using-options):
+ Do not bind unused local variable `eshell-option-stub'.
- * international/mule-cmds.el (set-language-environment-charset):
- If coding-system-charset-list returns `iso-2022' or `emacs-mule',
- ignore them.
+ * progmodes/gdb-mi.el (gdb): Fix typo in previous change.
- * language/misc-lang.el ("IPA"): Change coding systems to utf-8.
- Delete unibyte-display.
+2011-03-22 Juanma Barranquero <lekktu@gmail.com>
-2009-07-15 Chong Yidong <cyd@stupidchicken.com>
+ * emacs-lisp/derived.el (define-derived-mode): Wrap declaration of
+ keymap variable in `with-no-warnings' to avoid a warning when the
+ keymap has been already `defconst'ed.
- * simple.el (kill-visual-line): Obey kill-whole-line (Bug#3695).
+2011-03-22 Leo Liu <sdl.web@gmail.com>
-2009-07-15 Chong Yidong <cyd@stupidchicken.com>
+ * abbrev.el (write-abbrev-file): Use utf-8 for writing if it can
+ encode all chars in abbrevs; otherwise use emacs-mule or
+ utf-8-emacs. (Bug#8308)
- * simple.el (deactivate-mark): Optional argument FORCE.
- (set-mark): Use deactivate-mark.
+2011-03-22 Juanma Barranquero <lekktu@gmail.com>
- * info.el (Info-search): No need to check transient-mark-mode
- before calling deactivate-mark.
+ * simple.el (backward-delete-char-untabify):
+ Avoid warning about using `delete-backward-char'.
- * select.el (x-set-selection): Doc fix.
- (x-valid-simple-selection-p): Allow buffer values.
- (xselect--selection-bounds): Handle buffer values.
- Suggested by David De La Harpe Golden.
+ * image.el (image-type-file-name-regexps): Make it variable.
+ `imagemagick-register-types' modifies it, and the user may want
+ to add new extensions for known image types.
+ (imagemagick-register-types): Throw error if not using ImageMagick.
- * mouse.el (mouse-set-region, mouse-drag-track):
- Call copy-region-as-kill before setting the mark, to let
- select-active-regions work.
+2011-03-22 Leo Liu <sdl.web@gmail.com>
-2009-07-15 David De La Harpe Golden <david@harpegolden.net>
+ * net/rcirc.el (rcirc-completion-at-point): Return nil if point is
+ located before rcirc-prompt-end-marker.
+ (rcirc-complete): Error if point is not after rcirc prompt.
+ Handle the case when table is nil.
+ (rcirc-user-authenticated): Define to fix compiler warning.
- * simple.el (deactivate-mark): If select-active-regions is
- non-nil, copy the selection data into a string.
- (activate-mark): If select-active-regions is non-nil, set the
- selection to the current buffer.
- (set-mark): Update selection if select-active-regions is non-nil.
+2011-03-22 Chong Yidong <cyd@stupidchicken.com>
- * select.el (x-valid-simple-selection-p): Allow buffer values.
+ * custom.el (custom--inhibit-theme-enable): Make it affect only
+ custom-theme-set-variables and custom-theme-set-faces.
+ (provide-theme): Ignore custom--inhibit-theme-enable.
+ (load-theme): Enable the theme explicitly if NO-ENABLE is non-nil.
+ (custom-enabling-themes): Delete variable.
+ (enable-theme): Accept only loaded themes as arguments.
+ Ignore the special custom-enabled-themes variable.
+ (custom-enabled-themes): Forbid themes from setting this.
+ Eliminate use of custom-enabling-themes.
+ (custom-push-theme): Quote "changed" custom var entry.
-2009-07-14 Stefan Monnier <monnier@iro.umontreal.ca>
+2011-03-21 Leo Liu <sdl.web@gmail.com>
- * simple.el (mail-user-agent): Default to the upwardly-UI-compatible
- and more featureful message-mode.
+ * ido.el (ido-read-internal): Add ido-selected to history instead
+ of user input.
-2009-07-14 Chong Yidong <cyd@stupidchicken.com>
+2011-03-21 Stefan Monnier <monnier@iro.umontreal.ca>
- * select.el (x-set-selection): Doc fix.
- (x-valid-simple-selection-p): Disallow selection data consisting
- of a list or cons of integers, since that is not used.
- (xselect--selection-bounds, xselect--int-to-cons): New functions.
- (xselect-convert-to-string, xselect-convert-to-length)
- (xselect-convert-to-filename, xselect-convert-to-charpos)
- (xselect-convert-to-lineno, xselect-convert-to-colno): Use them.
+ * subr.el (deferred-action-list, deferred-action-function):
+ Mark obsolete.
-2009-07-14 Dmitry Dzhus <dima@sphinx.net.ru>
+2011-03-21 Leo Liu <sdl.web@gmail.com>
- * progmodes/gdb-mi.el (json-partial-output): Fix broken GDB/MI
- output in -break-info command (Emacs bug #3794).
+ * vc/log-view.el: Remove (require 'wid-edit), not needed after the
+ change on 2011-02-13 (bug#8309).
-2009-07-14 Glenn Morris <rgm@gnu.org>
+ * minibuffer.el (read-file-name-function): Change default value.
+ (read-file-name--defaults): Rename from read-file-name-defaults.
+ (read-file-name-default): Rename from read-file-name.
+ (read-file-name): Call read-file-name-function.
- * emacs-lisp/edebug.el (edebug-setup-hook, edebug-all-forms)
- (edebug-eval-macro-args, edebug-save-displayed-buffer-points)
- (edebug-print-length, edebug-print-level, edebug-print-circle)
- (edebug-sit-for-seconds, edebug-view-outside)
- (edebug-bounce-point, edebug-set-global-break-condition)
- (edebug-Go-nonstop-mode, edebug-trace-mode)
- (edebug-Trace-fast-mode, edebug-continue-mode)
- (edebug-Continue-fast-mode, edebug-forward-sexp, edebug-help)
- (edebug-visit-eval-list): Doc fixes.
+2011-03-21 Glenn Morris <rgm@gnu.org>
- * subr.el (def-edebug-spec): Doc fix.
-
-2009-07-14 Kenichi Handa <handa@m17n.org>
+ * eshell/esh-opt.el (eshell-eval-using-options, eshell-process-args):
+ Doc fixes.
- * international/characters.el: Fix setting of category ?C.
+2011-03-21 Chong Yidong <cyd@stupidchicken.com>
-2009-07-13 Jan Djärv <jan.h.d@swipnet.se>
+ * cus-theme.el: Add missing provide statement.
+ (customize-create-theme): Extract theme value correctly.
+ (custom-theme-visit-theme): Autoload.
+ (customize-create-theme): Prompt before inserting default faces.
- * term/ns-win.el (x-select-font): defalias x-select-font to
- ns-popup-font-panel instead of generate-fontset-menu.
+2011-03-20 Jay Belanger <jay.p.belanger@gmail.com>
-2009-07-12 Eli Zaretskii <eliz@gnu.org>
+ * calc/calc-menu.el (calc-units-menu): Add entries for logarithmic
+ units and musical notes.
- * desktop.el (desktop-buffers-not-to-save): Remove ".log". (Bug#3833)
+2011-03-20 Leo <sdl.web@gmail.com>
-2009-07-12 Peter Jolly <peter@jollys.org> (tiny change)
+ * ido.el (ido-read-internal): Use completing-read-default.
+ (ido-completing-read): Fix compatibility with completing-read.
- * arc-mode.el (archive-find-type): Allow for a PK00 string before
- the PK\003\004 header (Bug#3770).
+2011-03-20 Christian Ohler <ohler@gnu.org>
-2009-07-12 Guanpeng Xu <herberteuler@hotmail.com>
+ * emacs-lisp/ert.el (ert-run-tests-batch): Remove unused variable.
+ (ert-delete-all-tests): Use `called-interactively-p' rather than
+ `interactive-p'.
+ (ert--make-xrefs-region): Respect END.
- * pcomplete.el (pcomplete-comint-setup): Check for
- shell-dynamic-complete-filename too.
+2011-03-19 Chong Yidong <cyd@stupidchicken.com>
-2009-07-11 Chong Yidong <cyd@stupidchicken.com>
+ * dired-aux.el (dired-create-directory): Signal an error if the
+ directory already exists (Bug#8246).
- * simple.el (temporary-goal-column): Change the value for
- line-move-visual to a cons cell.
- (line-move-visual): Record or set the window hscroll, if
- necessary (Bug#3494).
- (line-move-1): Handle cons value of temporary-goal-column.
+ * facemenu.el (list-colors-display): Call list-faces-display
+ inside with-help-window.
+ (list-colors-print): Use display property to align the final
+ column, instead of checking window-width.
-2009-07-11 Kenichi Handa <handa@m17n.org>
+2011-03-19 Eli Zaretskii <eliz@gnu.org>
- * international/mule-diag.el (describe-character-set): Don't show
- width.
+ * emerge.el (emerge-metachars): Separate value for ms-dos and
+ windows-nt systems.
+ (emerge-protect-metachars): Quote correctly for ms-dos and
+ windows-nt systems.
-2009-07-10 Sam Steingold <sds@gnu.org>
+2011-03-19 Ralph Schleicher <rs@ralph-schleicher.de>
- * progmodes/compile.el (compilation-mode-font-lock-keywords):
- Omake sometimes indents the errors it prints, so allow all
- regexps to start with spaces.
+ * info.el (info-initialize): Replace all uses of `:' with
+ path-separator for compatibility with non-Unix systems.
+ Cache quoting of path-separator. (Bug#8258)
-2009-07-10 Eli Zaretskii <eliz@gnu.org>
+2011-03-19 Juanma Barranquero <lekktu@gmail.com>
- * cus-edit.el (customize-changed-options-previous-release):
- Bump value to 22.1. (Bug#3804)
+ * avoid.el (mouse-avoidance-mode, mouse-avoidance-nudge-dist)
+ (mouse-avoidance-threshold, mouse-avoidance-banish-destination)
+ (mouse-avoidance-mode): Fix typos in docstrings.
-2009-07-08 Sam Steingold <sds@gnu.org>
+2011-03-19 Chong Yidong <cyd@stupidchicken.com>
- * progmodes/grep.el (rgrep): Allow grep-find-ignored-directories
- to be a cons cell (test . ignored-directory) to selectively ignore
- some directories depending on the location of the search.
+ * startup.el (package-subdirectory-regexp): Move from package.el.
+ Omit \\` and \\', and let callers add them.
-2009-07-08 Michael Albinus <michael.albinus@gmx.de>
+ * emacs-lisp/package.el (package-strip-version)
+ (package-load-all-descriptors): Add \\` and \\' to
+ package-subdirectory-regexp before using it.
+ (package-untar-buffer): New arg DIR; ensure that file untars only
+ into this expected directory. Remove superfluous delete-region.
+ (package-unpack): Caller changed.
+ (package-tar-file-info): Use package-subdirectory-regexp.
- * net/tramp.el (tramp-set-file-uid-gid): Handle the case the
- remote user is root, on the local host.
- (tramp-local-host-p): Either the local user or the remote user
- must be root. (Bug#3771)
+2011-03-18 Stefan Monnier <monnier@iro.umontreal.ca>
-2009-07-08 Nick Roberts <nickrob@snap.net.nz>
+ * vc/diff-mode.el (diff-mode-map): Shadow problematic bindings from
+ diff-mode-shared-map (bug#8284).
+ (diff-mode-shared-map): Re-introduce some bindings that were problematic.
- * progmodes/gdb-mi.el (gdb): Remove description of
- gdb-use-separate-io-buffer.
- (menu): Don't allow toggling of or enable
- gdb-use-separate-io-buffer from menubar.
+2011-03-17 Lars Magne Ingebrigtsen <larsi@gnus.org>
-2009-07-08 E. Jay Berkenbilt <ejb@ql.org> (tiny change)
+ * calendar/time-date.el (format-seconds): Use assoc instead of
+ assoc-string, since assoc-string doesn't exist in XEmacs.
- * mail/unrmail.el (unrmail): Make sure the message ends with two
- newlines (Bug#3769).
+2011-03-17 Juanma Barranquero <lekktu@gmail.com>
-2009-07-08 Glenn Morris <rgm@gnu.org>
+ * custom.el (custom-known-themes): Reflow docstring.
+ (custom-theme-load-path): Fix typo in docstring.
+ (load-theme): Fix typo in error message.
+ (custom-available-themes, custom-variable-theme-value):
+ Use `let', not `let*'.
- * calendar/calendar.el (calendar-current-date): Rework previous change.
+2011-03-17 Jay Belanger <jay.p.belanger@gmail.com>
-2009-07-08 Ed Reingold <reingold@emr.cs.iit.edu>
+ * calc/README: Mention inclusion of musical notes.
- * calendar/calendar.el (calendar-current-date):
- Add an optional argument giving an offset from today.
+ * calc/calc-units.el (calc-lu-quant): Rename from
+ `calc-logunits-quantity'.
+ (calcFunc-lupquant): Rename from `calcFunc-powerquant'.
+ (calcFunc-lufquant): Rename from `calcFunc-fieldquant'.
+ (calc-db): Rename from `calc-dblevel'.
+ (calcFunc-dbpower): Rename from `calcFunc-dbpowerlevel'.
+ (calcFunc-dbfield): Rename from `calcFunc-dbfieldlevel'.
+ (calc-np): Rename from `calc-nplevel'.
+ (calcFunc-nppower): Rename from `calcFunc-nppowerlevel'.
+ (calcFunc-npfield): Rename from `calcFunc-npfieldlevel'.
+ (calc-lu-plus): Rename from `calc-logunits-add'.
+ (calcFunc-lupadd): Rename from `calcFunc-lupoweradd'.
+ (calcFunc-lufadd): Rename from `calcFunc-lufieldadd'.
+ (calc-lu-minus): Rename from `calc-logunits-sub'.
+ (calcFunc-lupsub): Rename from `calcFunc-lupowersub'.
+ (calcFunc-lufsub): Rename from `calcFunc-lufieldsub'.
+ (calc-lu-times): Rename from `calc-logunits-mul'.
+ (calcFunc-lupmul): Rename from `calcFunc-lupowermul'.
+ (calcFunc-lufmul): Rename from `calcFunc-lufieldmul'.
+ (calc-lu-divide): Rename from `calc-logunits-div'.
+ (calcFunc-lupdiv): Rename from `calcFunc-lupowerdiv'.
+ (calcFunc-lufdiv): Rename from `calcFunc-lufielddiv'.
-2009-07-08 Glenn Morris <rgm@gnu.org>
+ * calc/calc-ext.el (calc-init-extensions): Update the names of the
+ functions being autoloaded.
- * tutorial.el (tutorial--describe-nonstandard-key):
- Adjust the message for when a key has been unbound.
- (help-with-tutorial): Hide the arch-tag.
+ * calc/calc.el (calc-lu-power-reference): Rename from
+ `calc-logunits-power-reference'.
+ (calc-lu-field-reference): Rename from
+ `calc-logunits-field-reference'.
-2009-07-08 Kenichi Handa <handa@m17n.org>
+ * calc/calc-help (calc-l-prefix-help): Mention musical note functions.
- * international/fontset.el (setup-default-fontset): For each
- script, append (not set) font-specs.
+2011-03-17 Stefan Monnier <monnier@iro.umontreal.ca>
- * language/japanese.el (japanese-shift-jis-2004): Fix typo in the
- docstring.
+ * minibuffer.el (completion-all-sorted-completions):
+ Use :completion-cycle-penalty text property if present.
-2009-07-08 Nick Roberts <nickrob@snap.net.nz>
+2011-03-16 Ken Manheimer <ken.manheimer@gmail.com>
- * progmodes/gdb-mi.el (gdb-init-1): Move sending
- -data-list-register-names to ...
- (gdb-starting): ... here because GDB 7.0 requires execution to
- have started when using this MI command.
- (gdb-set-header): New function to distinguish select and
- unselected tabs in gdb buffers.
- (gdb-propertize-header): New macro that uses gdb-set-header.
- (gdb-breakpoints-header, gdb-locals-header): Use it.
- (gdb-disassembly-mode-map): Add keybinding to kill buffer.
+ * allout.el (allout-yank-processing): Adjust for new rebulleting
+ regime so bullet being yanked is used without prompting the user
+ for a choice.
-2009-07-07 Chong Yidong <cyd@stupidchicken.com>
+2011-03-16 Juanma Barranquero <lekktu@gmail.com>
- * Makefile.in (ELCFILES): Remove fadr.elc.
+ * startup.el (command-line): Warn the user that _emacs is deprecated.
-2009-07-07 Dmitry Dzhus <dima@sphinx.net.ru>
+2011-03-16 Juanma Barranquero <lekktu@gmail.com>
- * progmodes/gdb-mi.el (gdb-init-1): Disassembly buffer mode name
- may contain frame information, so `string-match' should be used.
- (gdb-update): Disassembly is invalidated through
- `gdb-get-selected-frame'.
- (gdb-pad-string): New function to pad string with spaces.
- (gdb-invalidate-disassembly): Invalidate only if the buffer
- exists.
- (gdb-disassembly-handler-custom): Column alignment.
- (gdb-disassembly-place-breakpoints): Clear old breakpoints before
- placing new ones.
- (gdb-toggle-breakpoint, gdb-delete-breakpoint): Now work from the
- end of line, too.
- (gdb-frame-handler): Match convention to for disassembly buffer
- mode name.
- (gdb-stack-list-frames-handler): Rewritten without regexps.
- (gdb-breakpoints-list-handler-custom): y/n instead of on/off; do
- not highlight breakpoints without line information.
- (gdb-input): Add trailing newline to command.
+ * progmodes/delphi.el (delphi-search-path, delphi-indent-level)
+ (delphi-verbose, delphi-comment-face, delphi-string-face)
+ (delphi-keyword-face, delphi-ignore-changes, delphi-indent-line)
+ (delphi-mode-abbrev-table, delphi-debug-buffer, delphi-tab)
+ (delphi-find-unit, delphi-find-current-xdef, delphi-fill-comment)
+ (delphi-new-comment-line, delphi-font-lock-defaults)
+ (delphi-debug-mode-map, delphi-mode-syntax-table, delphi-mode):
+ Fix typos in docstrings.
- * progmodes/gdb-mi.el (gdb-init-1): Set mode name for disassembly
- buffer properly.
- (gdb-breakpoints-list-handler-custom): Replacement for
- `gdb-break-list-handler'. Using real parser instead of regexps
- now.
- (gdb-place-breakpoints): Replacement for `gdb-break-list-custom'.
- Use `gdb-breakpoints-list' instead of parsing breakpoints buffer
- to place breakpoints.
- (def-gdb-memory-unit): A new macro to define gdb-memory-unit-..
- functions.
- (gdb-disassembly-handler-custom): Show overlay arrow.
- (gdb-disassembly-place-breakpoints): Show breakpoints in
- disassembly buffer.
- (gdb-toggle-breakpoint, gdb-delete-breakpoint)
- (gdb-goto-breakpoint): Using `gdb-breakpoint' text properties
- instead of parsing breakpoints buffer. Fixed old menu references
- in `gud-menu-map'.
+2011-03-15 Ken Manheimer <ken.manheimer@gmail.com>
- * fadr.el: Remove.
+ * allout.el (allout-make-topic-prefix, allout-rebullet-heading):
+ Invert the roles of character and string values for INSTEAD, so a
+ string is used for the more common case of a defaulting prompt.
- * progmodes/gdb-mi.el: Port memory buffer from gdb-ui.el.
- (gdb-memory-address): New variable which holds top address of
- memory page shown in memory buffer.
- (gdb-memory-repeat-count, gdb-memory-format, gdb-memory-unit):
- New customization variables.
- New functions:
- (gdb-display-memory-buffer, gdb-frame-memory-buffer): Functions to
- display the memory buffer.
- (gdb-memory-set-address, gdb-memory-set-repeat-count): Set memory
- buffer display parameters.
- (def-gdb-memory-format, gdb-memory-format-binary)
- (gdb-memory-format-octal, gdb-memory-format-unsigned)
- (gdb-memory-format-signed, gdb-memory-format-hexadecimal):
- Functions for setting memory buffer format.
- (gdb-memory-unit-word, gdb-memory-unit-halfword)
- (gdb-memory-unit-giant, gdb-memory-unit-byte): Functions to set
- unit size used in memory buffer.
- (gdb-memory-show-next-page, gdb-memory-show-previous-page):
- Switch to next/previous page of memory buffer.
- Now using (bindat-get-field) instead of fadr functions.
+2011-03-15 Stefan Monnier <monnier@iro.umontreal.ca>
-2009-07-07 Sam Steingold <sds@gnu.org>
+ * progmodes/ruby-mode.el (ruby-backward-sexp):
+ * progmodes/ebrowse.el (ebrowse-draw-file-member-info):
+ * play/gamegrid.el (gamegrid-make-face):
+ * play/bubbles.el (bubbles--grid-width, bubbles--grid-height)
+ (bubbles--colors, bubbles--shift-mode, bubbles--initialize-images):
+ * notifications.el (notifications-notify):
+ * net/xesam.el (xesam-search-engines):
+ * net/quickurl.el (quickurl-list-insert):
+ * vc/vc-hg.el (vc-hg-dir-printer): Fix use of case.
- * vc-cvs.el (vc-cvs-merge-news): Fix message parsing for
- non-top-level files.
+2011-03-15 Chong Yidong <cyd@stupidchicken.com>
-2009-07-07 Kenichi Handa <handa@m17n.org>
+ * startup.el (command-line): Update package subdirectory regexp.
- * international/mule-cmds.el (reset-language-environment):
- Put the highset priority to the charset iso-8859-1.
+2011-03-15 Stefan Monnier <monnier@iro.umontreal.ca>
-2009-07-06 Chong Yidong <cyd@stupidchicken.com>
-
- * progmodes/hideshow.el (hs-hide-block-at-point): Don't move point
- to the end of the line when locating the block (Bug#700).
-
-2009-07-06 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-handle-write-region): Flush file properties
- in case of short track.
-
-2009-07-06 Michael McNamara <mac@mail.brushroad.com>
-
- * progmodes/verilog-mode.el (verilog-error-regexp-emacs-alist):
- Coded custom representation of verilog error regular expressions
- to work with Emacs-22's new format.
- (verilog-error-regexp-xemacs-alist): Coded custom representation
- of verilog error regular expressions to work with XEmacs format.
- (verilog-error-regexp-add-xemacs): Hook routine to install verilog
- error recognition into XEmacs.
- (verilog-error-regexp-add-emacs): Hook routine to install verilog
- error recognition into Emacs-22.
-
-2009-07-06 Chong Yidong <cyd@stupidchicken.com>
+ * allout.el (allout-abbreviate-flattened-numbering)
+ (allout-mode-deactivate-hook): Fix up obsolescence "date".
- * woman.el: Remove stand-alone closing parentheses.
- (woman-file-name, woman2-format-paragraphs)
- (woman-leave-blank-lines): Code cleanup.
- (woman-use-own-frame): Change default to nil.
- (woman-italic, woman-bold, woman-unknown, woman-addition):
- Change defaults to inherit from default faces.
- (woman2-process-escapes): Consume the newline after a stand-alone
- filler character (Bug#3651).
-
-2009-07-06 Glenn Morris <rgm@gnu.org>
-
- * ffap.el (ffap-version): Make it an obsolete alias for emacs-version.
- (top-level): Move provide to the end.
- (ffap): Remove defunct URL from custom group.
-
- * subr.el (eval-after-load): Doc fix.
+ * subr.el (read-char-choice): Only show the cursor after the prompt,
+ not after the answer.
-2009-07-06 Vincent Belaïche <vincent.belaiche@gmail.com>
+2011-03-15 Kevin Ryde <user42@zip.com.au>
- * calc/calc-embed.el (calc-embedded-make-info): Don't force when
- `calc-embedded-word' is called twice.
+ * help-fns.el (variable-at-point): Skip leading quotes, if any
+ (bug#8253).
-2009-07-05 Stefan Monnier <monnier@iro.umontreal.ca>
+2011-03-15 Stefan Monnier <monnier@iro.umontreal.ca>
- * files.el (find-alternate-file-other-window, find-alternate-file):
- Obey confirm-nonexistent-file-or-buffer.
+ * emacs-lisp/bytecomp.el (byte-compile-save-excursion): Change the
+ warning message.
-2009-07-05 Michael Albinus <michael.albinus@gmx.de>
+2011-03-14 Michael Albinus <michael.albinus@gmx.de>
- * dired-aux.el (dired-show-file-type): Handle remote files.
+ * shell.el (shell): When called interactively, offer to change the
+ shell file name on remote hosts.
-2009-07-05 Jari Aalto <jari.aalto@cante.net>
+2011-03-13 Teodor Zlatanov <tzz@lifelogs.com>
- * desktop.el (desktop-globals-to-save):
- Add file-name-history (Bug#2750).
+ * net/ldap.el (ldap-search-internal): Add `auth-source-search'
+ integration for LDAP parameters. The host, base, user or binddn,
+ and secret tokens can be specified in a netrc file, for instance.
+ This is optional because an `auth-source' parameter must be
+ specified in the search attributes.
-2009-07-05 Chong Yidong <cyd@stupidchicken.com>
+2011-03-13 Juanma Barranquero <lekktu@gmail.com>
- * add-log.el (add-log-current-defun-header-regexp): Doc fix (Bug#2217).
+ * help.el (describe-mode): Link to the mode's definition (bug#8185).
-2009-07-04 Johan Bockgård <bojohan@gnu.org>
+2011-03-12 Stefan Monnier <monnier@iro.umontreal.ca>
- * eshell/esh-arg.el (eshell-parse-argument-hook): Put `number'
- property on entire argument since this is what eshell-lisp-command
- expects.
+ * ebuff-menu.el (electric-buffer-menu-mode-map): Move initialization
+ into declaration. Remove redundant and harmful binding.
-2009-07-03 Michael Albinus <michael.albinus@gmx.de>
+2011-03-12 Eli Zaretskii <eliz@gnu.org>
- * net/tramp-gvfs.el (tramp-gvfs-methods)
- (tramp-gvfs-zeroconf-domain)
- (tramp-bluez-discover-devices-timeout): Add version flag.
- (tramp-gvfs-handler-mounted-unmounted)
- (tramp-gvfs-connection-mounted-p): Polish handling of
- incompatibilities between GVFS 0.2 and 1.0.
+ * files.el (file-ownership-preserved-p): Pass `integer' as an
+ explicit 2nd argument to `file-attributes'. If the file's owner
+ is the Administrators group on Windows, and the current user is
+ Administrator, consider that a match.
-2009-07-03 Jan Djärv <jan.h.d@swipnet.se>
+ * server.el (server-ensure-safe-dir): Consider server directory
+ safe on MS-Windows if its owner is the Administrators group while
+ the current Emacs user is Administrator. Use `=' to compare
+ numerical UIDs, since they could be integers or floats.
- * cus-start.el (all): Add make-pointer-invisible.
+2011-03-12 Juanma Barranquero <lekktu@gmail.com>
-2009-07-03 Jay Belanger <jay.p.belanger@gmail.com>
+ * vc/vc-bzr.el (vc-bzr-state): Handle bzr 2.3.0 (follow-up to bug#8170).
- * calc/calc-math.el (math-use-emacs-fn): Make sure that the number is
- formatted correctly.
+2011-03-12 Michael Albinus <michael.albinus@gmx.de>
-2009-07-02 Juri Linkov <juri@jurta.org>
+ Sync with Tramp 2.2.1.
- * info.el: Virtual Info files and nodes.
- (Info-virtual-files, Info-virtual-nodes): New variables.
- (Info-current-node-virtual): New variable.
- (Info-virtual-file-p, Info-virtual-fun, Info-virtual-call):
- New functions.
- (Info-file-supports-index-cookies): Use Info-virtual-file-p
- to check for a virtual file instead of checking a fixed list
- of node names.
- (Info-find-file): Use Info-virtual-fun and Info-virtual-call
- instead of ad-hoc processing of "dir" and (apropos history toc).
- (Info-find-node-2): Use Info-virtual-fun and Info-virtual-call
- instead of ad-hoc processing of "dir" and (apropos history toc).
- Reread a file when moving from a virtual node.
- (add-to-list)<Info-virtual-files>: Add "\\`dir\\'".
- (Info-directory-toc-nodes, Info-directory-find-file)
- (Info-directory-find-node): New functions.
- (add-to-list)<Info-virtual-files>: Add "\\`\\*History\\*\\'".
- (Info-history): Move part of code to
- `Info-history-find-node'.
- (Info-history-toc-nodes, Info-history-find-file)
- (Info-history-find-node): New functions.
- (add-to-list)<Info-virtual-nodes>: Add "\\`\\*TOC\\*\\'".
- (Info-toc): Move part of code to `Info-toc-find-node'.
- (Info-toc-find-node): New function.
- (Info-toc-insert): Rename from `Info-insert-toc'. Don't insert
- the current Info file name to references because now the node
- "*TOC*" belongs to the same Info manual.
- (Info-toc-build): Rename from `Info-build-toc'.
- (Info-toc-nodes): Rename input argument `file' to `filename'.
- Use Info-virtual-fun, Info-virtual-call and Info-virtual-file-p
- instead of ad-hoc processing of ("dir" apropos history toc).
- (Info-index-nodes): Use Info-virtual-file-p
- to check for a virtual file instead of checking a fixed list
- of node names.
- (Info-index-node): Add check for `Info-current-node-virtual'.
- Raise `save-match-data' higher up the tree to contain
- `search-forward' too (bug fix).
- (add-to-list)<Info-virtual-nodes>: Add "\\`\\*Index.*\\*\\'".
- (Info-virtual-index-nodes): New variable.
- (Info-virtual-index-find-node, Info-virtual-index): New functions.
- (add-to-list)<Info-virtual-files>: Add "\\`\\*Apropos\\*\\'".
- (Info-apropos-file, Info-apropos-nodes): New variables.
- (Info-apropos-toc-nodes, Info-apropos-find-file)
- (Info-apropos-find-node, Info-apropos-matches): New functions.
- (info-apropos): Move part of code to `Info-apropos-find-node' and
- `Info-apropos-matches'.
- (Info-mode-map): Bind "I" to `Info-virtual-index'.
- (Info-desktop-buffer-misc-data): Use Info-virtual-file-p to check
- for a virtual file instead of checking a fixed list of node names.
-
- * simple.el (async-shell-command): New command.
-
- * bindings.el (esc-map): Bind "&" to `async-shell-command'.
-
- * net/tramp-gvfs.el (tramp-gvfs-connection-mounted-p): Use `elt'
- instead of `mount-info'.
-
-2009-07-02 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp-gvfs.el (tramp-gvfs-handler-mounted-unmounted)
- (tramp-gvfs-connection-mounted-p): Handle changed mount-info interface.
-
-2009-07-02 Kenichi Handa <handa@m17n.org>
-
- * international/mule.el (set-keyboard-coding-system): Force *-unix
- coding-system to avoid eol conversion.
-
-2009-07-01 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp-gvfs.el (tramp-gvfs-file-name-handler-alist):
- Add handler for `process-file', `shell-command' and
- `start-file-process'.
- (tramp-gvfs-handle-shell-command)
- (tramp-gvfs-handle-start-file-process)
- (tramp-gvfs-handle-process-file): New defuns.
- (tramp-synce-list-devices): Simplify check for existence of property.
-
-2009-07-01 Jan Djärv <jan.h.d@swipnet.se>
-
- * startup.el (command-line-x-option-alist): Add -mm and --maximized.
-
-2009-07-01 Eduard Wiebe <usenet@pusto.de> (tiny change)
-
- * language/korean.el (set-language-info-alist): Add korean-cp949,
- cp949 to spec.
-
-2009-07-01 Kenichi Handa <handa@m17n.org>
-
- * Makefile.in (ELCFILES): Delete encoded-kb.elc.
-
- * international/encoded-kb.el: Deleted.
-
- * international/mule.el (set-keyboard-coding-system): Perform the
- necessary setup here instead of calling encoded-kbd-setup-display.
-
-2009-07-01 Glenn Morris <rgm@gnu.org>
-
- * progmodes/f90.el (f90-break-delimiters, f90-no-break-re): Doc fixes.
-
-2009-07-01 Evangelos Evangelou <vangelis@email.unc.edu> (tiny change)
-
- * progmodes/f90.el (f90-no-break-re): Add "(/" and "/)". (Bug#3730)
-
-2009-06-30 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-do-copy-or-rename-file-directly):
- Handle also the 'rename case, when setting file modes. (Bug#3712)
- (tramp-default-file-modes): Remove execute permissions.
-
- * net/tramp-gvfs.el (tramp-gvfs-methods): Add "synce" method.
- (top): Add a default for "synce" in `tramp-default-user-alist'.
- Add completion function for "synce" method.
- (tramp-hal-service, tramp-hal-path-manager)
- (tramp-hal-interface-manager, tramp-hal-interface-device):
- New defconst.
- (tramp-gvfs-connection-mounted-p): Handle empty user name for synce.
- (tramp-synce-list-devices, tramp-synce-parse-device-names):
- New defuns.
+ * net/tramp-sh.el (tramp-methods): Exchange "%k" marker with options.
* net/trampver.el: Update release number.
-2009-06-30 Kenichi Handa <handa@m17n.org>
-
- * international/fontset.el (setup-default-fontset): Add CJK fonts
- for symbols and the other miscellaneous characters.
-
- * language/korea-util.el (setup-korean-environment-internal):
- Make char-width-table suitable for Korean environments.
- (exit-korean-environment): Cancel above.
-
- * language/chinese.el ("Chinese-GB", "Chinese-BIG5")
- ("Chinese-CNS", "Chinese-EUC-TW", "Chinese-GBK"): Add a
- setup-function to make char-width-table suitable for respective
- environments, and an exit-function to cancel that.
-
- * language/japan-util.el (setup-japanese-environment-internal):
- Call use-cjk-char-width-table with arg `ja_JP'.
-
- * international/characters.el (cjk-char-width-table): Delete it.
- (cjk-char-width-table-list): New variable.
- (use-cjk-char-width-table): New arg local-name.
- (use-default-char-width-table): Fix for the case that Emacs is
- already using the default char-width-table.
-
-2009-06-29 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-do-copy-or-rename-file-directly): Set file
- modes mandatory. (Bug#3712)
-
-2009-06-29 Alan Mackenzie <acm@muc.de>
-
- * progmodes/cc-cmds.el (c-mask-paragraph): Remove a spurious
- correction between the visible width of TABs and their number of bytes.
-
-2009-06-29 Chong Yidong <cyd@stupidchicken.com>
-
- * server.el (server-buffer-done): Prevent kill-buffer from
- prompting by clearing the buffer modification flag (Bug#3696).
-
-2009-06-28 Michael McNamara <mac@mail.brushroad.com>
-
- * progmodes/verilog-mode.el (verilog-beg-of-statement)
- (verilog-endcomment-reason-re): Support unique case and priority case.
- (verilog-basic-complete-re): Support localparam lineup.
- (verilog-beg-of-statement-1): Fix for robustness, unique case.
- (verilog-set-auto-endcomments): Fix for unique case, always_comb
- commenting.
- (verilog-leap-to-case-head): Now support *nested* unique &
- priority case statements.
- (verilog-auto-lineup): Make just declarations the default (as it
- had been).
- (verilog-leap-to-case-head): Support priority/unique case statements.
- (verilog-auto-lineup): Rework to give users radio buttons to
- select the various styles of automatic lineup.
- (verilog-error-regexp-alist): Rework to support the XEmacs style
- of error regular expressions from compilers, lint tools &
- simulators. Note that GNU Emacs has made it impossible for a mode
- to load such things.
- (electric-verilog-terminate-line, verilog-indent-declaration)
- (verilog-auto-wiure): Rework for radio button selection of
- auto-lineup selection of specification of auto lineup.
- (verilog-beg-of-statement-1): Redesign to support proper operation
- in additional code, based on testing with auto-lineup.
- (verilog-calculate-indent, assignments & declarations)
- (verilog-backward-token): Enhance to support auto-lineup of
- assignments & declarations.
- (verilog-in-directive-p, verilog-at-struct-p): New function for
- easy test of whether we are.
- (verilog-pretty-declarations, verilog-pretty-expr): Massive rework
- to support safe execution at almost anyline.
- (verilog-calc-1): Properly support indenting deep inside generate
- blocks.
- (verilog-init-font): Remove definition & use of verilog-init-font,
- as it is redundant with font-lock-defaults.
- (verilog-mode): Alter the definition of verilog-font-lock-defaults
- to avoid circular calls if syntax-ppss is a function (as is the
- case now in 22.x GNU Emacs) as that function would sometimes call
- itself, leading to (nearly) infinite recursion.
- (verilog-ovm-begin-re, verilog-ovm-end-re)
- (verilog-ovm-statement-re, verilog-leap-to-head)
- (verilog-backward-token): Add support for OVM macros. Some are
- complete statements, and others open and close scopes like begin
- and end.
- (verilog-defun-level-not-generate-re, verilog-defun-level-re)
- (verilog-defun-level-generate-only-re): Really fix the defun-list
- compilation issue.
- (verilog-calc-1, verilog-beg-of-statement): Enhance support for
- coverpoint, constraint and cross statements.
- (verilog-defun-level-list, verilog-generate-defun-level-list)
- (verilog-all-defun-level-list): Redo these specifications - it is
- too hard to support eval-when compile aggregation of lists also
- built at when-compile time.
- (verilog-defun-level-list): Place defconsts of variables used in
- building regular expressions which are built in eval-when-compile
- bodies in the same eval-when-compile body to facilitate compile
- without load.
- (verilog-beg-block-re-ordered): Support indenting
- virtual/protected tasks and functions.
- (verilog-defun-level-list, verilog-in-generate-region-p)
- (verilog-backward-ws&directives, verilog-calc-1): Speed up
- indentation of some module items (generate items).
- (verilog-forward-sexp, verilog-leap-to-head): Support stepping
- across virtual/protected tasks and functions.
-
-2009-06-28 Wilson Snyder <wsnyder@wsnyder.org>
-
- * progmodes/verilog-mode.el (verilog-auto-arg, verilog-auto-arg-sort):
- Allow sorting AUTOARG lists. Suggested by Andrea Fedeli.
- (verilog-read-sub-decls-line): Fix AUTOWIRE signals getting lost
- in concatenations. Reported by Yishay Belkind.
- (verilog-auto-ascii-enum): Support one-hot state machines in
- AUTOASCIIENUM. Suggested by Lloyd Gomez.
- (verilog-auto-inst, verilog-auto-inst-port): Include interface
- modport in AUTOINST and add vl-modport for users.
- Reported by David Rogoff.
- (verilog-auto-inout-module, verilog-auto-inst)
- (verilog-decls-get-interfaces, verilog-insert-definition)
- (verilog-insert-one-definition, verilog-read-decls)
- (verilog-read-sub-decls, verilog-read-sub-decls-sig)
- (verilog-sig-modport, verilog-signals-combine-bus)
- (verilog-subdecls-get-interfaces): Fix expansion of SystemVerilog
- interfaces in AUTOINOUTMODULE, AUTOINOUTCOMP, and AUTOINST.
- Suggested by David Rogoff.
- (verilog-repair-open-comma): Fix non-insertion of comma when
- `DEFINE occurs in V2K argument list. Reported by Lane Brooks.
- (verilog-make-width-expression): Simplify [A-1:0] expression
- widths to just {A{1'b0}}.
- (verilog-mode): Cleanup checkdoc warnings.
- (verilog-auto-inout-module, verilog-signals-matching-dir-re):
- Add third optional regexp to AUTOINOUTMODULE to allow selecting only
- inputs/outputs or data type. Suggested by Vasu Kandadi.
- (next-error-last-buffer): Fix byte-compiler warning.
- (verilog-auto, verilog-auto-insert-lisp, verilog-auto-inst)
- (verilog-delete-auto): Add AUTOINSERTLISP to insert arbitrary lisp
- or shell command text during AUTO expansion. Suggested by Tad Truex.
- (verilog-read-sub-decls-expr, verilog-read-sub-decls-line)
- (verilog-read-sub-decls-sig, verilog-symbol-detick-text):
- Fix dotted nets {a.b,c.d} and excaped identifiers being mis-included
- in AUTOINOUT. Reported by Matthew Lovell.
- (verilog-read-always-signals-recurse): Fix AUTORESET "if (a<=b)"
- causing use of <= assignments. Reported by Alex Reed.
- (verilog-read-decls): Fix triand, trior, wand, wor to be
- recognized by AUTOWIRE. Reported by Spencer Isaacson.
- (verilog-extended-complete-re): Support import "DPI-C" functions.
- (verilog-read-always-signals-recurse): Fix AUTORESET of "x <=
- y[a+1:a+1]" to not include a in reset list. Reported by Dan Dever.
- (verilog-insert-date, verilog-insert-year)
- (verilog-sk-header-tmpl): Fix verilog-header inserting error on
- Windows systems. Reported by Michael Potts.
- (verilog-read-module-name): Fix AUTOINST when the child module
- declaration's name is a tick define. Reported by Elliot Mednick.
- (verilog-read-decls): Fix V2K parameter bit subscripts getting
- passed to next parameter's definition. Reported by Bruce T.
- (verilog-read-decls): Fix detecting "parameter int" when using
- AUTOINSTPARAM. Reported by Bruce T.
- (verilog-goto-defun): Fix goto not finding modules unless first
- perform a verilog-auto expansion. Suggested by Lawrence Butcher.
- (verilog-mode): Expand -f flag arguments on entry to mode so
- verilog-goto-defun will work. Reported by Lawrence Butcher.
- (verilog-getopt): Expand environment variables in -f file
- arguments. Suggested by Lawrence Butcher.
- (verilog-set-define): Fix "Symbol's value as variable is void"
- when reading enumerations.
- (verilog-auto-ascii-enum): Fix duplicate labels in AUTOASCIIENUM.
- Suggested by Stephen Peltan.
- (verilog-read-defines): Fix reading of enumerations in include
- files. Reported by Steve Peltan.
-
-2009-06-28 David De La Harpe Golden <david@harpegolden.net>
-
- * files.el (trash-directory): Fix defcustom type.
-
-2009-06-28 Juri Linkov <juri@jurta.org>
-
- * help-fns.el (describe-function-1): Correctly locate adviced
- functions in hyperlink (Bug#2438).
-
-2009-06-28 Chong Yidong <cyd@stupidchicken.com>
-
- * files.el (trash-directory): Change default to nil.
- (move-file-to-trash): If trash-directory is nil and
- system-move-file-to-trash is unbound, perform freedesktop-style
- trashing.
-
-2009-06-28 David De La Harpe Golden <david@harpegolden.net>
-
- * files.el (move-file-to-trash): Add freedesktop trash
- support (Bug#973).
-
-2009-06-28 Glenn Morris <rgm@gnu.org>
-
- * autorevert.el (global-auto-revert-non-file-buffers)
- (global-auto-revert-mode): Doc fixes.
-
-2009-06-27 Johan Bockgård <bojohan@gnu.org>
-
- * emacs-lisp/cl-specs.el (defstruct): Fix :conc-name spec.
-
-2009-06-27 Chong Yidong <cyd@stupidchicken.com>
-
- * faces.el (x-handle-named-frame-geometry): Ensure that we have
- opened an X connection before calling x-get-resource (Bug#3194).
-
- * play/doctor.el: Remove reference to obsolete website.
- (make-doctor-variables): Correct grammar mistake (Bug#2633).
-
-2009-06-26 Dan Nicolaescu <dann@ics.uci.edu>
-
- Remove find-file-not-found-hook VC method. (Bug#2757)
- * vc-hooks.el (vc-file-not-found-hook)
- (vc-default-find-file-not-found-hook): Remove functions.
- (find-file-not-found-functions): Do not add vc-file-not-found-hook.
- * vc-rcs.el (vc-rcs-find-file-not-found-hook): Remove function.
- * vc.el:
- * vc-hg.el:
- * vc-git.el: Do not mention find-file-not-found-hook VC method.
-
-2009-06-25 Agustín Martín <agustin.martin@hispalinux.es>
-
- * textmodes/ispell.el: Add `ispell-looking-back' XEmacs
- compatibility function for `looking-back'.
-
- * textmodes/flyspell.el (sgml-mode-flyspell-verify):
- Use `ispell-looking-back'.
-
-2009-06-24 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp-gvfs.el (tramp-gvfs-handle-make-directory): Use `dir'
- rather than `filename'.
-
-2009-06-23 Miles Bader <miles@gnu.org>
-
- * face-remap.el (text-scale-set): New function.
-
-2009-06-23 Glenn Morris <rgm@gnu.org>
-
- * pcmpl-rpm.el (pcomplete/rpm): Doc fix.
-
- * bindings.el (mode-line-modified): Fix case of "Buffer is modified".
-
- * textmodes/ispell.el (ispell-local-dictionary): Doc fix.
+2011-03-12 Stefan Monnier <monnier@iro.umontreal.ca>
- * progmodes/gdb-mi.el (gud-remove, gud-break): Update declarations.
+ * progmodes/compile.el (compilation--previous-directory): Fix up
+ various nil/dead-marker mismatches (bug#8014).
+ (compilation-directory-properties, compilation-error-properties):
+ Don't call it at a position past the one we're about to change.
- * calendar/cal-dst.el (calendar-time-zone-daylight-rules):
- Simplify Persian conditionals.
+ * emacs-lisp/bytecomp.el (byte-compile-make-obsolete-variable):
+ Disable obsolescence warnings in the file that declares it.
- * calc/calc-graph.el (calc-graph-plot): Avoid assignment to free
- variable `filename'.
+2011-03-11 Ken Manheimer <ken.manheimer@gmail.com>
- * comint.el (comint-insert-input): Doc fix.
+ * allout-widgets.el (allout-widgets-tally):
+ Initialize allout-widgets-tally as a hash table rather than nil to
+ prevent mode-line redisplay warnings. Also, clarify the module
+ description and fix a comment typo.
- * Makefile.in (ELCFILES): Fix typo in previous change.
+2011-03-11 Juanma Barranquero <lekktu@gmail.com>
-2009-06-23 Miles Bader <miles@gnu.org>
+ * help-fns.el (describe-variable): Don't complete keywords.
+ Suggested by Teodor Zlatanov <tzz@lifelogs.com>.
- * cus-start.el: Add entry for `recenter-redisplay'.
+2011-03-10 Chong Yidong <cyd@stupidchicken.com>
-2009-06-23 Dan Nicolaescu <dann@ics.uci.edu>
+ * emacs-lisp/package.el (package-version-join): Impose a standard
+ string representation for pre/alpha/beta version lists.
+ (package-unpack-single): Standardize the directory name by passing
+ it through package-version-join.
+ (package-strip-rcs-id): Accept any version string that does not
+ signal an error in version-to-list.
- * vc-hooks.el (vc-stay-local-p, vc-state, vc-working-revision):
- Add an optional argument for the backend, use it instead of
- calling vc-backend.
- (vc-mode-line): Add an optional argument for the backend.
- Pass the backend to vc-state and vc-working-revision. Move code for
- special handling for vc-state being a buffer to ...
+2011-03-10 Michael Albinus <michael.albinus@gmx.de>
- * vc-rcs.el (vc-rcs-find-file-hook):
- * vc-sccs.el (vc-sccs-find-file-hook): ... here. New functions.
+ * simple.el (delete-trailing-whitespace): Return nil for the
+ benefit of `write-file-functions'.
- * vc-svn.el (vc-svn-state, vc-svn-dir-status, vc-svn-checkout)
- (vc-svn-print-log, vc-svn-diff): Pass 'SVN to vc-state,
- vc-stay-local-p and vc-mode-line calls.
+2011-03-10 Glenn Morris <rgm@gnu.org>
- * vc-cvs.el (vc-cvs-state, vc-cvs-checkout, vc-cvs-print-log)
- (vc-cvs-diff, vc-cvs-annotate-command)
- (vc-cvs-make-version-backups-p, vc-cvs-stay-local-p)
- (vc-cvs-dir-status): Pass 'CVS to vc-state, vc-stay-local-p and
- vc-mode-line calls.
+ * vc/vc-hg.el (vc-hg-pull, vc-hg-merge-branch): Use vc-hg-program.
- * vc.el (vc-deduce-fileset): Use vc-deduce-fileset instead of
- direct comparison.
- (vc-next-action, vc-transfer-file, vc-rename-file): Also pass the
- backend when calling vc-mode-line.
- (vc-register): Do not create a closure for calling the vc register
- function, call it directly.
+ * vc/vc-git.el (vc-git-program): New option.
+ (vc-git-branches, vc-git-pull, vc-git-merge-branch, vc-git-command)
+ (vc-git--call): Use it.
-2009-06-23 Dan Nicolaescu <dann@ics.uci.edu>
+ * eshell/esh-util.el (eshell-condition-case): Doc fix.
- * emacs-lisp/elp.el (elp-output-insert-symname): Add a link face
- to make it obvious item can be clicked.
+ * cus-edit.el (Custom-newline): If no button at point, look
+ for a subgroup button at start-of-line. (Bug#2298)
- * vc-mtn.el (vc-mtn-after-dir-status, vc-mtn-dir-status): New functions.
+ * mail/rmail.el (rmail-msgend, rmail-msgbeg): Doc fixes.
-2009-06-23 Kenichi Handa <handa@m17n.org>
+2011-03-10 Julien Danjou <julien@danjou.info>
- * language/korea-util.el (korean-key-bindings): Change the binding
- of F9 to hangul-to-hanja-conversion. Bind Hangul_Hanja to the
- same command.
+ * avoid.el (mouse-avoidance-ignore-p): Do not move the cursor if
+ `cursor-type' is nil.
-2009-06-22 Michael Albinus <michael.albinus@gmx.de>
+2011-03-09 Jay Belanger <jay.p.belanger@gmail.com>
- Sync with Tramp 2.1.16.
+ * calc/calc.el (calc-mode-map): Don't bind "C-_" to `calc-missing-key'.
- * Makefile.in (ELCFILES): Add net/tramp-gvfs.elc.
+2011-03-09 Ken Manheimer <ken.manheimer@gmail.com>
- * net/tramp.el (top): Require tramp-gvfs. Catch `tramp-loading',
- when a loading of a package fails. Completion function for rsync
- is `tramp-completion-function-alist-ssh'.
- (all): Replace all calls of `split-string' and
- `tramp-split-string' by `tramp-compat-split-string'.
- (tramp-default-method): Use `tramp-compat-process-running-p'.
- (tramp-default-proxies-alist): Allow also Lisp forms.
- (tramp-remote-path): Add choice "Private Directories".
- (tramp-wrong-passwd-regexp): Remove "Tramp connection closed" option.
- (tramp-domain-regexp): Allow also "-", "_" and ".".
- (tramp-end-of-output): Remove newlines, and add "$" at the end.
- (tramp-file-name-handler-alist): Add handler for `dired-uncache'.
- (tramp-debug-message): Insert header line in debug buffer.
- (tramp-handle-directory-files-and-attributes-with-stat):
- Care about filenames with spaces, or starting with "-".
- (tramp-handle-dired-uncache): New defun.
- (tramp-handle-insert-directory): Don't flush the directory from
- cache, this is handled by `dired-uncache' now.
- (tramp-handle-insert-file-contents): Improve error handling.
- (tramp-find-shell, tramp-open-connection-setup-interactive-shell):
- Quote `tramp-end-of-output'.
- (tramp-action-password): Improve trace message.
- (tramp-check-for-regexp): Both echoes must be present, before removing.
- (tramp-open-connection-setup-interactive-shell): Trace coding system.
- (tramp-compute-multi-hops): Eval cons cells of
- `tramp-default-proxies-alist'.
- (tramp-maybe-open-connection): Use the same command pattern for
- first hop and further hops.
- (tramp-wait-for-output): Remove handling of newlines.
- (tramp-get-remote-path): Handle also `tramp-own-remote-path'.
- (tramp-split-string): Remove function. It is handled in
- tramp-compat now.
+ * allout.el Summary: Change so yank of distinctive-bullet items
+ preserves the existing header prefix, rebulleting it if necessary,
+ rather than replacing it. This is necessary for proper operation
+ of cooperative addons like allout-widgets.
+ (allout-make-topic-prefix, allout-rebullet-heading): Change
+ SOLICIT arg to INSTEAD, and interpret additionally a string value
+ as alternate bullet to be used, instead of prompting the user for
+ a bullet character.
- * net/tramp-cmds.el (tramp-bug):
- Recommend `tramp-cleanup-all-connections' in the bug mail.
+2011-03-09 Michael Albinus <michael.albinus@gmx.de>
- * net/tramp-compat.el (tramp-compat-split-string)
- (tramp-compat-process-running-p): New defuns.
+ * net/tramp-sh.el (tramp-do-copy-or-rename-file-out-of-band):
+ Do not use `tramp-file-name-port', because this returns also
+ `tramp-default-port'.
- * net/tramp-fish.el (tramp-fish-file-name-handler-alist): Add handler
- for `dired-uncache'.
+2011-03-09 Deniz Dogan <deniz.a.m.dogan@gmail.com>
- * net/tramp-gvfs.el: New package.
+ * net/rcirc.el (rcirc-handler-001): Remove useless
+ with-rcirc-process-buffer.
+ (rcirc-check-auth-status): Swap arguments to string-match.
- * net/tramp-smb.el (tramp-smb-file-name-handler-alist):
- Add handler for `dired-uncache'.
- (tramp-smb-handle-file-local-copy): Cleanup in case of error.
+2011-03-09 Glenn Morris <rgm@gnu.org>
- * net/trampver.el: Update release number. Make version check fit
- for SXEmacs 22.
+ * shell.el (shell-mode):
+ Set comint-input-ring-size from HISTSIZE. (Bug#7889)
-2009-06-22 Jim Meyering <meyering@redhat.com>
+ * progmodes/gdb-mi.el (gdb): Improve 2010-12-08 change.
+ Check for GDBHISTFILE, HISTSIZE, etc. (Bug#7889)
- Automatically handle .xz suffix (XZ-compressed files), too.
- * jka-cmpr-hook.el (jka-compr-compression-info-list): Add xz.
- XZ is the successor to LZMA: <http://tukaani.org/xz/>
+2011-03-08 Chong Yidong <cyd@stupidchicken.com>
-2009-06-22 Dmitry Dzhus <dima@sphinx.net.ru>
- Nick Roberts <nickrob@snap.net.nz>
+ * emacs-lisp/package.el (package-refresh-contents)
+ (package-menu-execute): Use condition-case-no-debug.
- * progmodes/gdb-mi.el: Pull further modified changes from Dmitry's
- repository (http://sphinx.net.ru/hg/gdb-mi/).
+2011-03-08 Michael Albinus <michael.albinus@gmx.de>
-2009-06-22 Glenn Morris <rgm@gnu.org>
+ * simple.el (shell-command-to-string): Use `process-file'.
- * files.el (dir-locals-collect-mode-variables): Allow for any number of
- `mode' and `eval' entries. (Bug#3430)
+ * emacs-lisp/package.el (package-tar-file-info): Handle also
+ remote files.
- * Makefile.in (ELCFILES): Add fadr.elc.
+ * emacs-lisp/package-x.el (package-upload-buffer-internal):
+ Use `equal' for upload base check.
- * calendar/appt.el (appt-make-list): Fix off-by-one error caused by
- differing behavior of \n and ^ in strings. (Bug#3385)
+2011-03-08 Arni Magnusson <arnima@hafro.is> (tiny change)
- * emacs-lisp/cl-indent.el: Remove leading "*" from defcustom docs.
+ * textmodes/texinfo.el (texinfo-environments):
+ Add deftypecv, deftypeivar, deftypemethod, deftypeop, html. (Bug#2783)
- * emacs-lisp/lisp-mode.el (lisp-indent-offset): Fix safe-local-variable
- property.
- (lisp-indent-function): Make it a defcustom.
+2011-03-08 Glenn Morris <rgm@gnu.org>
-2009-06-21 Nick Roberts <nickrob@snap.net.nz>
+ * cus-start.el (cursor-in-non-selected-windows):
+ Fix :set quoting oddness. (Bug#8192)
- * progmodes/gdb-ui.el: Replace with ...
- * progmodes/gdb-mi.el: ... this file.
- * progmodes/gud.el: Modify for gdb-mi.el.
+ * font-lock.el (lisp-font-lock-keywords-1): Don't highlight `)'
+ in some setf expressions. (Bug#2159)
-2009-06-21 Dmitry Dzhus <dima@sphinx.net.ru>
+2011-03-08 Chong Yidong <cyd@stupidchicken.com>
- * fadr.el: New file.
+ * custom.el (custom-available-themes): Return themes in
+ alphabetical order.
-See ChangeLog.14 for earlier changes.
+See ChangeLog.15 for earlier changes.
;; Local Variables:
;; coding: utf-8
;; End:
- Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
diff --git a/lisp/ChangeLog.1 b/lisp/ChangeLog.1
index a393b120b5a..f1c931589d1 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,58 +3194,60 @@
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.
- Copyright (C) 1985, 1986, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
- Free Software Foundation, Inc.
+ Copyright (C) 1985-1986, 2001-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -3263,5 +3263,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: b6060738-7fac-4c9c-80ae-67995bae78a7
diff --git a/lisp/ChangeLog.10 b/lisp/ChangeLog.10
index 301802899b8..1c2f2b5b015 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'.
@@ -23534,8 +23534,7 @@ See ChangeLog.9 for earlier changes.
;; coding: utf-8
;; End:
- Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006,
- 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 2001-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -23552,4 +23551,3 @@ See ChangeLog.9 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: 5fcf8004-6f58-452a-b9d6-6950323a19c1
diff --git a/lisp/ChangeLog.11 b/lisp/ChangeLog.11
index ab33c746fee..76bac50c4b8 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.
@@ -14336,8 +14336,7 @@ See ChangeLog.10 for earlier changes.
;; coding: utf-8
;; End:
- Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
- Free Software Foundation, Inc.
+ Copyright (C) 2003-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -14353,5 +14352,3 @@ See ChangeLog.10 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: 2fe8d7b0-27e3-4634-a0b7-db70ff071825
diff --git a/lisp/ChangeLog.12 b/lisp/ChangeLog.12
index ea50cbf5d4f..35572bd6105 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
@@ -10699,9 +10699,6 @@
output of the next command. Reported by M Jared Finder
<jared@hpalace.com>.
- * net/tramp-vc.el (vc-user-login-name): Wrap defadvice with a test
- for `process-file', in order to let it work for older Emacsen too.
-
2006-04-17 Ralf Angeli <angeli@iwi.uni-sb.de>
* textmodes/tex-mode.el (tex-font-lock-match-suscript): New function.
@@ -10862,7 +10859,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 +10878,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 +13663,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 +16157,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 +19703,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 +20585,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 +20754,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 +29162,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 +29349,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 +29418,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 +29600,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 +31915,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 +32506,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 +32778,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 +32889,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.
@@ -33349,7 +33346,7 @@ See ChangeLog.11 for earlier changes.
;; add-log-time-zone-rule: t
;; End:
- Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 2005-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -33366,4 +33363,3 @@ See ChangeLog.11 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: e39939be-dab3-400e-86f5-0e2701a883c1
diff --git a/lisp/ChangeLog.13 b/lisp/ChangeLog.13
index 96fcebd69b0..8cbe1ad5776 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.
@@ -16696,7 +16696,7 @@ See ChangeLog.12 for earlier changes.
;; coding: utf-8
;; End:
- Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 2007-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
diff --git a/lisp/ChangeLog.14 b/lisp/ChangeLog.14
index 54d41f4d0ed..c1313cfd16f 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):
@@ -20547,7 +20551,7 @@ See ChangeLog.13 for earlier changes.
;; coding: utf-8
;; End:
- Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 2008-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -20564,4 +20568,3 @@ See ChangeLog.13 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: c241c1f9-d668-48bf-920a-2897ed0340bc
diff --git a/lisp/ChangeLog.15 b/lisp/ChangeLog.15
new file mode 100644
index 00000000000..3cb6c00b6ee
--- /dev/null
+++ b/lisp/ChangeLog.15
@@ -0,0 +1,22810 @@
+2011-03-07 Chong Yidong <cyd@stupidchicken.com>
+
+ * Version 23.3 released.
+
+2011-03-07 Chong Yidong <cyd@stupidchicken.com>
+
+ * progmodes/cc-cmds.el (c-beginning-of-statement): Fix incorrect
+ application of patch from Alan Mackenzie (Bug#7595).
+
+2011-03-07 Deniz Dogan <deniz.a.m.dogan@gmail.com>
+
+ * net/rcirc.el (rcirc-connect): Fix PASS bug.
+
+2011-03-07 Glenn Morris <rgm@gnu.org>
+
+ * vc/vc.el (vc-next-action): Add missing space to y-or-n-p prompt.
+ Give an explicit error if failed to make writable. (Bug#6146)
+
+2011-03-07 Ed Reingold <reingold@emr.cs.iit.edu>
+
+ * calendar/cal-hebrew.el (diary-hebrew-yahrzeit):
+ Add optional `after-sunset' argument. (Bug#8190)
+
+2011-03-07 Aaron S. Hawley <aaron.s.hawley@gmail.com>
+
+ * play/morse.el (nato-alphabet, nato-region, denato-region):
+ New variable and functions. (Bug#2288)
+ (morse-region, unmorse-region): Barf if read-only.
+
+2011-03-06 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/gud.el (gdb-script-syntax-propertize-function):
+ Don't change the syntax of a \n that closes a comment (bug#8169).
+
+2011-03-06 Chong Yidong <cyd@stupidchicken.com>
+
+ * emacs-lisp/package-x.el (package-archive-upload-base): Make it a
+ defcustom.
+ (package--update-file): Doc fix. Accept relative file names.
+ (package--archive-contents-from-file): Remove the argument, since
+ it's necessarily always "archive-contents".
+ (package-maint-add-news-item): Pass relative file name args to
+ package--update-file.
+ (package-upload-buffer-internal): Prompt for a destination if
+ package-archive-upload-base is invalid. Create the directory if
+ it does not exist.
+ (package-upload-buffer, package-upload-file): Doc fix.
+
+2011-03-06 Chong Yidong <cyd@stupidchicken.com>
+
+ * isearch.el (isearch-mode-map): Bind C-y to isearch-yank-kill,
+ and move isearch-yank-line to M-s C-e (Bug#8183).
+
+2011-03-06 Alan Mackenzie <acm@muc.de>
+
+ * progmodes/cc-engine.el (c-guess-basic-syntax): Reindent.
+ (c-guess-basic-syntax): Move CASE 19 to a different place,
+ correctly to process template-args-cont lines.
+
+2011-03-06 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc-ext.el (calc-init-extensions):
+ Rename calc-logunits-dblevel and calc-logunits-nplevel to calc-dblevel
+ and calc-nplevel, respectively. Add keybindings for calc-spn,
+ calc-midi and calc-freq. Add autoloads for calcFunc-spn,
+ calcFunc-midi, calcFunc-freq, calc-spn, calc-midi and calc-freq.
+
+ * calc/calc-units.el (calc-dblevel): Rename from
+ calc-logunits-dblevel.
+ (calc-nplevel): Rename from calc-logunits-nplevel.
+ (math-midi-round, math-freqp, math-midip, math-spnp)
+ (math-spn-to-midi, math-midi-to-spn, math-freq-to-spn)
+ (math-midi-to-freq, math-spn-to-freq, calcFunc-spn, calcFunc-midi)
+ (calcFunc-freq, calc-freq, calc-midi, calc-spn): New functions.
+ (math-notes): New variable.
+
+ * calc/calc.el (calc-note-threshold): New variable.
+
+2011-03-06 Chong Yidong <cyd@stupidchicken.com>
+
+ * emacs-lisp/package.el (package-archives): Accept either ordinary
+ directory names, in addition to HTTP URLs.
+ (package--with-work-buffer): New macro. Handle normal directories.
+ (package-handle-response): Don't display the failing buffer.
+ (package-download-single, package-download-tar)
+ (package--download-one-archive): Use package--with-work-buffer.
+ (package-archive-base): Rename from package-archive-url.
+
+2011-03-06 Glenn Morris <rgm@gnu.org>
+
+ * generic-x.el (generic-unix-modes): Add xmodmap-generic-mode.
+ (xmodmap-generic-mode): Respect generic-extras-enable-list.
+
+2011-03-06 Daniel Clemente <dcl441-bugs@yahoo.com> (tiny change)
+
+ * generic-x.el (xmodmap-generic-mode): New. (Bug#2065)
+
+2011-03-06 Juanma Barranquero <lekktu@gmail.com>
+
+ * allout.el (allout-init, allout-prefixed-keybindings)
+ (allout-unprefixed-keybindings):
+ * progmodes/prolog.el (prolog-find-term):
+ Fix typos in docstrings.
+
+2011-03-06 Nikolaj Schumacher <me@nschum.de> (tiny change)
+
+ * emacs-lisp/elp.el (elp-results): Fix off-by-one in header. (Bug#2746)
+
+2011-03-06 Kevin Ryde <user42@zip.com.au>
+
+ * textmodes/sgml-mode.el (sgml-fill-nobreak): Give it a doc. (Bug#5326)
+
+2011-03-06 Michael Shields <shields@msrl.com> (tiny change)
+
+ * window.el (one-window-p, walk-windows, display-buffer):
+ Doc fixes. (Bug#5567)
+
+2011-03-06 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * cus-edit.el (custom-prompt-variable): Use the `custom-get' property
+ of the variable if it exists.
+
+2011-03-06 Juanma Barranquero <lekktu@gmail.com>
+
+ * bookmark.el:
+ * desktop.el:
+ * emacs-lock.el:
+ * ps-print.el:
+ * saveplace.el:
+ * net/tramp-cache.el:
+ * obsolete/fast-lock.el:
+ * textmodes/reftex.el:
+ Don't set `kill-emacs-hook' on noninteractive sessions (bug#8137).
+
+2011-03-05 Antoine Levitt <antoine.levitt@gmail.com>
+
+ * files.el (delete-directory, copy-directory, list-directory):
+ Use read-directory-name.
+
+ * find-file.el (ff-find-the-other-file):
+ * net/ange-ftp.el (ange-ftp-make-directory):
+ * printing.el (pr-interactive-dir):
+ * progmodes/ada-prj.el (ada-prj-load-directory):
+ * progmodes/ebnf2ps.el (ebnf-print-directory)
+ (ebnf-spool-directory, ebnf-eps-directory)
+ (ebnf-syntax-directory):
+ * shell.el (shell):
+ * speedbar.el (speedbar-create-directory):
+ * vc/emerge.el (emerge-merge-directories):
+ * vc/vc-dir.el (vc-dir):
+ * vc/vc.el (vc-create-tag, vc-retrieve-tag): Likewise.
+
+2011-03-05 Chong Yidong <cyd@stupidchicken.com>
+
+ * help-mode.el (help-buffer): If we are to return the current
+ buffer, signal an error if it's not in Help mode (Bug#8147).
+
+2011-03-05 Reuben Thomas <rrt@sc3d.org>
+
+ * files.el (file-name-version-regexp): Handle backup files of the
+ form `foo.js.~HEAD~1~' (Bug#8159).
+
+2011-03-05 Glenn Morris <rgm@gnu.org>
+
+ * eshell/esh-var.el: Don't require esh-test when compiling.
+ * eshell/em-banner.el, eshell/esh-cmd.el, eshell/esh-mode.el:
+ * eshell/esh-var.el, eshell/eshell.el: Move tests to esh-test.
+ * eshell/esh-test.el: Move to ../../test/eshell.el.
+
+2011-03-05 David Engster <deng@randomsample.de>
+
+ * files.el (save-some-buffers): Report the names of buffers saved
+ automatically due to buffer-save-without-query (Bug#8134).
+
+2011-03-05 Deniz Dogan <deniz.a.m.dogan@gmail.com>
+
+ * net/rcirc.el: Add QuakeNet authentication support.
+ (rcirc-authinfo, rcirc-check-auth-status)
+ (rcirc-authenticate): Support QuakeNet.
+
+2011-03-05 Deniz Dogan <deniz.a.m.dogan@gmail.com>
+
+ * net/rcirc.el: Add functionality to authenticate before
+ autojoining channels.
+ (rcirc-authenticate-before-join): New option.
+ (rcirc-authenticated-hook): New variable.
+ (rcirc-connect): Make local variable rcirc-user-authenticated.
+ (rcirc-handler-001): Respect rcirc-authenticate-before-join.
+ (rcirc-check-auth-status, rcirc-join-channels-post-auth):
+ New functions.
+ (rcirc-handler-PRIVMSG, rcirc-handler-NOTICE):
+ Call rcirc-check-auth-status.
+
+2011-03-05 Alex Harsanyi <AlexHarsanyi@gmail.com>
+
+ * net/soap-client.el (soap-namespace-put-link): Check if the target
+ name is fully qualified -- use only the name part.
+ (soap-parse-complex-type, soap-parse-sequence): Recognize xsd:all
+ types, treated the same as xsd:sequence. (Bug#8166)
+
+2011-03-05 Eli Zaretskii <eliz@gnu.org>
+
+ * files.el (find-file-noselect): Don't ask about re-visiting
+ non-literally if the file is already visited in image-mode.
+ (Bug#8177)
+
+2011-03-05 Glenn Morris <rgm@gnu.org>
+
+ * eshell/esh-mode.el (eshell-kill-buffer-function): New function.
+ (eshell-mode): Use eshell-kill-buffer-function.
+ Run the -initialize functions independently of the -load-hooks.
+ * eshell/esh-proc.el (eshell-kill-process-function): New function.
+ (eshell-gather-process-output, eshell-sentinel)
+ (eshell-interrupt-process, eshell-kill-process, eshell-quit-process):
+ Use eshell-kill-process-function.
+ * eshell/em-alias.el (eshell-alias-load-hook):
+ * eshell/em-banner.el (eshell-banner-load-hook):
+ * eshell/em-cmpl.el (eshell-cmpl-load-hook):
+ * eshell/em-dirs.el (eshell-dirs-load-hook):
+ * eshell/em-glob.el (eshell-glob-load-hook):
+ * eshell/em-hist.el (eshell-hist-load-hook):
+ * eshell/em-pred.el (eshell-pred-load-hook):
+ * eshell/em-prompt.el (eshell-prompt-load-hook):
+ * eshell/em-rebind.el (eshell-rebind-load-hook):
+ * eshell/em-script.el (eshell-script-load-hook):
+ * eshell/em-smart.el (eshell-smart-load-hook):
+ * eshell/em-term.el (eshell-term-load-hook):
+ * eshell/em-unix.el (eshell-unix-load-hook):
+ * eshell/esh-arg.el (eshell-arg-load-hook):
+ * eshell/esh-cmd.el (eshell-cmd-load-hook):
+ * eshell/esh-ext.el (eshell-ext-load-hook):
+ * eshell/esh-io.el (eshell-io-load-hook):
+ * eshell/esh-mode.el (eshell-exit-hook):
+ * eshell/esh-proc.el (eshell-proc-load-hook, eshell-kill-hook):
+ * eshell/esh-var.el (eshell-var-load-hook):
+ Set default hook values to nil. (Bug#5375)
+
+ * eshell/esh-module.el (eshell-module-unload-hook)
+ (eshell-modules-list): Remove leading * from defcustom docs.
+
+ * eshell/esh-util.el (eshell-for): Make it obsolete.
+ * eshell/em-alias.el (eshell/alias, eshell-alias-completions):
+ * eshell/em-dirs.el (eshell-save-some-last-dir):
+ * eshell/em-hist.el (eshell-save-some-history)
+ (eshell-hist-parse-modifier):
+ * eshell/em-ls.el (eshell-ls-dir, eshell-ls-files)
+ (eshell-ls-entries):
+ * eshell/em-unix.el (eshell/cat, eshell/du, eshell/su):
+ * eshell/esh-cmd.el (eshell-invoke-directly, eshell-do-eval)
+ (eshell/which):
+ * eshell/esh-ext.el (eshell-find-interpreter):
+ * eshell/esh-mode.el (eshell-mode):
+ * eshell/esh-module.el (eshell-unload-extension-modules):
+ * eshell/esh-proc.el (eshell-process-interact):
+ * eshell/esh-test.el (eshell-test):
+ * eshell/esh-util.el (eshell-flatten-list, eshell-winnow-list):
+ * eshell/esh-var.el (eshell/env, eshell-environment-variables)
+ (eshell-variables-list):
+ * eshell/eshell.el (eshell-unload-all-modules):
+ Replace eshell-for with dolist.
+
+2011-03-04 Glenn Morris <rgm@gnu.org>
+
+ * vc/vc-bzr.el (vc-bzr-after-dir-status): Handle bzr 2.3.0. (Bug#8170)
+
+2011-03-04 Tom Tromey <tromey@redhat.com>
+
+ * progmodes/gud.el (gdb-script-mode): Derive from prog-mode.
+
+2011-03-04 Glenn Morris <rgm@gnu.org>
+
+ * outline.el (outline-regexp): No longer allow nil.
+ (outline-heading-end-regexp): Add safety predicate. (Bug#7619)
+
+ * net/browse-url.el (browse-url):
+ Handle deleted default-directory. (Bug#6077)
+
+ * recentf.el (recentf-include-p): In case of a buggy predicate,
+ err on the side of including, not excluding. (Bug#5843)
+
+2011-03-04 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc-units.el (math-to-standard-rec): Don't treat subscripted
+ variables as units.
+
+2011-03-04 Bob Rogers <rogers@rgrjr.dyndns.org>
+
+ * emacs-lisp/ewoc.el (ewoc-goto-next): Give a more explicit error
+ if there is no node. (Bug#3261)
+
+2011-03-04 Leo <sdl.web@gmail.com>
+
+ * vc/diff-mode.el (diff-mode): Fix whitespace-style. (Bug#8139)
+
+ * time.el (display-time-world-list): Fix typo. (Bug#7571)
+
+2011-03-04 Zachary Kanfer <zkanfer@gmail.com> (tiny change)
+
+ * cus-edit.el (custom-buffer-create-internal):
+ Split search string before passing it to `customize-apropos' (bug#8136).
+
+2011-03-04 Drew Adams <drew.adams@oracle.com>
+
+ * image-dired.el (image-dired-cmd-read-exif-data-options):
+ Fix typo in docstring (bug#8156).
+
+2011-03-03 Deniz Dogan <deniz.a.m.dogan@gmail.com>
+
+ * net/rcirc.el (rcirc-cmd-join): Accept comma-separated input.
+
+2011-03-03 Christian Ohler <ohler@gnu.org>
+
+ * emacs-lisp/ert.el (ert--explain-equal): New function.
+ (ert--explain-equal-rec): Rename from `ert--explain-not-equal'.
+ All callers changed.
+ (ert--explain-equal-including-properties): Rename from
+ `ert--explain-not-equal-including-properties'. All callers
+ changed.
+
+2011-03-03 Christian Ohler <ohler@gnu.org>
+
+ * emacs-lisp/ert.el (ert--stats-set-test-and-result)
+ (ert-char-for-test-result, ert-string-for-test-result)
+ (ert-run-tests-batch, ert--print-test-for-ewoc):
+ Handle `ert-test-quit'.
+
+2011-03-03 David Abrahams <dave@boostpro.com> (tiny change)
+
+ * vc/ediff-init.el (ediff-use-faces, ediff-highlight-all-diffs):
+ Move ediff-defvar-local calls after defcustoms. (Bug#1821)
+
+2011-03-03 Glenn Morris <rgm@gnu.org>
+
+ * files.el (file-truename): Doc fix. (Bug#2341)
+
+2011-03-03 Bob Rogers <rogers-emacs@rgrjr.dyndns.org>
+
+ * vc/vc-dir.el (vc-dir-mode-map): Bind vc-dir-find-file to e (Bug#7349).
+
+2011-03-03 Vagn Johansen <gonz808@hotmail.com> (tiny change)
+
+ * vc/vc-svn.el (vc-svn-after-dir-status): Some MS Windows svn client
+ programs output backslashes. (Bug#7663)
+
+2011-03-03 Glenn Morris <rgm@gnu.org>
+
+ * mail/sendmail.el (mail-mode-map): Remove mail-sent-via.
+ (mail-mode): Remove mail-sent-via from the doc.
+ (mail-sent-via): Make it obsolete. (Bug#1776)
+
+ * progmodes/grep.el (grep-highlight-matches): Doc fix.
+ (grep-process-setup): No highlighting without font-lock. (Bug#8084)
+
+ * vc/vc-bzr.el (vc-bzr-state-heuristic): Handle dirstate entries
+ with no parents. (Bug#8025)
+
+2011-03-02 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * password-cache.el (password-in-cache-p): Add autoload.
+
+2011-03-02 Glenn Morris <rgm@gnu.org>
+
+ * man.el (Man-support-local-filenames): Also handle Red Hat's man.
+ * dired-x.el (Man-support-local-filenames): Autoload it.
+ (dired-guess-shell-alist-default): Also handle Red Hat's man.
+
+ * dired-x.el (dired-default-directory-alist, dired-default-directory):
+ Mark as obsolete.
+ (dired-smart-shell-command): Just call dired-current-directory.
+
+ * dired-x.el (dired-jump-other-window): Add autoload.
+ (dired-default-directory-alist, dired-default-directory): Doc fixes.
+ (dired-default-directory-alist): Mark as risky.
+
+ * dired-x.el (dired-omit-here-always): Make it obsolete.
+
+2011-03-02 Chong Yidong <cyd@stupidchicken.com>
+
+ * textmodes/artist.el (artist-curr-go): Default to pen-line.
+ (artist-select-op-pen-line): New function.
+ (artist-menu-map): New variable.
+ (artist-mode-map): Add a menu to the menu-bar.
+
+2011-03-02 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc-math.el (calcFunc-log10): Check for symbolic mode
+ when evaluating.
+
+ * calc/calc-units.el (math-conditional-apply, math-conditional-pow):
+ New function.
+ (math-logunits-add, math-logunits-mul, math-logunits-divide):
+ (math-logunits-quant, math-logunits-level):
+ Use `math-conditional-apply' and `math-conditional-pow' to evaluate
+ functions.
+ (math-logunits-level): Extract units from ratio.
+
+2011-03-01 Juanma Barranquero <lekktu@gmail.com>
+
+ * emacs-lisp/cl-macs.el (lexical-let*): Fix argument name in docstring.
+
+2011-03-01 Glenn Morris <rgm@gnu.org>
+
+ * calendar/cal-hebrew.el (calendar-hebrew-birthday)
+ (diary-hebrew-birthday): Rename and rework functions added
+ in previous change.
+
+2011-03-01 Ed Reingold <reingold@emr.cs.iit.edu>
+
+ * calendar/cal-hebrew.el (hebrew-calendar-birthday)
+ (diary-hebrew-birthday): New functions.
+
+2011-03-01 Glenn Morris <rgm@gnu.org>
+
+ * dired.el (dired-safe-switches-p): Beef it up.
+ (dired-actual-switches): Use it for the safe-local prop. (Bug#3230)
+
+2011-03-01 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * dired.el (dired-safe-switches-p): New function.
+
+2011-03-01 Glenn Morris <rgm@gnu.org>
+
+ * files.el (dir-locals-collect-variables):
+ Add the ability to exclude subdirectories. (Bug#8100)
+
+ * dired-x.el (dired-omit-here-always): Add `(subdirs . nil)' to locals.
+
+2011-02-28 Christoph Scholtes <cschol2112@googlemail.com>
+
+ * ido.el (ido-everywhere): Doc fix.
+ (ido-mode): Doc fix.
+
+2011-02-28 Glenn Morris <rgm@gnu.org>
+
+ * dired-x.el (dired-guess-shell-alist-default): Use \\', not $.
+
+2011-02-28 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-cmds.el (tramp-append-tramp-buffers): Dump load-path
+ shadows.
+
+2011-02-28 Antoine Levitt <antoine.levitt@gmail.com>
+
+ * dired-x.el (dired-guess-shell-alist-default): Add rar and 7z.
+
+2011-02-28 Juanma Barranquero <lekktu@gmail.com>
+
+ * emacs-lisp/pcase.el (pcase, pcase--u1, pcase--q1):
+ Fix typos in docstrings.
+
+2011-02-28 Stephen Berman <stephen.berman@gmx.net>
+
+ * dired-aux.el (dired-update-file-line):
+ Fix 2010-11-09 change. (Bug#8131)
+
+2011-02-28 Eli Zaretskii <eliz@gnu.org>
+
+ * international/mule-cmds.el (set-default-coding-systems): Use the
+ -unix variant of encoding in default-keyboard-coding-system.
+ (Bug#8122)
+
+2011-02-27 Chong Yidong <cyd@stupidchicken.com>
+
+ * facemenu.el (list-colors-display): Use with-help-window (Bug#8048).
+
+2011-02-27 Prestoo Ten <prestooten@gmail.com> (tiny change)
+
+ * term/screen.el: New file (Bug#2650).
+
+2011-02-27 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/pcase.el (pcase--if): Try to invert test to reduce depth.
+ (pcase-mutually-exclusive-predicates): New var.
+ (pcase--split-consp, pcase--split-pred): Use it.
+ (pcase--split-equal, pcase--split-member): When splitting against
+ a pure predicate, run it to know the outcome.
+ (pcase--u1): Mark vars that are actually used.
+ (pcase--q1): Avoid introducing unused vars.
+
+2011-02-27 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc-ext.el (calc-init-extensions):
+ Autoload `calc-l-prefix-help' instead of `calc-ul-prefix-help'.
+
+ * calc/calc-math.el (calcFunc-log10): Don't signal an error in
+ symbolic mode.
+
+ * calc/calc-vec.el (calcFunc-subscr): Return nil if the first
+ argument is a variable.
+
+2011-02-26 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/assoc.el: Remove misleading `sort' (bug#8126).
+ (aput, adelete, amake): Replace `eval' -> `symbol-value'.
+ Suggested by Michael Heerdegen <michael_heerdegen@web.de>.
+
+2011-02-25 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * password-cache.el (password-in-cache-p): Convenience function to
+ check if a key is in the cache, even if the value is nil.
+
+2011-02-25 Jambunathan K <kjambunathan@gmail.com>
+
+ * emacs-lisp/package-x.el (package--archive-contents-from-url)
+ (package--archive-contents-from-file): New functions.
+ (package-update-news-on-upload): New var.
+ (package-upload-buffer-internal): Extract archive-contents from
+ package-archive-upload-base if it is not found at archive-url.
+ Obey package-update-news-on-upload.
+ (package-upload-buffer, package-upload-file): Doc fix.
+
+2011-02-24 Glenn Morris <rgm@gnu.org>
+
+ * files-x.el (modify-dir-local-variable): Handle dir-locals from
+ the cache, and from non-file sources.
+
+ * help-fns.el (describe-variable): Return consistent results when a
+ dir-local from a file came from the cache or did not. (Bug#8095)
+ If a dir-local has no associated file, say it came from a "directory".
+
+ * files.el (hack-dir-local-variables): Fix setting of `dir-name'.
+ (hack-local-variables-confirm, hack-local-variables-filter): Doc fix.
+
+ * files.el (dir-locals-find-file): Doc fix.
+ Fix the check for cache elements that have no associated file,
+ and the mtime check for those that do. (Bug#8095)
+
+ * dired-x.el (dired-hack-local-variables):
+ Handle interrupts during hacking local variables. (Bug#5216)
+
+ * emacs-lisp/autoload.el (autoload-save-buffers)
+ (autoload-find-destination, update-directory-autoloads):
+ Avoid prompts when updating autoloads.
+
+2011-02-23 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/bytecomp.el (byte-compile-disable-print-circle): Obsolete.
+
+2011-02-23 Kenichi Handa <handa@m17n.org>
+
+ * mail/rmailmm.el (rmail-mime-process-multipart): Do not signal an
+ error when a multipart boundary in the nested multipart is found.
+
+ * mail/rmail.el (rmail-start-mail): Decode "encoded-words" of
+ header components.
+
+2011-02-23 Glenn Morris <rgm@gnu.org>
+
+ * dired.el (dired-mode): Call hack-dir-local-variables-non-file-buffer.
+ * dired-x.el (dired-omit-mode): Safe if boolean.
+ (dired-enable-local-variables): Fix doc and custom type.
+ (dired-enable-local-variables, dired-local-variables-file)
+ (dired-hack-local-variables): Make obsolete.
+ (dired-omit-here-always): Use dir-locals.el instead.
+
+ * files.el (safe-local-eval-forms): Add the write-file-hooks version.
+
+2011-02-22 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * help-fns.el (describe-function-1): Don't signal an error just because
+ the DOC file disappeared.
+
+2011-02-22 Seppo Sade <sepposade1@gmail.com> (tiny change)
+
+ * eshell/esh-ext.el (eshell-external-command): Do not restrict
+ remote check to "ftp". (Bug#8089)
+
+2011-02-21 Alan Mackenzie <acm@muc.de>
+
+ Fix bug #7930.
+ * progmodes/cc-engine.el (c-state-literal-at): Prevent positions
+ in macros finding their way into c-state-nonlit-pos-cache.
+ Strengthen the comments.
+ (c-state-dump): New commented out diagnostic routine.
+
+2011-02-21 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-rfn-eshadow-setup-minibuffer): Do not use
+ `field' property of `rfn-eshadow-overlay'.
+
+2011-02-21 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * net/netrc.el (netrc-parse): Comment fix.
+
+2011-02-21 Chong Yidong <cyd@stupidchicken.com>
+
+ * color.el (color-name-to-rgb): Rename from color-rgb->normalize.
+ Autoload. Add optional arg FRAME, and pass it to color-values.
+ (color-complement): Caller changed. Doc fix.
+ (color-gradient): Rewrite for better clarity and efficiency.
+
+ * faces.el (color-values): Use cond for clarity. Doc fix.
+
+ * facemenu.el (color-rgb-to-hsv): Delete; use the version in
+ color.el instead.
+ (list-colors-sort-key, list-colors-print):
+ Use color-normalized-values.
+
+2011-02-20 Drew Adams <drew.adams@oracle.com>
+
+ * color.el: First part of merge from hexrgb.el.
+ (color-rgb-to-hex): Rename from color-rgb->hex.
+ (color-rgb-to-hsv): Rename from color-rgb->hsv. Force hue and
+ saturation to zero if the value is too small.
+ (color-rgb-to-hsl): Rename from color-rgb->hsl.
+ (color-srgb-to-xyz): Rename from color-srgb->xyz. Doc fix.
+ (color-xyz-to-srgb): Rename from color-xyz->srgb. Doc fix.
+ (color-xyz-to-lab): Rename from color-xyz->lab. Doc fix.
+ (color-lab-to-xyz): Rename from color-lab->xyz. Doc fix.
+ (color-lab-to-srgb): Rename from color-lab->srgb. Doc fix.
+ (color-cie-de2000): Doc fix.
+
+2011-02-20 Alan Mackenzie <acm@muc.de>
+
+ * progmodes/cc-cmds.el (c-beginning-of-statement): Avoid loop in
+ locating the beginning of a macro. (Bug#7595)
+
+2011-02-20 Glenn Morris <rgm@gnu.org>
+
+ * edmacro.el (edmacro-eight-bits): Make it a defcustom.
+ Don't autoload it.
+
+ * autorevert.el (auto-revert-mode, auto-revert-tail-mode)
+ (global-auto-revert-ignore-buffer): Remove leading "*" from docs.
+
+2011-02-19 Dmitry Bolshakov <dmitry.bolshakov@bridge-quest.com>
+ Dima Kogan <dkogan@cds.caltech.edu> (tiny change)
+
+ * progmodes/hideshow.el (hs-find-block-beginning)
+ (hs-hide-level-recursive): Ignore comments when parsing braces
+ (Bug#8036).
+
+2011-02-19 Chong Yidong <cyd@stupidchicken.com>
+
+ * vc/vc-bzr.el (vc-bzr-bound-branch-p): New function.
+ (vc-bzr-pull): Use it.
+
+2011-02-19 Chong Yidong <cyd@stupidchicken.com>
+
+ * vc/vc-bzr.el (vc-bzr--branch-conf): Function deleted.
+ (vc-bzr-branch-conf): New function, similar to vc-bzr--branch-conf
+ but returning an alist. Ignore comments in bzr conffile.
+ (vc-bzr-pull, vc-bzr-merge-branch): Use vc-bzr-branch-conf.
+ (vc-bzr-error-regex-alist): New var.
+ (vc-bzr-merge-branch): Use it to highlight the pull/merge buffer.
+
+ * vc/vc-dispatcher.el (vc-do-async-command):
+ Bind inhibit-read-only to t.
+
+ * progmodes/compile.el (compilation--flush-directory-cache):
+ Handle the case where cdr of compilation--flush-directory-cache
+ points to no buffer, which can occur if we previously switched to
+ compilation-mode in a pregenerated buffer.
+
+2011-02-19 Kenichi Handa <handa@m17n.org>
+
+ * mail/rmailmm.el (rmail-mime-find-header-encoding): Be sure to
+ get the header copy into the temporary buffer.
+ (rmail-mime-insert-decoded-text): Ignore us-ascii.
+ (rmail-show-mime): When rmail-mime-coding-system is nil, set
+ buffer-file-coding-system to undecided.
+
+2011-02-19 Eli Zaretskii <eliz@gnu.org>
+
+ * international/mule-cmds.el (read-char-by-name, ucs-insert):
+ Document completion with asterisk and a substring.
+
+2011-02-19 Glenn Morris <rgm@gnu.org>
+
+ * files.el (find-file-literally): Doc fix.
+
+ * simple.el (rfc822-goto-eoh): Give it a doc-string.
+
+ * log-edit.el (log-edit-insert-changelog):
+ Fix `log-edit-strip-single-file-name' functionality. (Bug#8057)
+
+2011-02-19 Glenn Morris <rgm@gnu.org>
+
+ * dired-x.el: Don't require dired-aux.
+ (dired-do-create-files, dired-mark-read-regexp)
+ (dired-do-create-files-regexp): Autoload from dired-aux.
+
+ * dired-x.el (dired-find-buffer-nocreate): Merge into dired.el.
+ * dired.el (dired-find-buffer-nocreate): Merge dired-x version.
+
+ * dired-x.el (dired-read-shell-command): Merge into dired-aux's version.
+ * dired-aux.el (dired-read-shell-command): Merge dired-x's version.
+
+ * dired-x.el (dired-clean-up-after-deletion): Merge into dired.el.
+ * dired.el (dired-clean-up-after-deletion): Merge dired-x's version.
+ (dired-clean-up-buffers-too): Declare.
+
+ * dired-x.el (dired-initial-position): Merge into dired.el's version.
+ * dired.el (dired-initial-position): Merge dired-x's version here.
+ (dired-find-subdir): Declare.
+
+ * dired-x.el (dired-omit-new-add-entry): Merge into dired-add-entry.
+ * dired-aux.el (dired-add-entry): Give it a doc-string.
+ Merge dired-x's dired-omit handling here.
+ (dired-omit-mode, dired-omit-regexp, dired-omit-localp): Declare.
+
+ * international/mule-diag.el (list-input-methods-1):
+ Indent all lines of multi-line doc-strings. (Bug#8066)
+
+2011-02-18 Chong Yidong <cyd@stupidchicken.com>
+
+ Fix 2011-02-02 changes.
+
+ * apropos.el (apropos-print): Call apropos-mode before setting up
+ buffer variables. Use inhibit-read-only.
+
+ * emacs-lisp/package.el (package--list-packages):
+ Call package-menu-mode before setting up buffer variables.
+
+ * play/solitaire.el (solitaire): Call solitaire-mode before
+ setting up buffer variables. Use inhibit-read-only.
+
+2011-02-18 Lawrence Mitchell <wence@gmx.li>
+
+ * progmodes/sh-script.el (sh-syntax-propertize-here-doc): (bug#8053)
+ Bind case-fold-search to nil when looking for end of here-doc.
+
+2011-02-18 Eli Zaretskii <eliz@gnu.org>
+
+ * image-mode.el (image-toggle-display-image):
+ Set find-file-literally non-nil in buffers visiting binary image
+ files. (Bug#8047)
+
+2011-02-18 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * files.el (cd): Make completion obey cd-path (bug#7924).
+
+2011-02-18 Glenn Morris <rgm@gnu.org>
+
+ * progmodes/prolog.el: Don't require compile when compiling.
+ (compilation-shell-minor-mode, compilation-error-regexp-alist)
+ (compilation-forget-errors, compilation-fake-loc)
+ (compilation-parse-errors-function, compilation-error-list): Declare.
+ (prolog-inferior-mode): Require 'compile.
+
+ * emulation/cua-base.el (pc-selection-mode): Declare.
+
+ * emacs-lisp/eieio-custom.el: Set generated-autoload-file.
+ (customize-object): Add autoload cookie.
+ * emacs-lisp/eieio-opt.el: Set generated-autoload-file.
+ (eieio-browse, describe-class, eieio-describe-class)
+ (eieio-describe-constructor, describe-generic, eieio-describe-generic)
+ (eieio-help-mode-augmentation-maybee): Add autoload cookies.
+ * emacs-lisp/eieio.el: Regenerate with automatic autoloads.
+ * Makefile.in (autoloads): Make eieio.el writable.
+
+ * dired-x.el (dired-clean-up-after-deletion, dired-do-relsymlink)
+ (dired-do-relsymlink-regexp, dired-find-buffer-nocreate): Use #'.
+ (dired-hack-local-variables): Use inhibit-read-only.
+ (dired-guess-default): Simplify.
+ (dired-make-relative-symlink): Use dotimes.
+ (dired-simultaneous-find-file): Use dolist.
+ (dired-mark-sexp): Remove unneeded `if'. Use line-end-position.
+ (dired-x-hands-off-my-keys): Doc fix.
+ (dired-x-bind-find-file): Doc fix. Use remapping.
+ (after-init-hook): No need to add dired-x-bind-find-file.
+ (dired-x-find-file, dired-x-find-file-other-window): Doc fixes.
+ No need to call expand-file-name.
+ (dired-filename-at-point): Remove unused locals `end', `filename'.
+
+2011-02-18 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/pcase.el (pcase--u1): Understand non-linear patterns.
+
+2011-02-18 Christian Ohler <ohler@gnu.org>
+
+ * emacs-lisp/ert.el (ert--setup-results-buffer)
+ (ert-results-pop-to-backtrace-for-test-at-point)
+ (ert-results-pop-to-messages-for-test-at-point)
+ (ert-results-pop-to-should-forms-for-test-at-point)
+ (ert-results-pop-to-timings): Revert parts of change 2011-02-02T17:59:44Z!sds@gnu.org that
+ were incorrect and unnecessary. This should make `make check'
+ pass again.
+
+2011-02-17 Ken Manheimer <ken.manheimer@gmail.com>
+
+ * lisp/allout-widgets.el (allout-widgets-icons-light-subdir)
+ (allout-widgets-icons-dark-subdir): Track relocations of icons.
+ * lisp/allout.el: Remove commentary about remove encryption
+ passphrase mnemonic support and verification.
+ (allout-encrypt-string): Recognize epg failure to decrypt gpg2
+ armored text using gpg1, and indicate that the gpg version *might*
+ be the problem in the error message.
+
+2011-02-17 Deniz Dogan <deniz.a.m.dogan@gmail.com>
+
+ * net/rcirc.el (rcirc-float-time): New function.
+ (rcirc-keepalive, rcirc-handler-ctcp-KEEPALIVE)
+ (rcirc-ctcp-sender-PING): Use it.
+
+2011-02-17 Glenn Morris <rgm@gnu.org>
+
+ * speedbar.el (speedbar-ignored-modes, speedbar-file-unshown-regexp)
+ (speedbar-update-flag, speedbar-fetch-etags-command)
+ (speedbar-fetch-etags-arguments):
+ * term.el (term-buffer-maximum-size, term-input-chunk-size)
+ (term-completion-autolist, term-completion-addsuffix)
+ (term-completion-recexact, term-completion-fignore):
+ * term/sup-mouse.el (sup-mouse-fast-select-window):
+ * term/x-win.el (x-select-request-type):
+ Convert some defvars with "*" to defcustoms.
+
+ * shell.el (shell-delimiter-argument-list): Set it to nil. (Bug#8027)
+
+ * vc/vc.el (vc-default-previous-version):
+ Remove alias that points nowhere. (Bug#4496)
+
+ * dired-x.el (dired-clean-up-after-deletion):
+ kill-buffer does not need save-excursion.
+ (dired-do-run-mail): Doc fix.
+ (dired-filename-at-point): Doc fix.
+ Use looking-at, and skip-chars rather than re search.
+
+ * dired-x.el (dired-filename-at-point): Fix 8-year old typo.
+
+2011-02-16 Ken Manheimer <ken.manheimer@gmail.com>
+
+ * allout-widgets.el: New allout extension that shows allout
+ outline structure with graphical widgets. 'allout-widgets'
+ customize group is an 'allout' subgroup, for easy discovery.
+
+ * allout.el: Include PGP and GnuPG in Keywords, and other
+ commentary refinements.
+ (allout-abbreviate-flattened-numbering): Rename to
+ allout-flattened-numbering-abbreviation, and
+ define-obsolete-variable-alias the old name.
+ (allout-flattened-numbering-abbreviation): Rename from
+ allout-abbreviate-flattened-numbering.
+ (allout-mode-p): Include among autoloads, for use by other modes
+ with impunity.
+ (allout-listify-exposed):
+ Use allout-flattened-numbering-abbreviation.
+ (allout-encrypt-string): Use set-buffer-multibyte directly.
+ (allout-set-buffer-multibyte): Remove.
+
+2011-02-16 Deniz Dogan <deniz.a.m.dogan@gmail.com>
+
+ * simple.el (just-one-space): Remove useless `or' call.
+
+2011-02-16 Alex Harsanyi <AlexHarsanyi@gmail.com>
+
+ * net/soap-client.el (soap-well-known-xmlns, soap-local-xmlns)
+ (soap-default-xmlns, soap-target-xmlns, soap-multi-refs)
+ (soap-decoded-multi-refs, soap-current-wsdl)
+ (soap-encoded-namespaces): Rename CL-style *...* variables.
+
+2011-02-16 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/soap-client.el: Add "comm" and "hypermedia" to the
+ keywords. Reflow too long lines.
+
+ * net/soap-inspect.el: Ditto. Require 'cl.
+
+2011-02-16 Bastien Guerry <bzg@altern.org>
+
+ * play/doctor.el (doctor-mode): Bugfix: escape the "," character
+ in a `doctor-type' argument.
+
+2011-02-16 Alex Harsanyi <AlexHarsanyi@gmail.com>
+
+ * net/soap-client.el:
+ * net/soap-inspect.el: New files.
+
+2011-02-16 Leo <sdl.web@gmail.com>
+
+ * dired-x.el (dired-mode-map, dired-extra-startup):
+ Remove dired-copy-filename-as-kill since it's already in dired.el.
+
+2011-02-16 Glenn Morris <rgm@gnu.org>
+
+ * dired-x.el (dired-bind-jump, dired-bind-man, dired-bind-info):
+ Doc fixes. Add :set property, replacing top-level calls.
+ (dired-vm-read-only-folders, dired-vm): Doc fix (drop v. old VM 4).
+ (dired-guess-shell-gnutar): Test tar version rather than system-type.
+ (dired-extra-startup, dired-man, dired-info): Doc fixes.
+ (dired-clean-up-after-deletion): Use when and dolist.
+ (dired-jump): Use unless and when.
+ (dired-virtual): Use line-end-position.
+ (dired-default-directory-alist): Rename from default-directory-alist.
+ (dired-default-directory): Update for above name change.
+ (dired-vm): Drop VM < 5 and simplify.
+ (dired-buffer-more-recently-used-p): Rewrite.
+ (dired-filename-at-point): Use when and or.
+ (dired-x-read-filename-at-point): Rename from read-filename-at-point.
+ Update callers.
+
+2011-02-15 Glenn Morris <rgm@gnu.org>
+
+ * dired-x.el: Use easymenu for menu items. Fix item capitalization.
+
+2011-02-14 Chong Yidong <cyd@stupidchicken.com>
+
+ * vc/vc-git.el (vc-git-root-log-format): New option for
+ customizing log format.
+ (vc-git-print-log, vc-git-log-outgoing, vc-git-log-incoming)
+ (vc-git-log-view-mode): Use it.
+ (vc-git-expanded-log-entry): New function.
+ (vc-git-log-view-mode): Use it. Truncate lines in root log.
+
+ * vc/vc-hg.el (vc-hg-root-log-template): New option for
+ customizing log format.
+ (vc-hg-print-log): Use it.
+ (vc-hg-expanded-log-entry): New function.
+ (vc-hg-log-view-mode): Use vc-hg-root-log-template and
+ vc-hg-expanded-log-entry. Truncate lines in root log.
+
+ * vc/vc-bzr.el (vc-bzr-log-view-mode): Truncate lines in root log.
+
+ * vc/log-view.el (log-view-mode-menu):
+ Add log-view-toggle-entry-display.
+
+2011-02-14 Glenn Morris <rgm@gnu.org>
+
+ * dired-x.el: Don't require man when compiling.
+ (dired-omit-extensions, dired-local-variables-file)
+ (dired-x-hands-off-my-keys): Make them defcustoms.
+ (Man-support-local-filenames, Man-getpage-in-background): Declare.
+ (vm-visit-folder): Declare rather than defining.
+ (dired-x-help-address, dired-x-variable-list): Remove.
+ (dired-x-submit-report): Make it an obsolete alias.
+
+2011-02-14 Juanma Barranquero <lekktu@gmail.com>
+
+ * makefile.w32-in (TRAMP_SRC): Remove tramp-imap.el.
+
+2011-02-13 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * net/imap.el: Bring it back.
+
+2011-02-13 Alan Mackenzie <acm@muc.de>
+
+ * progmodes/cc-fonts.el (c-font-lock-declarations): Remove a
+ narrow-to-region call that cuts context off the end (Bug#7722).
+
+ * progmodes/cc-engine.el (c-forward-<>-arglist-recur):
+ Refactor nested if-forms with a simple cond.
+ (c-forward-<>-arglist): Revert 2011-01-31 change.
+
+2011-02-13 Chong Yidong <cyd@stupidchicken.com>
+
+ * vc/log-view.el: New command log-view-toggle-entry-display for
+ toggling log entries between concise and detailed forms.
+ (log-view-toggle-entry-display): New command.
+ (log-view-mode-map): Bind RET to it.
+ (log-view-expanded-log-entry-function): New variable.
+ (log-view-current-entry, log-view-inside-comment-p)
+ (log-view-current-tag): New functions.
+ (log-view-toggle-mark-entry): Use log-view-current-entry and
+ log-view-end-of-defun instead of searching directly with
+ log-view-message-re.
+ (log-view-end-of-defun): Likewise. Add optional ARG for
+ compatibility with end-of-defun.
+ (log-view-end-of-defun): Ignore comments and VC buttons.
+
+ * vc/vc-bzr.el (vc-bzr-expanded-log-entry): New function.
+ (vc-bzr-log-view-mode): Use log-view-expanded-log-entry-function.
+
+2011-02-13 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * net/imap.el: Remove file. All the functionality is in nnimap.el.
+
+ * net/imap-hash.el: Remove file.
+
+2011-02-13 Michael Albinus <michael.albinus@gmx.de>
+
+ * Makefile.in (TRAMP_SRC): Remove tramp-imap.el.
+
+ * net/tramp.el (tramp-read-passwd): Simplify `auth-source-search'
+ call.
+
+ * net/tramp-imap.el: Remove file.
+
+2011-02-13 Chong Yidong <cyd@stupidchicken.com>
+
+ * vc/vc.el (vc-print-log-setup-buttons): Instead of using the
+ widget library for buttons, just use button.el.
+
+ * vc/log-view.el (log-view-mode-map): Don't inherit from
+ widget-keymap.
+
+2011-02-12 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/cl-seq.el (union, nunion, intersection)
+ (nintersection, set-difference, nset-difference)
+ (set-exclusive-or, nset-exclusive-or): Doc fix.
+
+ * ediff-ptch.el (ediff-fixup-patch-map): Doc fix.
+
+ * faces.el (face-attr-match-p): Handle the obsolete :bold and
+ :italic props, so that frame-set-background-mode works. (Bug#7966)
+
+ * simple.el (next-error): Doc fix.
+
+2011-02-12 Thierry Volpiatto <thierry.volpiatto@gmail.com>
+
+ * dired-aux.el (dired-create-files): Adapt destination name to
+ match the new behavior of copy-directory.
+
+2011-02-12 Chong Yidong <cyd@stupidchicken.com>
+
+ * mail/mail-utils.el (mail-dont-reply-to-names): New variable,
+ from rmail-dont-reply-to-names. Callers changed.
+ (mail-dont-reply-to): Rename from mail-dont-reply-to.
+ (rmail-dont-reply-to): Make it an obsolete alias.
+
+ * mail/rmail.el (rmail-default-dont-reply-to-names): Default to
+ nil, and make obsolete (Bug#7888).
+ (rmail-dont-reply-to-names): Alias to mail-dont-reply-to-names.
+
+ * mail/rmailsum.el (rmail-summary-sort-by-correspondent): Doc fix.
+
+ * mail/rmailsort.el (rmail-sort-by-correspondent)
+ (rmail-select-correspondent): Doc fix. Use mail-dont-reply-to.
+
+ * mail/rmail.el (rmail-reply): Use mail-dont-reply-to.
+
+2011-02-12 Thierry Volpiatto <thierry.volpiatto@gmail.com>
+
+ * files.el (copy-directory): New argument COPY-CONTENTS for
+ copying directory contents into another existing directory.
+
+2011-02-12 Tassilo Horn <tassilo@member.fsf.org>
+
+ * minibuffer.el (completion-table-case-fold): New function for
+ creating a case-insensitive completion table.
+
+2011-02-12 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * net/tramp.el (tramp-default-method): Also check if
+ `auth-source-search' is bound.
+ (tramp-read-passwd): Use `auth-source-search' instead of
+ `auto-source-user-or-password'.
+
+ * net/tramp-imap.el: Autoload `auto-source-search' instead of
+ `auto-source-user-or-password.
+ (tramp-imap-passphrase-callback-function): Use it.
+
+ * net/imap-hash.el: Autoload `auto-source-search' instead of
+ `auto-source-user-or-password.
+ (imap-hash-open-connection): Use it.
+
+ * mail/smtpmail.el: Autoload `auto-source-search' instead of
+ `auto-source-user-or-password.
+ (smtpmail-try-auth-methods): Use it.
+
+2011-02-12 Phil Hagelberg <phil@hagelb.org>
+
+ * emacs-lisp/package.el: Allow packages to be reinstalled.
+ (package--write-file-no-coding): Remove EXCL arg.
+ (package-unpack-single): Don't use it.
+
+2011-02-12 Karl Pflästerer <k@rl.pflaesterer.de> (tiny change)
+
+ * vc/vc-svn.el: Adapt to Subversion change, with no .svn directory
+ in each sub directory.
+ (vc-svn-registered): Use vc-svn-root.
+ (vc-svn-root): New function. Make vc-svn-responsible-p an alias.
+ (vc-svn-repository-hostname): Use "svn info".
+
+2011-02-11 Deniz Dogan <deniz.a.m.dogan@gmail.com>
+
+ * simple.el (delete-trailing-whitespace): New optional buffer
+ bound parameters.
+
+2011-02-11 Bastien Guerry <bzg@altern.org>
+
+ * files.el (basic-save-buffer): save unmodified buffers when
+ the file pointed by buffer-file-name doesn't exist.
+
+2011-02-11 Deniz Dogan <deniz.a.m.dogan@gmail.com>
+
+ * net/rcirc.el (rcirc-cmd-join): Accept multiple channels.
+
+2011-02-11 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/cl-specs.el (multiple-value-bind): Fix debug spec.
+
+2011-02-11 Juanma Barranquero <lekktu@gmail.com>
+
+ * net/rcirc.el (rcirc-send-ctcp): Remove spurious arg to `format'.
+
+2011-02-10 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * server.el (server-process-filter): Use pcase.
+
+ * emacs-lisp/smie.el (smie-blink-matching-open): Don't use `pos' in two
+ conflicting ways.
+ (smie-indent--parent): Extend to "parent of arg".
+ (smie-indent-inside-string): New function.
+ (smie-indent-functions): Use it.
+
+ * vc/vc-dir.el (vc-dir-refresh): Reorder operations to try and avoid
+ bzr locking race condition.
+
+ * emacs-lisp/edebug.el (edebug-instrument-function): Check a marker is
+ still valid before using it.
+
+ * progmodes/grep.el (grep-mode-font-lock-keywords): Adjust to
+ `message' -> `compilation-message' rename (bug#8004).
+
+ Move keymap initialization into declaration.
+ * textmodes/enriched.el (enriched-mode-map):
+ * textmodes/bib-mode.el (bib-mode-map):
+ * term/lk201.el (lk201-function-map):
+ * tar-mode.el (tar-mode-map):
+ * replace.el (occur-mode-map):
+ * progmodes/idlwave.el (idlwave-rinfo-mouse-map, idlwave-rinfo-map):
+ * progmodes/idlw-help.el (idlwave-help-mode-map):
+ * progmodes/gdb-mi.el (gdb-memory-format-menu, gdb-memory-unit-menu):
+ * play/solitaire.el (solitaire-mode-map):
+ * play/snake.el (snake-mode-map, snake-null-map):
+ * play/pong.el (pong-mode-map):
+ * play/handwrite.el (menu-bar-handwrite-map):
+ * play/gametree.el (gametree-mode-map):
+ * net/rcirc.el (rcirc-mode-map, rcirc-browse-url-map)
+ (rcirc-multiline-minor-mode-map, rcirc-track-minor-mode-map):
+ * net/newst-plainview.el (newsticker-menu, newsticker-mode-map)
+ (newsticker--url-keymap):
+ * net/net-utils.el (nslookup-mode-map, ftp-mode-map):
+ * menu-bar.el (menu-bar-file-menu, menu-bar-i-search-menu)
+ (menu-bar-search-menu, menu-bar-replace-menu, menu-bar-goto-menu)
+ (menu-bar-edit-menu, menu-bar-custom-menu)
+ (menu-bar-showhide-fringe-ind-menu, menu-bar-showhide-fringe-menu)
+ (menu-bar-showhide-scroll-bar-menu, menu-bar-showhide-menu)
+ (menu-bar-line-wrapping-menu, menu-bar-options-menu)
+ (menu-bar-games-menu, menu-bar-encryption-decryption-menu)
+ (menu-bar-tools-menu, menu-bar-describe-menu)
+ (menu-bar-search-documentation-menu, menu-bar-manuals-menu)
+ (menu-bar-help-menu):
+ * mail/rmailsum.el (rmail-summary-mode-map):
+ * kmacro.el (kmacro-step-edit-map):
+ * ibuffer.el (ibuffer-mode-groups-popup, ibuffer-mode-map)
+ (ibuffer-mode-operate-map):
+ * hi-lock.el (hi-lock-menu, hi-lock-map):
+ * emulation/vip.el (vip-mode-map):
+ * emacs-lisp/re-builder.el (reb-lisp-mode-map):
+ * bookmark.el (bookmark-bmenu-mode-map):
+ * help-mode.el (help-mode-map): Move initialization into declaration.
+
+2011-02-10 Deniz Dogan <deniz.a.m.dogan@gmail.com>
+
+ * net/rcirc.el: Add PRIVMSG and CTCP functions.
+ (rcirc-send-privmsg, rcirc-send-ctcp): New functions.
+ (rcirc-keepalive, rcirc-cmd-ctcp, rcirc-ctcp-sender-PING)
+ (rcirc-cmd-me, rcirc-authenticate): Use them.
+
+2011-02-10 Ken Manheimer <ken.manheimer@gmail.com>
+
+ * allout.el: Synopsis: Change allout user configuration so
+ auto-activation is controlled solely by customization
+ `allout-auto-activation'.
+
+ (allout-auto-activation-helper, allout-setup): New autoloads
+ implement new custom set procedure for allout-auto-activation.
+ Also, explicitly invoke (allout-setup) after allout-auto-activation
+ is custom-defined, to affect the settings in emacs sessions besides
+ the few where allout-auto-activation customization is done.
+ (allout-auto-activation): Use allout-auto-activation-helper to
+ :set. Revise the docstring.
+ (allout-init): Reduce functionality to just customizing
+ allout-auto-activation, and mark obsolete.
+ (allout-mode): Respect string values for allout-auto-activation.
+ Run allout-after-copy-or-kill-hook without any args.
+ (allout-mode, allout-layout, allout-default-layout)
+ (outlineify-sticky): Adjust docstring for new scheme.
+ (allout-after-copy-or-kill-hook): No arguments - hook implementers
+ should concentrate on the kill ring.
+
+2011-02-09 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * password-cache.el (password-cache-remove): Accept secrets that are
+ not strings.
+
+2011-02-09 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/sh-script.el (sh-font-lock-open-heredoc): Fix case
+ of here-doc that immediately follows a comment.
+
+2011-02-09 Deniz Dogan <deniz.a.m.dogan@gmail.com>
+
+ * net/rcirc.el (rcirc-ctcp-sender-PING): Simplifying.
+
+ * net/rcirc.el (rcirc-cmd-ctcp): Use dedicated function when
+ available.
+ (rcirc-ctcp-sender-PING): New function.
+
+2011-02-08 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * obsolete/pc-select.el: Rename from emulation/pc-select.el (bug#7940).
+ Remove the mark/nomark handling, and activate shift-select-mode instead.
+
+ * obsolete/pc-mode.el: Rename from emulation/pc-mode.el.
+
+2011-02-07 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc-units.el (math-logunits-quant): Add support for
+ non-logarithmic units.
+
+2011-02-07 Ken Manheimer <ken.manheimer@gmail.com>
+
+ * allout.el (allout-after-copy-or-kill-hook): New hook for
+ extension-specific processing of killed text.
+ (allout-mode): Include new allout-after-copy-or-kill-hook among
+ mentioned hooks.
+ (allout-kill-line, allout-kill-topic): Ensure that processing
+ after kill happens even if barf-if-buffer-read-only is raised.
+ Include new allout-after-copy-or-kill-hook among that subsequent
+ processing.
+ (allout-deannotate-hidden): Actually remove the annotation text
+ properties.
+
+ * allout.el (allout-listify-exposed): Copy text sans text properties.
+
+2011-02-07 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/dbus.el (dbus-list-activatable-names): Add optional argument BUS.
+
+2011-02-07 Deniz Dogan <deniz.a.m.dogan@gmail.com>
+
+ * net/rcirc.el (rcirc-handler-317): New function (Bug#6507).
+
+2011-02-06 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc.el (calc-logunits-field-reference): Rename from
+ `calc-default-field-reference-level'.
+ (calc-logunits-power-reference): Rename from
+ `calc-default-power-reference-level'.
+
+ * calc/calc-units.el (math-logunits-quant): Rename from
+ `math-logunits-level'
+ (math-logunits-plus): Rename from math-logcombine.
+ (calcFunc-luplus, calcFunc-luminus calc-luplus, calc-luminus): Remove.
+ (calcFunc-lufieldadd, calcFunc-lupoweradd, calcFunc-lufieldsub)
+ (calcFunc-lufieldsub, calc-logunits-add, calc-logunits-sub):
+ New functions.
+ (calcFunc-fieldquant): Rename from `calcFunc-fieldlevel'.
+ (calcFunc-powerquant): Rename from `calcFunc-powerlevel'.
+ (calc-logunits-quantity): Rename from `calc-level'.
+ (calcFunc-dbfieldlevel, calcFunc-dbpowerlevel, calcFunc-npfieldlevel)
+ (calcFunc-nppowerlevel, calc-logunits-dblevel, calc-logunits-nplevel)
+ (math-logunits-mul, calcFunc-lufieldmul, calcFunc-lupowermul)
+ (calc-logunits-mul, math-logunits-divide, calcFunc-lufielddiv)
+ (calcFunc-lupowerdiv, calc-logunits-divide, math-logunits-level):
+ New functions.
+
+ * calc/calc-help.el (calc-u-prefix-help): Remove "L" reference.
+ (calc-ul-prefix-help): Remove.
+ (calc-l-prefix-help): New function.
+ (calc-full-help): Add reference to `calc-l-prefix-help'.
+
+ * calc/calc-ext.el (calc-init-extensions): Update autoloads.
+
+ * calc/README: Mention logarithmic units.
+
+2011-02-06 Chong Yidong <cyd@stupidchicken.com>
+
+ * mail/emacsbug.el (report-emacs-bug-hook): Remove the check for
+ non-ASCII characters (Bug#7925).
+
+2011-02-05 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/cl-macs.el (return-from): Fix doc typo.
+
+ * calendar/diary-lib.el (diary-font-lock-keywords):
+ Tweak diary-time-regexp match. (Bug#7891)
+
+ * progmodes/f90.el (f90-find-tag-default): New function. (Bug#7919)
+ (f90-mode): Use it for mode's `find-tag-default-function' property.
+
+ * ibuf-ext.el (ibuffer-filter-disable): Make it work. (Bug#7969)
+
+ * faces.el (set-face-attribute): Doc fix. (Bug#2659)
+
+2011-02-05 Deniz Dogan <deniz.a.m.dogan@gmail.com>
+
+ * net/rcirc.el (rcirc-handler-JOIN): Reset mode-line-process
+ (Bug#6386).
+
+2011-02-05 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/sh-script.el (sh-here-doc-open-re): Don't rely on the
+ font-lock-syntax-table remappings.
+ (sh-here-doc-markers, sh-here-doc-re): Remove.
+ (sh-font-lock-close-heredoc): Remove.
+ (sh-syntax-propertize-here-doc): New function.
+ (sh-font-lock-open-heredoc): Set the sh-here-doc-marker property
+ instead of the sh-here-doc-re.
+ (sh-font-lock-paren): Don't do anything in comments or strings.
+ Handle line continuations. Accept a few more chars.
+ Don't rely on the font-lock-syntax-table remappings.
+ `esac' is not a valid pattern.
+ (sh-syntax-propertize-function): Handle here-docs differently, so we
+ don't bother syntax-propertizing the insides.
+
+ * progmodes/sh-script.el (sh-font-lock-paren, sh-kw, sh-prev-thing):
+ Handle new bashisms ";&" and ";;&" (bug#7947).
+
+2011-02-05 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-smb.el (tramp-smb-errors): Use `regexp-opt'.
+ Add "NT_STATUS_IO_TIMEOUT" and "NT_STATUS_NO_SUCH_USER".
+
+2011-02-05 Era Eriksson <era+tramp@iki.fi> (tiny change)
+
+ * net/tramp.el (tramp-postfix-method-format)
+ (tramp-postfix-method-regexp, tramp-prefix-domain-format)
+ (tramp-prefix-domain-regexp, tramp-postfix-user-format)
+ (tramp-postfix-user-regexp, tramp-prefix-port-format)
+ (tramp-prefix-port-regexp, tramp-postfix-host-format)
+ (tramp-postfix-host-regexp, tramp-handle-substitute-in-file-name):
+ Doc fix.
+
+2011-02-04 Sam Steingold <sds@gnu.org>
+
+ * mouse.el (mouse-buffer-menu-mode-groups): Add a "GDB" group.
+
+2011-02-04 Andreas Schwab <schwab@linux-m68k.org>
+
+ * international/mule-util.el (with-coding-priority): Doc fix.
+
+2011-02-04 Eli Zaretskii <eliz@gnu.org>
+
+ * arc-mode.el (archive-mode-map): Fix a typo in last change.
+
+2011-02-03 Sam Steingold <sds@gnu.org>
+
+ * progmodes/gdb-mi.el (gdb-breakpoints-list-handler-custom):
+ Do not error out when `func' is nil.
+
+2011-02-03 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-sh.el (tramp-remote-path): Add default settings for
+ `tramp-default-remote-path' to the docstring.
+ (tramp-get-remote-path): Suppress error message when `getconf
+ PATH' fails.
+
+ * net/tramp-smb.el (tramp-smb-errors): Add "NT_STATUS_UNSUCCESSFUL".
+
+2011-02-03 Glenn Morris <rgm@gnu.org>
+
+ * vc/vc-hg.el (vc-hg-command): Doc fix.
+
+ * term/w32-win.el (libpng-version): Declare for compiler.
+
+ * msb.el: No need to load dired while compiling.
+
+ * emacs-lisp/elint.el (elint-standard-variables):
+ Remove a couple of built-ins that now have doc-strings.
+
+ * hi-lock.el, ps-bdf.el, ps-mule.el, ps-print.el, ps-samp.el:
+ `require' is automatically `eval-and-compile'd.
+
+ * net/rcirc.el (rcirc-nick-completion-format): Add :version tag.
+ (rcirc-log-directory, rcirc-log-flag): Move definitions before use.
+
+ * strokes.el (strokes-fill-current-buffer-with-whitespace):
+ Move definition before use.
+ (strokes-report-bug): Make it obsolete.
+
+2011-02-02 Sam Steingold <sds@gnu.org>
+
+ * apropos.el (apropos-print): Now that `apropos-mode' inherits
+ from `special-mode', entering it makes the buffer read-only, so
+ call it only when everything has been already inserted.
+ * emacs-lisp/ert.el (ert--setup-results-buffer)
+ (ert-results-pop-to-backtrace-for-test-at-point)
+ (ert-results-pop-to-messages-for-test-at-point)
+ (ert-results-pop-to-timings): Ditto.
+ * emacs-lisp/package.el (package--list-packages): Ditto.
+ * play/solitaire.el (solitaire): Ditto.
+
+2011-02-02 Chong Yidong <cyd@stupidchicken.com>
+
+ * progmodes/compile.el: Make all faces inherit.
+ (compilation-warning): Inherit from font-lock-variable-name-face.
+ (compilation-info): Inherit from font-lock-type-face.
+ (compilation-line-number): Reassign to font-lock-keyword-face.
+ (compilation-column-number): Reassign to font-lock-doc-face.
+ (compilation-leave-directory-face): Reassign to
+ font-lock-builtin-face.
+
+2011-02-02 Eli Zaretskii <eliz@gnu.org>
+
+ * dired.el (dired-insert-directory): Don't invoke `ls' when
+ ls-lisp.el is used to emulate it.
+
+2011-02-01 Julien Danjou <julien@danjou.info>
+
+ * color.el (color-gradient): Add a color-gradient function.
+
+2011-02-01 Sam Steingold <sds@gnu.org>
+
+ * simple.el (special-mode-map): Bind "h" to `describe-mode';
+ bind "z" to `kill-this-buffer'.
+ (completion-list-mode-map): Bind "z" to `kill-this-buffer'.
+ * apropos.el (apropos-mode-map): Inherit from `special-mode-map'.
+ (apropos-mode): Inherit from `special-mode'.
+ * arc-mode.el (archive-mode-map): Inherit from `special-mode-map'.
+ * bookmark.el (bookmark-bmenu-mode): Define using
+ `define-derived-mode' inheriting from `special-mode'.
+ * dired.el (dired-mode-map): Inherit from `special-mode-map'.
+ * image-mode.el (image-mode-map): Ditto.
+ * replace.el (occur-mode): Define using
+ `define-derived-mode' inheriting from `special-mode'.
+ * tar-mode.el (tar-mode): Inherit from `special-mode'.
+ * calendar/diary-lib.el (diary-fancy-display-mode):
+ Inherit from `special-mode-map'.
+ * emacs-lisp/ert.el (ert-simple-view-mode, ert-results-mode):
+ Inherit from `special-mode'.
+ * emacs-lisp/package.el (package-menu-mode-map): Copy from
+ `special-mode-map'.
+ (package-menu-mode): Define using `define-derived-mode'
+ inheriting from `special-mode'.
+ * erc/erc-list.el (erc-list-menu-mode): Inherit from `special-mode'.
+ * net/xesam.el (xesam-mode): Inherit from `special-mode'.
+ (xesam-mode-map): Define separately.
+ * play/solitaire.el (solitaire-mode): Inherit from `special-mode'.
+ * progmodes/compile.el (compilation-minor-mode-map)
+ (compilation-mode-map): Inherit from `special-mode-map'.
+ * vc/diff-mode.el (diff-mode-shared-map):
+ Inherit from `special-mode-map'.
+ * vc/log-view.el (log-view-mode-map): Add a comment.
+
+2011-02-01 Chong Yidong <cyd@stupidchicken.com>
+
+ * custom.el (load-theme): Define return value. Drop use of
+ unsafep; call custom-theme-load-confirm for non-known-safe themes.
+ (custom-theme-load-confirm): Scroll in the correct window.
+ (custom-enabled-themes): Add custom-safe-themes to :set-after.
+
+ * cus-theme.el (custom-theme-checkbox-toggle): Don't activate the
+ checkbox if load-theme fails.
+
+2011-02-01 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/compile.el (compilation-next-error): Check there's
+ a message before using it (bug#7941).
+
+2011-02-01 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc-mtx.el (math-lud-pivot-check): New function.
+ (math-do-matrix-lud): Use `math-lud-pivot-check' to check the size
+ of potential pivots.
+
+2011-01-31 Alan Mackenzie <acm@muc.de>
+
+ * progmodes/cc-cmds.el (c-forward-over-illiterals):
+ Continue parsing if we encounter a naked # (Bug#7595).
+ (c-beginning-of-statement): Avoid loop in locating the beginning
+ of a macro. (Not actually committed until 2011-02-20, see above).
+
+2011-01-31 Chong Yidong <cyd@stupidchicken.com>
+
+ * files.el (copy-directory): Fix arguments to recursive call.
+
+2011-01-31 Chong Yidong <cyd@stupidchicken.com>
+
+ * files.el (copy-directory): If destination is an existing
+ directory, copy into a subdirectory there.
+
+2011-01-31 Andreas Schwab <schwab@linux-m68k.org>
+
+ * emacs-lisp/shadow.el (load-path-shadows-find): Ignore leim-list
+ files.
+
+2011-01-31 Chong Yidong <cyd@stupidchicken.com>
+
+ * image-dired.el (image-dired-mouse-display-image): No-op if no
+ file is found (Bug#7817).
+
+ * mouse.el (mouse-menu-non-singleton): Doc fix (Bug#7801).
+
+2011-01-31 Kenichi Handa <handa@m17n.org>
+
+ * international/quail.el (quail-keyboard-layout-alist):
+ Remove superfluous SPC for "pc105-uk" (bug#7927).
+
+2011-01-31 Glenn Morris <rgm@gnu.org>
+
+ * msb.el (msb-menu-bar-update-buffers): Update for changed
+ argument handling of menu-bar-select-frame. (Bug#7902)
+
+2011-01-31 Chong Yidong <cyd@stupidchicken.com>
+
+ * progmodes/cc-engine.el (c-forward-<>-arglist-recur): Set a limit
+ to the recursion depth (Bug#7722).
+
+2011-01-31 Roy Liu <carsomyr@gmail.com> (tiny change)
+
+ * term/ns-win.el (ns-find-file): Expand ns-input-file with
+ command-line-default-directory (Bug#7872).
+
+2011-01-31 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/compile.el (compilation--flush-directory-cache):
+ New function, extracted from compilation--remove-properties.
+ (compilation--remove-properties, compilation--parse-region): Use it.
+ (compilation--previous-directory): Handle one more case.
+ (compilation-enable-debug-messages): Remove.
+ (compilation-parse-errors, compilation--flush-parse): Just remove the
+ left over debug messages.
+
+2011-01-31 Sam Steingold <sds@gnu.org>
+
+ * progmodes/compile.el (compilation-enable-debug-messages):
+ Add a variable to make the parsing messages introduced in
+ 2011-01-28T22:12:05Z!monnier@iro.umontreal.ca optional.
+ (compilation-parse-errors, compilation--flush-parse): Use it.
+
+2011-01-31 Deniz Dogan <deniz.a.m.dogan@gmail.com>
+
+ * net/rcirc.el: New customizable nick completion format. (Bug#6314)
+ (rcirc-nick-completion-format): New defcustom.
+ (rcirc-complete): Use it.
+
+2011-01-31 Deniz Dogan <deniz.a.m.dogan@gmail.com>
+
+ * net/rcirc.el: Clean log filenames (Bug#7933).
+ (rcirc-log-write): Use convert-standard-filename.
+ (rcirc-log-filename-function): Documentation updates.
+
+2011-01-30 Jan Djärv <jan.h.d@swipnet.se>
+
+ * mail/emacsbug.el (report-emacs-bug-insert-to-mailer):
+ Check report-emacs-bug-can-use-osx-open and use that if t.
+ (report-emacs-bug-can-use-osx-open): New function.
+ (report-emacs-bug): Rename can-xdg-email to can-insert-mail.
+ Check report-emacs-bug-can-use-osx-open also for can-insert-mail.
+
+2011-01-29 Chong Yidong <cyd@stupidchicken.com>
+
+ * vc/vc-dispatcher.el (vc-set-async-update): New function for
+ updating Dired or VC-dir buffers after async command completes.
+
+ * vc/vc-bzr.el (vc-bzr-async-command): Return the process buffer.
+ (vc-bzr-pull, vc-bzr-merge-branch): Use vc-set-async-update.
+
+ * vc/vc-git.el (vc-git-merge-branch): Add FETCH_HEAD to branch
+ completions if it exists. Use vc-set-async-update.
+ (vc-git-pull): Use vc-set-async-update.
+
+ * vc/vc-hg.el (vc-hg-pull): Fix default-contents arg to
+ read-shell-command. Use vc-set-async-update.
+ (vc-hg-merge-branch): Use vc-set-async-update.
+
+2011-01-29 Daiki Ueno <ueno@unixuser.org>
+
+ * epg.el (epg--status-KEYEXPIRED, epg--status-KEYREVOKED):
+ Don't presume KEYEXPIRED and KEYREVOKED to be a fatal error status
+ (Bug#7931).
+
+2011-01-29 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/compile.el: Avoid an N² behavior in grep.
+ (compilation--previous-directory): New fun.
+ (compilation--previous-directory-cache): New var.
+ (compilation--remove-properties): Flush it.
+ (compilation-directory-properties, compilation-error-properties):
+ Use the new fun to speed up looking for the current directory.
+
+2011-01-29 Chong Yidong <cyd@stupidchicken.com>
+
+ * vc/vc-hg.el (vc-hg-history): New var.
+ (vc-hg-pull): Perform default pull if called via Lisp by vc-pull.
+ (vc-hg-merge-branch): New function.
+
+ * vc/vc.el (vc-pull): Make vc-update an alias for this, instead of
+ the other way around.
+
+ * vc/vc-git.el (vc-git-branches, vc-git-pull)
+ (vc-git-merge-branch): New functions.
+ (vc-git-history): New var.
+
+2011-01-28 Chong Yidong <cyd@stupidchicken.com>
+
+ * vc/vc-dispatcher.el (vc-do-async-command): New function.
+
+ * vc/vc-bzr.el (vc-bzr-async-command): Convert into a wrapper for
+ vc-do-async-command.
+
+ * vc/vc-bzr.el (vc-bzr-pull, vc-bzr-merge-branch):
+ Callers changed.
+
+2011-01-28 Leo <sdl.web@gmail.com>
+
+ * emacs-lisp/advice.el (ad-make-advised-docstring): Don't apply
+ highlighting to the "this function is advised" message.
+
+ * help-mode.el (help-mode-finish): Apply highlighting here, to
+ avoid clobbering by substitute-command-keys (Bug#6304).
+
+2011-01-28 Chong Yidong <cyd@stupidchicken.com>
+
+ * woman.el (woman0-roff-buffer): Process roff escape sequences
+ occurring prior to the first request (Bug#7843).
+
+2011-01-28 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/compile.el: Don't use font-lock any more.
+ (compilation-error-regexp-alist-alist): Change handling of makepp
+ so it preserves the warning/error distinction on subsequent files.
+ Simplify various rules.
+ (compilation-directory-properties): Use font-lock-face.
+ Add a compilation-message property.
+ (compilation-internal-error-properties): Use font-lock-face.
+ Don't set the compilation-debug property here.
+ (compilation--put-prop, compilation--remove-properties)
+ (compilation--parse-region, compilation--ensure-parse)
+ (compilation--ensure-parse): New functions.
+ (compilation-parse-errors): New function, largely inspired of
+ compilation-mode-font-lock-keywords. Set compilation-debug here.
+ (compilation--parsed): New var.
+ (compilation--flush-parse): Use compilation--ensure-parse.
+ (compilation-start): Don't call font-lock.
+ (compilation-turn-on-font-lock): Remove.
+ (compilation-setup): Don't set font-lock-extra-managed-props not change
+ other font-lock settings, other than keywords.
+ Don't activate font-lock-mode.
+ Set change-major-mode-hook and before-change-functions.
+ (compilation--unsetup): Remove properties and hooks.
+ (compilation-next-single-property-change): New function.
+ (compilation-next-error): Use it to parse when needed.
+ (compile-goto-error): Parse buffer as needed.
+ (compilation--compat-error-properties): Don't need a dummy `face'
+ property any more.
+
+2011-01-28 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/compile.el: Use accessors for clarity and fix omake hack.
+ (compilation-process-setup-function): Fix docstring's false promises.
+ (compilation-error-regexp-alist-alist): Catch omake's continuous
+ recompilation message and avoid reuse of old markers.
+ (compilation-parse-errors-function): Declare obsolete.
+ (compilation-buffer-modtime): Remove.
+ (compilation--make-cdrloc, compilation--loc->col)
+ (compilation--loc->line, compilation--loc->file-struct)
+ (compilation--loc->marker, compilation--loc->visited)
+ (compilation--make-file-struct, compilation--file-struct->file-spec)
+ (compilation--file-struct->formats)
+ (compilation--file-struct->loc-tree): New macros. Use them.
+ (compilation--message): New defstruct. Use them.
+ (compilation-next-error-function): Don't mess with timestamps to try
+ and guess when to reparse.
+
+2011-01-28 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * textmodes/tex-mode.el: Get rid of compilation-parse-errors-function
+ (tex-old-error-file-name): New function,
+ extracted from tex-compilation-parse-errors.
+ (tex-compilation-parse-errors): Remove.
+ (tex-error-regexp-alist): New var.
+ (tex-shell): Use it to avoid compilation-parse-errors-function.
+
+ * progmodes/grep.el (grep-regexp-alist): Tighten regexp.
+ (grep-mode-font-lock-keywords): Remove regexp that seems like
+ a left-over from before we used compile.el.
+ (grep-mode-font-lock-keywords): Call syntax-ppss-flush-cache when
+ modifying the buffer within with-silent-modifications.
+
+ * progmodes/compile.el: Cleanup text-properties namespace by using
+ `compilation-message' instead of `message', `compilation-directory'
+ instead of `directory', and `compilation-debug' instead of `debug'.
+ (compilation-last-buffer, compilation-parsing-end)
+ (compilation-error-list, compilation-old-error-list): Move to the
+ compatibility part of the code.
+ (compilation-error-properties): If `file' is a function, let it return
+ a file name.
+ (compilation-mode-font-lock-keywords): Be more conservative with the
+ omake "^ *" pattern prefix, to try and minimize the risk of
+ pathologically slow regexp matching.
+ (compilation-start): Use inhibit-read-only.
+ (compilation--unsetup): New function.
+ (compilation-shell-minor-mode, compilation-minor-mode): Use it.
+ (compilation-filter): Minor tweaks.
+ (compilation-next-error-function): Try and avoid abusing variables.
+ (compilation--flush-file-structure): New fun.
+ (compilation-fake-loc): Use it to improve behavior when file is reused.
+ (debug-ignored-errors): Add "Moved past last ...".
+ (compilation--compat-error-properties)
+ (compilation--compat-parse-errors): Rename by doubling the "-".
+
+ Port features from the previous prolog.el to the new one.
+ * progmodes/prolog.el (prolog-system): Add GNU and ECLiPSe options.
+ (prolog-program-name, prolog-program-switches, prolog-consult-string)
+ (prolog-compile-string, prolog-prompt-regexp): Get rid of the <foo>-i
+ variable and use a function to compute the value dynamically.
+ (prolog-prompt-regexp): Add regexp for GNU Prolog.
+ (prolog-continued-prompt-regexp): Remove, unused.
+ (prolog-find-value-by-system): Try and use the value of prolog-system
+ in the *prolog* buffer if it helps.
+ (prolog-mode-keybindings-common): Bind C-c C-z unconditionally...
+ (prolog-zip-on): ..and check prolog-system and version here instead.
+ (prolog-inferior-self-insert-command): New command.
+ (prolog-inferior-mode-map): Use it.
+ (prolog-inferior-error-regexp-alist): New var.
+ (prolog-inferior-mode): Use it, with compilation-shell-minor-mode.
+ (prolog-input-filter): Use derived-mode-p.
+ (prolog-inferior-guess-flavor): New function.
+ (prolog-ensure-process): Use it. Use make-comint-in-buffer rather than
+ make-comint to avoid running comint-mode twice.
+ (prolog-inferior-buffer): New fun.
+ (prolog-old-process-region, prolog-old-process-file):
+ Don't call prolog-bsts here...
+ (prolog-build-prolog-command): ...do it here instead.
+ (prolog-old-process-region, prolog-old-process-file):
+ Use compilation-fake-loc and compilation-forget-errors.
+ (prolog-consult-compile-region): Use bolp.
+
+2011-01-28 Chong Yidong <cyd@stupidchicken.com>
+
+ * image-mode.el (image-display-size): Doc fix (Bug#7820).
+
+2011-01-27 Sam Steingold <sds@gnu.org>
+
+ * midnight.el (clean-buffer-list-kill-never-buffer-names):
+ Remove "*server*" which is never created by emacs server.
+
+2011-01-27 Deniz Dogan <deniz.a.m.dogan@gmail.com>
+
+ * vc/vc-bzr.el (vc-bzr-diff): Don't pass --diff-options unless
+ there are some diff switches.
+
+2011-01-27 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/ruby-mode.el (ruby-syntax-propertize-function):
+ Copy change made to ruby-font-lock-syntactic-keywords.
+
+ * htmlfontify.el: Make it obey the font-lock-face text property.
+ Miscellaneous cleanup such as:
+ - Don't hide expressions after a closing paren.
+ - Move initial setq into let.
+ - Hoist common parts out of ifs.
+ (hfy-p-to-face, hfy-p-to-face-lennart): Remove.
+ (hfy-face-at): Use get-text-property instead.
+ (hfy-prop-invisible-p): Use invisible-p if available.
+ (htmlfontify-manual): Use \\[...].
+ (hfy-html-quote-regex): Use [...].
+ (hfy-combined-face-spec): Simplify.
+ (hfy-compile-face-map): Don't presume point-min==1.
+ (hfy-css-name, hfy-buffer, htmlfontify-buffer): Use \' rather than $ to
+ match end of string.
+ (hfy-text-p): η-reduce.
+ (hfy-tags-for-file): Receive cache-hash directly.
+ (hfy-mark-tag-names): Adjust call.
+
+2011-01-27 Glenn Morris <rgm@gnu.org>
+
+ * msb.el (msb-after-load-hooks): Make it an obsolete alias.
+ (msb-after-load-hook): Remove eval-after-load wackiness.
+
+2011-01-25 Sam Steingold <sds@gnu.org>
+
+ * vc/vc-svn.el (vc-svn-diff): Use `diff-command' instead of the
+ literal "diff" (important for windows-nt).
+
+2011-01-25 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/copyright.el (copyright-at-end-flag)
+ (copyright-names-regexp): Add safety properties.
+ (copyright-year-ranges): New option.
+ (copyright-find-end): New function, split from copyright-update-year.
+ (copyright-update-year): Use copyright-find-end.
+ (copyright-fix-years): Optionally, convert years to ranges.
+ Handle years continued over comment lines.
+ Do not mess with the fill-prefix.
+ Do not call copyright-update.
+ (copyright-update-directory): Optionally, fix years rather than update.
+ Skip directories. Find files with only safe local vars.
+
+2011-01-25 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * files.el (file-name-non-special): Only change buffer-file-name after
+ insert-file-contents if it's `visit'ing the file (bug#7854).
+
+2011-01-25 Chong Yidong <cyd@stupidchicken.com>
+
+ * dired.el (dired-revert): Doc fix (Bug#7758).
+
+ * simple.el (line-move-visual): Doc fix (Bug#7594).
+
+2011-01-25 Nobuyoshi Nakada <nobu@ruby-lang.org>
+
+ * progmodes/ruby-mode.el (ruby-here-doc-beg-match): Fix for
+ here-doc which ends with an underscore.
+ (ruby-mode-set-encoding): Skip shebang line always.
+ (ruby-mode-map): Bind C-c C-c to comment-region.
+ (ruby-font-lock-keywords): Highlight literal hash key labels as symbols.
+ (ruby-forward-sexp): Stop after literal hash key labels.
+ (ruby-font-lock-syntactic-keywords): Highlight regexp after open
+ bracket.
+
+2011-01-25 Keitaro Miyazaki <keitaro.miyazaki@gmail.com> (tiny change)
+
+ * emacs-lisp/re-builder.el (reb-mode-map): Set case-fold-search in
+ the correct buffer (Bug#7650).
+
+2011-01-25 Glenn Morris <rgm@gnu.org>
+
+ * comint.el (comint-mode): Doc fix. (Bug#7897)
+
+ * simple.el (do-auto-fill): Give it a doc string.
+
+ * button.el (make-text-button): Doc fix. (See bug#7881)
+
+2011-01-24 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/perl-mode.el (perl-syntax-propertize-special-constructs):
+ Don't move backward, so as not to fall in an inf-loop (bug#7736).
+
+ * progmodes/ruby-mode.el (ruby-syntax-propertize-function): (bug#7735)
+ Handle ?" and friends differently (e.g. don't use backrefs).
+
+2011-01-24 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc.el (calc-default-power-reference-level)
+ (calc-default-field-reference-level): New variables.
+ * calc/calc-units.el (math-standard-units): Add dB and Np.
+ (math-logunits): New variable.
+ (math-extract-logunits, math-logcombine, calcFunc-luplus)
+ (calcFunc-luminus, calc-luplus, calc-luminus, math-logunit-level)
+ (calcFunc-fieldlevel, calcFunc-powerlevel, calc-level):
+ New functions.
+ (math-find-base-units-rec): Add entry for ln(10).
+ * calc/calc-help.el (calc-u-prefix-help): Add logarithmic help.
+ (calc-ul-prefix-help): New function.
+ * calc/calc-ext.el (calc-init-extensions): Autoload new units
+ functions. Add keybindings for new units functions.
+
+2011-01-22 Giorgos Keramidas <keramida@ceid.upatras.gr> (tiny change)
+
+ * net/rcirc.el (rcirc-kill-buffer-hook): Flush logs when killing
+ rcirc buffers. (Bug#4940)
+
+2011-01-22 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/copyright.el (copyright-find-copyright): New function,
+ split out from copyright-update-year.
+ (copyright-update): Don't mess with the GPL version if we don't own the
+ copyright. Update license regexp, and remove no longer needed
+ Esperanto stuff.
+ (copyright-fix-years): Use copyright-find-copyright.
+
+2011-01-22 Chong Yidong <cyd@stupidchicken.com>
+
+ * vc/diff.el (diff-sentinel): Doc fix (Bug#7682).
+
+2011-01-22 Jari Aalto <jari.aalto@cante.net>
+
+ * play/landmark.el: Change `lm-' prefix to `landmark-' (Bug#7672).
+ (lm): Rename to landmark.
+ (lm-test-run): Rename to landmark-test-run.
+
+2011-01-22 Chong Yidong <cyd@stupidchicken.com>
+
+ * emacs-lisp/re-builder.el (reb-mode-map): Fix logic error in
+ "Case sensitive" menu item.
+
+2011-01-22 Roland McGrath <roland@frob.com>
+
+ * comint.el (comint-replace-by-expanded-history-before-point): Fix
+ expansion of !$ and !!:N syntax to pick the indicated word (bug#7883).
+
+2011-01-22 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/js.el (js--regexp-literal): Count backslashes (bug#7882).
+
+2011-01-22 Jari Aalto <jari.aalto@cante.net>
+
+ * emacs-lisp/checkdoc.el (checkdoc-this-string-valid-engine):
+ Assume foo(bar) is a manpage reference rather than some unquoted
+ symbol (bug#7705).
+
+2011-01-22 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * subr.el (shell-quote-argument): Properly quote \n (bug#7687).
+ Suggested by Flo <sensorflo@gmail.com>.
+
+2011-01-22 Glenn Morris <rgm@gnu.org>
+
+ * progmodes/compile.el (compilation-error-regexp-alist):
+ Fix custom type. (Bug#7812)
+
+2011-01-22 Ken Manheimer <ken.manheimer@gmail.com>
+
+ * allout.el (allout-prefixed-keybindings): Bind (prefixed) '#' to
+ allout-number-siblings, in keeping with what obtained due to
+ (now-defunct) allout-keybindings-list. Ditch repeat binding to
+ (prefixed) ?i.
+ (allout-before-change-handler): Better expose spots affected by
+ undo.
+
+2011-01-22 Chong Yidong <cyd@stupidchicken.com>
+
+ * man.el (Man-highlight-references0): Use make-button (Bug#7881).
+
+2011-01-22 Phil Hagelberg <phil@evri.com>
+
+ * pcmpl-unix.el (pcmpl-ssh-config-file): New option.
+ (pcmpl-ssh-known-hosts): Rename from pcmpl-ssh-hosts.
+ (pcmpl-ssh-config-hosts): New function.
+ (pcmpl-ssh-hosts): Use pcmpl-ssh-config-hosts in addition to
+ pcmpl-ssh-known-hosts.
+
+2011-01-21 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc-undo.el (calc-undo): Autoload it.
+ * calc/calc-ext.el (calc-init-extensions): Remove keybindings
+ and autoload for `calc-undo'.
+ * calc/calc.el (calc-mode-map): Add keybindings for `calc-undo'.
+ * calc/calc-prog.el:
+ * calc/calc-graph.el:
+ * calc/calc-map.el: Change `arglist' to `math-arglist' throughout.
+
+2011-01-21 Štěpán Němec <stepnem@gmail.com> (tiny change)
+
+ * calc/calc-ext.el (calc-init-extensions): Map all `undo'
+ keybindings to `calc-undo'.
+
+2011-01-20 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Don't mess with *temp*.
+ * obsolete/spell.el: Move from textmodes/spell.el.
+ (spell-string):
+ * term.el (term-read-input-ring):
+ * startup.el (display-startup-echo-area-message):
+ * progmodes/antlr-mode.el (antlr-directory-dependencies):
+ * comint.el (comint-read-input-ring): Use with-temp-buffer.
+ * international/mule.el (ctext-pre-write-conversion): Don't hardcode
+ point-min==1.
+
+2011-01-20 Ken Manheimer <ken.manheimer@gmail.com>
+
+ * allout.el (allout-institute-keymap): Use fset instead of
+ reapplying defalias.
+
+ (allout-hotspot-key-handler): Check for non-control-modified
+ bindings for hotspot characters if there are no control-modified
+ versions.
+
+ * allout.el: Summary - migrate to defining allout mode using
+ define-minor-mode instead of defun. Significantly clean-up
+ internal keymap provisions, refactoring and, in the process,
+ removing a lot of accumulated cruft.
+
+ allout-mode-map is now a keymap by virtue of being a defalias to
+ allout-mode-map-value, which contains the actual keymap structure.
+
+ (allout-mode): Use define-minor-mode rather than defun.
+ Remove now-unnecessary minor-mode setup activities from the body.
+ Specify :keymap as allout-mode-map so the minor-mode-map-alist
+ entry will be '(allout-mode . allout-mode-map) - see
+ allout-mode-map-value, below. Adjust docstring to track changes.
+ (allout-minor-mode): Remove this defalias, now that we're using
+ define-minor-mode.
+ (allout-mode-map): Set value to be 'allout-mode-map. The actual
+ keymap is allout-mode-map-value, via defalias.
+ (allout-mode-map-value): The variable holding the actual mode
+ keymap structure, by virtue of defalias from allout-mode-map.
+ (allout-compose-and-institute-keymap): Rename from
+ allout-bind-keys, and including the binding-composition
+ functionality of the former produce-allout-mode-map and
+ allout-setup-mode-map.
+ (allout-institute-keymap): Take over the "setup" part of the former
+ allout-setup-mode-map. Reassign allout-mode-map-value value and
+ update the defalias.
+ (allout-command-prefix, allout-prefixed-keybindings)
+ (allout-unprefixed-keybindings):
+ Use allout-compose-and-institute-keymap to process the bindings.
+ (allout-unprefixed-keybindings): Remove extraneous '?' question marks.
+ (allout-prefixed-keybindings): Elide binding to (prefixed) \C-h -
+ user can customize if they want to use that binding.
+ Bind allout-copy-topic-as-kill to (prefixed) \M-k.
+ Bind allout-up-current-level to (prefixed) \C-u. (I think i mistakenly
+ elided that, previously, instead of the one for \C-h.)
+ (allout-hotspot-key-handler): Remove attempt to resolve the key
+ through the literal key-string lookup on allout-keybindings-list.
+ That probably hasn't worked for a Long Time, and removal of
+ allout-keybindings-list further simplifies the keybindings situation.
+ (allout-pre-command-business): Use allout-mode-map-value instead
+ of allout-mode-map.
+ (allout-preempt-trailing-ctrl-h): Remove. The user can customize
+ the bindings if they want to use a keybinding having a trailing
+ \C-h. No deprecation needed since this feature was never in a release.
+ (allout-keybindings-list): Remove. It's not been useful for a
+ while. (See allout-hotspot-key-handler changes, above.)
+ (produce-allout-mode-map): Remove. Consolidate into
+ allout-compose-and-institute-keymap.
+ (allout-mode-map-adjustments): Remove. No longer necessary with
+ removal of allout-preempt-trailing-ctrl-h.
+ (allout-setup-mode-map): Remove. Consolidate into
+ allout-compose-and-institute-keymap and allout-institute-keymap.
+
+2011-01-20 Glenn Morris <rgm@gnu.org>
+
+ * vc/vc-svn.el (vc-svn-after-dir-status): Tweak previous change.
+
+ * simple.el (read-expression-history): Remove, it's in minibuf.c.
+
+2011-01-20 Chong Yidong <cyd@stupidchicken.com>
+
+ * subr.el (y-or-n-p): Revert 2011-01-07 change, removing ARGS.
+
+ * files.el (find-alternate-file, basic-save-buffer)
+ (basic-save-buffer-2, revert-buffer, recover-file)
+ (kill-buffer-ask, abort-if-file-too-large)
+ (set-visited-file-name, write-file, backup-buffer)
+ (basic-save-buffer, save-some-buffers):
+ * dired-aux.el (dired-compress-file): Callers changed.
+
+2011-01-19 Glenn Morris <rgm@gnu.org>
+
+ * vc/vc-svn.el (vc-svn-after-dir-status, vc-svn-parse-status):
+ Also check the property status. (Bug#7861)
+
+2011-01-18 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-debug-message): Extend function exclude
+ list. Use `regexp-opt'.
+
+2011-01-18 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * textmodes/tex-mode.el (tex-font-lock-verb): Make sure \verb
+ highlighting doesn't spill over subsequent lines.
+
+ * emacs-lisp/easy-mmode.el (define-minor-mode): Don't re-evaluate the
+ keymap expression. Improve docstring.
+
+ * electric.el (electric-indent-post-self-insert-function):
+ Don't auto-indent for indent-to-left-margin, it's too often
+ counter-productive.
+
+2011-01-16 Tassilo Horn <tassilo@member.fsf.org>
+
+ * strokes.el (strokes-read-stroke): Re-fill strokes buffer with
+ spaces if the frame was resized, so that the full visible buffer
+ serves as canvas for strokes.
+
+2011-01-16 Glenn Morris <rgm@gnu.org>
+
+ * info-xref.el (info-xref-docstrings): Replace cl function.
+ Also skip directories.
+
+2011-01-16 Kevin Ryde <user42@zip.com.au>
+
+ * info-xref.el: Version 3.
+ (info-xref-check, info-xref-check-all): Move commentary details
+ into docstrings for better visibility.
+ Use compilation-mode for the results buffer.
+ (info-xref-output, info-xref-output-error, info-xref-with-output)
+ (info-xref-filename, info-xref-in-progress):
+ New internals for this.
+ (info-xref-check-list, info-xref-check-buffer)
+ (info-xref-check-all-custom): Use those.
+ (info-xref-output-buffer): Rename from info-xref-results-buffer.
+ (info-xref-output-heading): Rename from info-xref-filename-heading.
+ (info-xref-good, info-xref-bad, info-xref-xfile-alist)
+ (info-xref-filename-heading): Move to output managing section.
+ (info-xref-docstrings): New command checking "Info node `(foo)Bar'"
+ (info-xref-lock-file-p, info-xref-with-file): New helpers for it.
+ (info-xref-subfile-p): Move to generic section with those two.
+ (info-xref-check-node): New function split from
+ info-xref-check-buffer, shared by info-xref-docstrings.
+ (info-xref-goto-node-p): Move to a checking section with that func.
+ (info-xref-unavail): New counter.
+ (info-xref-check-node): Use it.
+ (info-xref-with-output): Show count of unavailables at end of output.
+ (info-xref-all-info-files): Exclude ".*" dotfiles. Ignore broken
+ symlinks. Exclude .texi files. Exclude Emacs backup files.
+ (info-xref-check-all-custom): Fix quietening viper-mode and
+ gnus-registry-install -- use setq not let so as not to unbind
+ after load.
+
+2011-01-16 Juri Linkov <juri@jurta.org>
+
+ * isearch.el (isearch-abort): Don't quit if search has
+ an incomplete regexp (isearch-error is non-nil). (Bug#7534)
+
+2011-01-15 Mark Diekhans <markd@soe.ucsc.edu>
+
+ * files.el (backup-buffer): Make last-resort backup file in
+ .emacs.d (Bug#6953).
+
+ * subr.el (locate-user-emacs-file): If .emacs.d does not exist,
+ make it with permission 700.
+
+2011-01-15 Kenichi Handa <handa@m17n.org>
+
+ * mail/rmailmm.el (rmail-mime-insert-header):
+ Set rmail-mime-coding-system to a cons whose car is the last coding
+ system used to decode the header.
+ (rmail-mime-find-header-encoding): New function.
+ (rmail-mime-insert-decoded-text):
+ Override rmail-mime-coding-system if it is a cons.
+ (rmail-show-mime): If only a header part was decoded, find the
+ coding system while ignoring mm-charset-override-alist.
+
+2011-01-15 Chong Yidong <cyd@stupidchicken.com>
+
+ * subr.el (event-start, event-end): Doc fix (Bug#7826).
+
+2011-01-15 Kenichi Handa <handa@m17n.org>
+
+ * mail/rmailmm.el (rmail-mime-next-item)
+ (rmail-mime-previous-item): Delete them.
+ (rmail-mime-shown-mode): Recursively call for children.
+ (rmail-mime-hidden-mode): Delete the 2nd arg TOP.
+ Callers changed.
+ (rmail-mime-raw-mode): Recursively call for children.
+ (rmail-mode-map): Change mapping of tab and backtab to
+ forward-button and backward-button respectively.
+ (rmail-mime-insert-tagline): Always insert "Hide" or "Show"
+ button.
+ (rmail-mime-update-tagline): New function.
+ (rmail-mime-insert-text): Call rmail-mime-update-tagline if the
+ body display is changed.
+ (rmail-mime-toggle-button): Rename from rmail-mime-image.
+ (rmail-mime-image): Delete this button type.
+ (rmail-mime-toggle): New button type.
+ (rmail-mime-insert-bulk): Call rmail-mime-update-tagline if the
+ body display is changed. Change the save button label to "Save".
+ Don't process show/hide button here.
+ (rmail-mime-insert-multipart): Call rmail-mime-update-tagline if
+ the body display is changed. Unconditionally call
+ rmail-mime-insert for children.
+ (rmail-mime-handle): Update `display' vector of the just inserted
+ entity.
+ (rmail-mime-process): If mail-header-parse-content-type returns
+ nil, use "text/plain" as the fallback type.
+ (rmail-mime-insert): For raw-mode, recursively call
+ rmail-mim-insert for children.
+ (rmail-mime): Handle the case that the current buffer is not rmail
+ buffer (e.g. in summary buffer).
+
+2011-01-15 Kenichi Handa <handa@m17n.org>
+
+ * mail/rmailmm.el (rmail-mime-next-item)
+ (rmail-mime-previous-item): Skip the body of a non-multipart
+ entity if a tagline is shown.
+
+2011-01-15 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * tmm.el (tmm-get-keymap): Skip bindings without labels (bug#7721).
+ (tmm-prompt): Simplify.
+ (tmm-add-prompt): Remove unused var `win'.
+
+ * whitespace.el (global-whitespace-newline-mode): Fix call (bug#7810)
+ to minor mode which used nil accidentally to mean "turn off".
+
+2011-01-15 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-sh.el (tramp-find-inline-compress)
+ (tramp-get-inline-coding): Quote command after pipe symbol for
+ local calls under W32. (Bug#6784)
+
+2011-01-15 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-default-method): Initialize with pscp/plink
+ only when running under W32.
+
+2011-01-15 Eli Zaretskii <eliz@gnu.org>
+
+ * progmodes/grep.el (grep-compute-defaults): Quote the program
+ file name after the pipe symbol in Grep templates. (Bug#6784)
+ * jka-compr.el (jka-compr-partial-uncompress): Likewise.
+
+2011-01-15 Lennart Borgman <lennart.borgman@gmail.com>
+
+ * buff-menu.el (Buffer-menu-buffer-list): New var.
+ (Buffer-menu-revert-function, list-buffers-noselect): Use it, so a
+ restricted buffer list is not lost on revert (Bug#7749).
+
+2011-01-15 Eric Hanchrow <eric.hanchrow@gmail.com>
+
+ * net/ldap.el (ldap-search-internal): Discard stderr output.
+
+2011-01-15 Eli Zaretskii <eliz@gnu.org>
+
+ * files.el (directory-abbrev-alist): Doc fix. (Bug#7777)
+
+2011-01-15 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * vc-bzr.el (vc-bzr-annotate-time): Tweak previous change.
+
+2011-01-15 Kenichi Handa <handa@m17n.org>
+
+ * mail/rmailmm.el (rmail-mime-insert-bulk): Display an unknown
+ part as a plain text.
+ (rmail-mime-process-multipart): Set the default content-type to
+ nil for unknown multipart subtypes (bug#7651).
+
+2011-01-14 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * hexl.el (hexl-mode-old-*): Remove.
+ (hexl-mode--old-var-vals): New var to replace them.
+ (hexl-mode--minor-mode-p, hexl-mode--setq-local): New funs.
+ (hexl-mode, hexl-follow-line, hexl-activate-ruler):
+ Use them to set local vars (bug#7846).
+ (hexl-mode-exit): Use hexl-mode--old-var-vals to restore state.
+ (hexl-backward-short, hexl-backward-word, hexl-scroll-down)
+ (hexl-scroll-up, hexl-end-of-1k-page, hexl-end-of-512b-page): Simplify.
+
+ * vc/smerge-mode.el: Resolve comment conflicts more aggressively.
+ (smerge-resolve--normalize-re): New var.
+ (smerge-resolve--extract-comment, smerge-resolve--normalize): New funs.
+ (smerge-resolve): Use them.
+ * newcomment.el (comment-only-p): New function.
+ (comment-or-uncomment-region): Use it.
+
+2011-01-14 Brent Goodrick <bgoodr@gmail.com> (tiny change)
+
+ * abbrev.el (prepare-abbrev-list-buffer): If listing local abbrev
+ table, get the value before switching to the output buffer. (Bug#7733)
+
+2011-01-14 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/python.el (python-mode): Don't impose font-lock (bug#3628).
+
+2011-01-14 Kim F. Storm <storm@cua.dk>
+
+ * emulation/cua-base.el (cua--init-keymaps):
+ Remap exchange-point-and-mark in cua-global-keymap.
+
+2011-01-14 Tassilo Horn <tassilo@member.fsf.org>
+
+ * progmodes/sh-script.el (sh-other-keywords): Add ZSH's foreach
+ loop keyword.
+
+2011-01-14 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/easymenu.el: Add :enable (bug#7754), and obey :label.
+ Require CL.
+ (easy-menu-create-menu, easy-menu-convert-item-1):
+ Use :label rather than nil for labels. Use `case'.
+ Add :enable as alias for :active.
+ (easy-menu-binding): Obey :label.
+
+2011-01-13 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Use run-mode-hooks for major mode hooks (bug#513).
+ * textmodes/reftex-toc.el (reftex-toc-mode-map):
+ Rename from reftex-toc-map.
+ (reftex-toc-mode): Use define-derived-mode.
+ * textmodes/reftex-sel.el (reftex-select-shared-map): New map.
+ (reftex-select-label-mode-map, reftex-select-bib-mode-map):
+ Rename from reftex-select-(label|bib)-map. Move init into declaration.
+ (reftex-select-label-mode, reftex-select-bib-mode):
+ Use define-derived-mode.
+ * textmodes/reftex-index.el (reftex-index-phrases-mode-map)
+ (reftex-index-mode-map): Rename from reftex-index(-phrases)-map.
+ Move init into delcaration.
+ (reftex-index-mode, reftex-index-phrases-mode):
+ Use define-derived-mode.
+ * speedbar.el (speedbar-mode-syntax-table): Renaqme from
+ speedbar-syntax-table. Move init into declaration.
+ (speedbar-mode-map): Rename from speedbar-key-map.
+ Move init into declaration.
+ (speedbar-file-key-map): Move init into declaration.
+ (speedbar-mode): Use define-derived-mode.
+ * recentf.el (recentf-mode): Don't run hook (or message) redundantly.
+ * net/rcirc.el (rcirc-mode): Use run-mode-hooks.
+ * emacs-lisp/chart.el (chart-mode-map): Rename from chart-map.
+ (chart-face-list): Move initialization into declaration.
+ (chart-mode): Use define-derived-mode.
+ * calculator.el (calculator-mode-map): Move init into declaration.
+ (calculator-mode): Use define-derived-mode.
+
+ * mail/mail-utils.el (mail-strip-quoted-names): Make the regexp code
+ work for nested comments.
+
+ * progmodes/prolog.el: Use syntax-propertize. Further code cleanup.
+ (prolog-use-prolog-tokenizer-flag): Change default when
+ syntax-propertize can be used.
+ (prolog-syntax-propertize-function): New var.
+ (prolog-mode-variables): Move make-local-variable into `set'.
+ Don't make comment-column local since we don't set it.
+ Set comment-add (as it was in previous prolog.el). Use dolist.
+ Set syntax-propertize-function.
+ (prolog-mode, prolog-inferior-mode):
+ Call prolog(-inferior)-menu directly, not through the mode-hook.
+ (prolog-buffer-module, prolog-indent-level)
+ (prolog-paren-is-the-first-on-line-p, prolog-paren-balance)
+ (prolog-comment-limits, prolog-goto-comment-column):
+ Use line-(end|beginning)-position.
+ (prolog-build-prolog-command): Tighten up regexp.
+ (prolog-consult-compile): Move make-local-variable into `set'.
+ (prolog-consult-compile-filter, prolog-goto-next-paren)
+ (prolog-help-on-predicate, prolog-clause-info)
+ (prolog-mark-predicate): Don't let+setq.
+ (prolog-indent-line): Use indent-line-to.
+ Only call prolog-goto-comment-column if necessary.
+ (prolog-indent-level): Use bobp.
+ (prolog-first-pos-on-line): Remove, not used any more.
+ (prolog-in-string-or-comment): Use syntax-ppss if available.
+ (prolog-help-on-predicate): Use read-string.
+ (prolog-goto-predicate-info): Simplify.
+ (prolog-read-predicate): Use `default' rather than `initial'.
+ (prolog-temporary-file): Use make-temp-file to close a security hole.
+ (prolog-toggle-sicstus-sd): New command.
+ (prolog-electric-underscore, prolog-variables-to-anonymous):
+ Use dynamic-scoping as it was meant.
+ (prolog-menu): Move menu definitions to top-level.
+ Use a toggle-button for Sicstus's source debugger.
+ Change "Code" to the more usual "Prolog", and hence change "Prolog"
+ to "System".
+ (prolog-inferior-menu): Reuse prolog-menu's help menu.
+ Move other menu definition to top-level.
+
+2011-01-13 Tassilo Horn <tassilo@member.fsf.org>
+
+ * doc-view.el (doc-view-open-text): Use meaningful text buffer
+ name. Keep original document's directory as default-directory
+ (bug#6446).
+ (doc-view-initiate-display): Fall back to normal mode when
+ doc-view-mode cannot be enabled, also when extracting the document
+ text into a separate buffer (bug#6446).
+
+ * simple.el (shell-command): Don't error out if shell command
+ buffer contains text with non-nil read-only property when erasing
+ the buffer.
+
+2011-01-13 Kim F. Storm <storm@cua.dk>
+
+ * ido.el (ido-may-cache-directory): Move "too-big" check later.
+ (ido-next-match, ido-prev-match): Fix stray reordering of matching
+ items when cycling through the matches.
+
+2011-01-13 Tassilo Horn <tassilo@member.fsf.org>
+
+ * dired-x.el (dired-omit-verbose): New defcustom that allows
+ disabling the omit messages.
+ (dired-omit-expunge): Use it.
+
+2011-01-13 Christian Ohler <ohler@gnu.org>
+
+ * emacs-lisp/ert.el, emacs-lisp/ert-x.el: New files.
+
+2011-01-13 Chong Yidong <cyd@stupidchicken.com>
+
+ * font-lock.el (font-lock-verbose): Default to nil.
+
+2011-01-13 Chong Yidong <cyd@stupidchicken.com>
+
+ * simple.el (sendmail-user-agent-compose): Move to sendmail.el.
+ (compose-mail): New arg RETURN-ACTION.
+ (compose-mail-other-window, compose-mail-other-frame): Likewise.
+
+ * mail/sendmail.el (mail-return-action): New var.
+ (mail-mode): Make it buffer-local.
+ (mail-bury): Obey it. Move special Rmail window handling to
+ rmail-mail-return.
+ (mail, mail-setup): New arg RETURN-ACTION.
+ (sendmail-user-agent-compose): Move from simple.el.
+
+ * mail/rmail.el (rmail-mail-return): New function.
+ (rmail-start-mail): Pass it to compose-mail.
+
+2011-01-12 Chong Yidong <cyd@stupidchicken.com>
+
+ * menu-bar.el (menu-bar-custom-menu): Tweak Mule and Customize
+ menus. Add menu item for customize-themes.
+
+ * cus-theme.el (customize-themes):
+ * emacs-lisp/package.el (package--list-packages):
+ Use switch-to-buffer.
+
+2011-01-11 Johan Bockgård <bojohan@gnu.org>
+
+ * emacs-lisp/unsafep.el (unsafep): Handle backquoted forms.
+
+2011-01-11 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/prolog.el: Fix up coding convention and such.
+ (prolog-indent-width): Use the same default as in
+ previous prolog.el rather than tab-width which depends on which buffer
+ is current when the file is loaded.
+ (prolog-electric-newline-flag): Only enable if electric-indent-mode
+ is not available.
+ (prolog-emacs): Remove. Use (featurep 'xemacs) instead.
+ (prolog-known-systems): Remove.
+ (prolog-mode-syntax-table, prolog-inferior-mode-map):
+ Move initialization into declaration.
+ (prolog-mode-map): Move initialization into declaration.
+ Remove system-specific mode-map vars, since they referred to the same
+ keymap anyway.
+ (prolog-mode-variables): Obey the user's preference w.r.t
+ adaptive-fill-mode. Prefer symbol-value to `eval'.
+ (prolog-mode-keybindings-edit): Add compatibility bindings.
+ (prolog-mode): Use define-derived-mode. Don't handle mercury here.
+ (mercury-mode-map): New var.
+ (mercury-mode, prolog-inferior-mode): Use define-derived-mode.
+ (prolog-ensure-process, prolog-process-insert-string)
+ (prolog-consult-compile): Use with-current-buffer.
+ (prolog-guess-fill-prefix): Simplify data flow.
+ (prolog-replace-in-string): New function to use instead of
+ replace-in-string.
+ (prolog-enable-sicstus-sd): Don't abuse `eval'.
+ (prolog-uncomment-region): Use `uncomment-region' when available.
+ (prolog-electric-colon, prolog-electric-dash): Use `eolp'.
+ (prolog-int-to-char, prolog-char-to-int): New functions to use instead
+ of int-to-char and char-to-int.
+ (prolog-mode-hook, prolog-inferior-mode-hook): Don't force font-lock.
+
+2011-01-11 Stefan Bruda <stefan@bruda.ca>
+
+ * progmodes/prolog.el: Replace by a whole new file.
+
+2011-01-11 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * subr.el (eval-after-load): Fix timing for features (bug#7769).
+ (declare-function, undefined, insert-for-yank)
+ (replace-regexp-in-string): Follow checkdoc's recommendations.
+
+2011-01-10 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * calendar/diary-lib.el (diary-mode): Refresh *Calendar* after
+ refreshing the diary buffer.
+
+2011-01-10 Ken Manheimer <ken.manheimer@gmail.com>
+
+ * allout.el: Add 2011 to the file copyright.
+ (allout-encrypt-string): Prevent encryption from adding an extra
+ newline at the end of the topic body.
+ (allout-version): Increment to 2.3.
+
+2011-01-10 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/dbus.el (dbus-unregister-service): Complete doc.
+ Fix call of dbus-error signal.
+ (dbus-register-property): Use `dont-register' keyword.
+
+2011-01-10 Jan Moringen <jan.moringen@uni-bielefeld.de>
+
+ * net/dbus.el (dbus-unregister-service): Translate returned
+ integer into a symbol.
+ (dbus-register-property): Use `dbus-register-service' to do the
+ name registration.
+
+2011-01-09 Chong Yidong <cyd@stupidchicken.com>
+
+ * progmodes/idlw-help.el (idlwave-help-link): Inherit from link face.
+ Suggested by Joakim Verona.
+
+ * comint.el (comint-highlight-prompt): Inherit minibuffer-prompt.
+
+ * wid-edit.el (visibility): Replace :on-image and :off-image
+ widget properties with :on-glyph and :off-glyph, for consistency
+ with the `visibility' widget.
+ (widget-toggle-value-create, widget-visibility-value-create):
+ Merge into a single function `widget-toggle-value-create'.
+
+ * cus-edit.el (custom-variable-value-create, custom-visibility)
+ (custom-face-edit-value-create, custom-face-value-create):
+ Replace :on-image and :off-image widget properties with :on-glyph and
+ :off-glyph, for consistency with the `visibility' widget.
+
+2011-01-09 Andreas Schwab <schwab@linux-m68k.org>
+
+ * net/ldap.el (ldap-search-internal): Don't use eval.
+
+2011-01-09 Chong Yidong <cyd@stupidchicken.com>
+
+ * subr.el (read-char-choice): Use read-key.
+
+ * custom.el (custom-safe-themes): Rename from
+ custom-safe-theme-files. Add :risky tag.
+ (load-theme, custom-theme-load-confirm): Save sha1 hashes to
+ custom-safe-themes, not filenames. Suggested by Stefan Monnier.
+
+2011-01-09 Chong Yidong <cyd@stupidchicken.com>
+
+ * tool-bar.el (tool-bar-setup): Remove Help button. Remove label
+ from Search and add a label to Undo.
+
+ * vc/vc-dir.el (vc-dir-tool-bar-map): Rearrange, removing
+ inappropriate buttons and adding :vert-only tags.
+
+ * progmodes/compile.el (compilation-mode-tool-bar-map): Adjust to
+ removal of Help tool-bar button. Remove Undo button for space.
+
+ * info.el (info-tool-bar-map): Add :vert-only tags.
+
+2011-01-08 Tassilo Horn <tassilo@member.fsf.org>
+
+ * doc-view.el (doc-view-mode-p): Check for png or imagemagick
+ image backend support. Either of them is fine.
+
+2011-01-08 Chong Yidong <cyd@stupidchicken.com>
+
+ * subr.el (y-or-n-p): Doc fix.
+
+ * custom.el (custom-safe-theme-files): New defcustom.
+ (custom-theme-load-confirm): New function.
+ (load-theme): Load theme using `load', confirming with
+ custom-theme-load-confirm if necessary.
+
+ * subr.el (read-char-choice): New function, factored out from
+ dired-query and hack-local-variables-confirm.
+
+ * dired-aux.el (dired-query):
+ * files.el (hack-local-variables-confirm): Use it.
+
+ * dired-aux.el (dired-compress-file):
+ * files.el (abort-if-file-too-large, find-alternate-file)
+ (set-visited-file-name, write-file, backup-buffer)
+ (basic-save-buffer, basic-save-buffer-2, save-some-buffers)
+ (delete-directory, revert-buffer, recover-file, kill-buffer-ask):
+ Use new format string args for y-or-n-p and yes-or-no-p.
+
+2011-01-08 Andreas Schwab <schwab@linux-m68k.org>
+
+ * progmodes/compile.el (compilation-error-regexp-alist-alist)
+ [gcc-include]: Tighten file name match, add match for column
+ number. (Bug#7806)
+ [gnu]: Remove unused group.
+
+2011-01-08 Glenn Morris <rgm@gnu.org>
+
+ * makefile.w32-in (EMACSOPT): Add --no-site-lisp.
+
+ * makefile.w32-in (EMACSOPT): -batch implies --no-init-file.
+
+2011-01-07 Sam Steingold <sds@gnu.org>
+
+ * w32-fns.el (w32-shell-name): Use `shell-file-name' instead of
+ the `explicit-shell-file-name' because that is the
+ non-interactive shell.
+
+2011-01-07 Chong Yidong <cyd@stupidchicken.com>
+
+ * subr.el (y-or-n-p): Accept format string args.
+
+2011-01-07 Glenn Morris <rgm@gnu.org>
+
+ * Makefile.in (EMACSOPT): Add --no-site-lisp.
+
+2011-01-06 Ken Manheimer <ken.manheimer@gmail.com>
+
+ * allout.el (allout-back-to-current-heading): Ensure return to
+ the visible containing topic, rather than a collapsed one.
+ (allout-view-change-hook): Remove hook that was deprecated long ago.
+ (allout-exposure-change-hook): Remove documentation remarks
+ concerning removed allout-view-change-hook.
+ (allout-flag-region): Remove invocation of and documentation
+ remarks concerning allout-view-change-hook.
+
+2011-01-06 Glenn Morris <rgm@gnu.org>
+
+ * vc/vc-bzr.el (vc-bzr-annotate-command, vc-bzr-annotate-time)
+ (vc-bzr-annotate-extract-revision-at-line):
+ Handle authors with embedded spaces. (Bug#7792)
+
+2011-01-05 Tassilo Horn <tassilo@member.fsf.org>
+
+ * doc-view.el (doc-view-image-width): New variable.
+ (doc-view-enlarge, doc-view-insert-image): Prefer imagemagick
+ backend for PNG images, and do dynamic rescaling instead of
+ reconverting the whole doc.
+
+2011-01-05 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/rx.el (rx-repeat): Replace CL function.
+
+2011-01-04 Ken Manheimer <ken.manheimer@gmail.com>
+
+ * allout.el: Reconcile with changes in line movement behavior for
+ long text lines that cross more than a single physical window
+ line, ie when truncate-lines is nil.
+ (allout-next-visible-heading): Provide for change in line-move
+ behavior on long lines when truncate-lines is nil. In that case,
+ line-move can wind up on the same textual line when it moves to
+ the next window line, and moving to the bullet position after the
+ move yields zero advancement. Add logic to detect and compensate
+ for the lack of progress.
+ (allout-current-topic-collapsed-p): move-end-of-line respect for
+ field boundaries is different when operating with body lines
+ shorter than window width versus ones greater than window width,
+ which can yield false negatives in this function. Avoid
+ difference by applying move-end-of-line while field-text-motion is
+ inhibited.
+
+2011-01-04 Glenn Morris <rgm@gnu.org>
+
+ * textmodes/rst.el (rst-compile-toolsets):
+ Add pdf and s5 to option alist.
+
+2011-01-04 Jan Moringen <jan.moringen@uni-bielefeld.de>
+
+ * net/dbus.el (dbus-register-property): Add optional parameter
+ dont-register-service. Updated docstring accordingly.
+
+2011-01-04 Andreas Schwab <schwab@linux-m68k.org>
+
+ * textmodes/rst.el (rst-compile-pdf-preview)
+ (rst-compile-slides-preview): Remove extra line.
+
+2011-01-04 Glenn Morris <rgm@gnu.org>
+
+ * textmodes/rst.el (rst-compile-toolsets): Make it a defcustom.
+ Add `pdf' and `s5' entries. Use `prog.py' if found, otherwise
+ default to `prog' without a .py extension.
+ (rst-compile-pdf-preview, rst-compile-slides-preview):
+ Use program names from rst-compile-toolsets, rather than hard-coding.
+ (rst-portable-mark-active-p): Fix presumed typo.
+
+2011-01-02 Eli Zaretskii <eliz@gnu.org>
+
+ * term/w32-win.el (dynamic-library-alist): Set up correctly for
+ libpng versions both before and after 1.4.0. (Bug#7716)
+
+2011-01-02 Eli Zaretskii <eliz@gnu.org>
+
+ * time.el (display-time-mode): Mention display-time-interval in
+ the doc string. (Bug#7713)
+
+2011-01-02 Kenichi Handa <handa@m17n.org>
+
+ * mail/rmailmm.el (rmail-mime-parse): Perform parsing in
+ condition-case and return an error message string if something
+ goes wrong.
+ (rmail-show-mime): Adjust for the above change. Insert the
+ header by rmail-mime-insert-header.
+
+2011-01-02 Kenichi Handa <handa@m17n.org>
+
+ * mail/rmailmm.el: New key bindings for rmail-mime-next-item,
+ rmail-mime-previous-item, and rmail-mime-toggle-hidden.
+ (rmail-mime-mbox-buffer)
+ (rmail-mime-view-buffer, rmail-mime-coding-system): New variables.
+ (rmail-mime-entity): Argument changed. All codes handling an
+ entity object are changed.
+ (rmail-mime-entity-header, rmail-mime-entity-body): Adjust for
+ the above change.
+ (rmail-mime-entity-children, rmail-mime-entity-handler)
+ (rmail-mime-entity-tagline): New functions.
+ (rmail-mime-message-p): New function.
+ (rmail-mime-save): Bind rmail-mime-mbox-buffer.
+ (rmail-mime-entity-segment, rmail-mime-next-item)
+ (rmail-mime-previous-item, rmail-mime-shown-mode)
+ (rmail-mime-hidden-mode, rmail-mime-raw-mode)
+ (rmail-mime-toggle-raw, rmail-mime-toggle-hidden)
+ (rmail-mime-insert-tagline, rmail-mime-insert-header):
+ New functions.
+ (rmail-mime-text-handler): Call rmail-mime-insert-text.
+ (rmail-mime-insert-decoded-text): New function.
+ (rmail-mime-insert-text): Call rmail-mime-insert-decoded-text.
+ (rmail-mime-insert-image): Argument changed. Caller changed.
+ (rmail-mime-image): Call rmail-mime-toggle-hidden.
+ (rmail-mime-set-bulk-data): New function.
+ (rmail-mime-insert-bulk): Argument changed.
+ (rmail-mime-multipart-handler): Return t.
+ (rmail-mime-process-multipart): Argument changed.
+ Handle "multipart/alternative" here.
+ (rmail-mime-process): Argument changed.
+ (rmail-mime-parse): Bind rmail-mime-mbox-buffer.
+ (rmail-mime-insert): Argument changed. Handle raw display mode.
+ (rmail-mime): Argument changed. Handle toggling of raw display
+ mode.
+ (rmail-show-mime): Bind rmail-mime-mbox-buffer and
+ rmail-mime-view-buffer.
+ (rmail-insert-mime-forwarded-message): Likewise.
+ (rmail-search-mime-message): Likewise. Don't bind rmail-buffer.
+
+ * mail/rmail.el (rmail-show-message-1): If rmail-enable-mime is
+ non-nil, handle the header in rmail-show-mime-function.
+
+2011-01-02 Leo <sdl.web@gmail.com>
+
+ * help-fns.el (describe-variable): Fix previous change.
+
+2011-01-02 Juri Linkov <juri@jurta.org>
+
+ * isearch.el (isearch-lazy-highlight-error): New variable.
+ (isearch-lazy-highlight-new-loop): Compare `isearch-error' and
+ `isearch-lazy-highlight-error'. Set `isearch-lazy-highlight-error'
+ to the current value of `isearch-error' (Bug#7468).
+
+2011-01-02 Chong Yidong <cyd@stupidchicken.com>
+
+ * help-fns.el (describe-variable): Don't emit trailing whitespace
+ (Bug#7511).
+
+2011-01-02 Chong Yidong <cyd@stupidchicken.com>
+
+ * textmodes/rst.el (rst-compile-pdf-preview)
+ (rst-compile-slides-preview): Use make-temp-file (Bug#7646).
+
+2011-01-02 Kevin Gallagher <Kevin.Gallagher@boeing.com>
+
+ * emulation/edt-mapper.el: Override mapping of function keys so
+ that the later call to read-key-sequence works.
+
+2011-01-02 Eli Zaretskii <eliz@gnu.org>
+
+ * mail/smtpmail.el (smtpmail-send-it): Write queued mail body with
+ Unix EOLs. (Bug#7589)
+
+2011-01-02 Leo <sdl.web@gmail.com>
+
+ * eshell/em-hist.el (eshell-previous-matching-input): Signal error
+ if point is not behind eshell-last-output-end (Bug#7585).
+
+2011-01-02 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * files.el (file-local-variables-alist):
+ Make permanent-local (bug#7767).
+
+2011-01-02 Glenn Morris <rgm@gnu.org>
+
+ * version.el (emacs-copyright): Set short copyright year to 2011.
+
+2011-01-02 Mark Lillibridge <mark.lillibridge@hp.com> (tiny change)
+
+ * mail/mail-utils.el (mail-strip-quoted-names): Avoid clobbering
+ an existing temp buffer. (Bug#7746)
+
+2011-01-02 Glenn Morris <rgm@gnu.org>
+
+ * mail/mail-utils.el (mail-mbox-from): Handle From: headers with
+ multiple addresses. (Bug#7760)
+
+2011-01-01 Ken Manheimer <ken.manheimer@gmail.com>
+
+ * allout.el (allout-auto-fill): Do not infinitely recurse - use
+ do-auto-fill if everything points back to allout-auto-fill.
+ (allout-mode-deactivate-hook): Declare obsolete, in favor of
+ standard-formed minor-mode deactivate hook, allout-mode-off-hook.
+
+2010-12-31 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-sh.el (tramp-methods): Add recursive options to "scpc"
+ and "scpx".
+
+2010-12-30 Tassilo Horn <tassilo@member.fsf.org>
+
+ * doc-view.el (doc-view-set-doc-type): New function refactored
+ from doc-view-mode.
+ (doc-view-fallback-mode): New function.
+ (doc-view-mode): Use it.
+ (doc-view-mode-maybe): New function that checks if doc-view-mode
+ can be used and falls back to the next best mode otherwise.
+
+ * files.el (auto-mode-alist): Use doc-view-mode-maybe for PDF,
+ DVI, OpenDocument, and MS Office files.
+
+2010-12-30 Andreas Schwab <schwab@linux-m68k.org>
+
+ * emacs-lisp/rx.el (rx-syntax): Fix typo.
+
+2010-12-30 Tassilo Horn <tassilo@member.fsf.org>
+
+ * doc-view.el (doc-view-toggle-display): Perform rassq-delete-all
+ on a copy of auto-mode-alist, because that deletes with side
+ effects.
+
+2010-12-30 Tassilo Horn <tassilo@member.fsf.org>
+
+ * doc-view.el (doc-view-mode, doc-view-toggle-display):
+ Use normal-mode without doc-view-mode bindings in auto-mode-alist as
+ fallback instead of hard coding fundamental mode.
+
+2010-12-30 Tassilo Horn <tassilo@member.fsf.org>
+
+ * doc-view.el (doc-view-doc->txt): Handle OpenDocument (or MS
+ Office) files also for searching.
+
+2010-12-30 Tassilo Horn <tassilo@member.fsf.org>
+
+ * doc-view.el: Implement viewing of OpenDocument (and Microsoft
+ Office) files. Not yet enabled via auto-mode-list.
+ (doc-view-unoconv-program): New custom variable.
+ (doc-view-mode-p): Handle new odf document type.
+ (doc-view-odf->pdf): New conversion function.
+ (doc-view-convert-current-doc): Call it for odf files.
+ (doc-view-mode): Recognize newly supported file extensions.
+
+2010-12-30 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-default-method-alist)
+ (tramp-default-user-alist)
+ (tramp-local-host-regexp, tramp-prefix-domain-format)
+ (tramp-prefix-domain-regexp): Set tramp-autoload cookie.
+
+ * net/tramp-ftp.el:
+ * net/tramp-gvfs.el:
+ * net/tramp-gw.el:
+ * net/tramp-imap.el:
+ * net/tramp-sh.el:
+ * net/tramp-smb.el: Add tramp-autoload cookie for initialisation
+ code of `tramp-default-method-alist' and `tramp-default-user-alist'.
+
+2010-12-29 Karl Fogel <kfogel@red-bean.com>
+
+ * saveplace.el (save-place-alist-to-file): Save list sorted and
+ pretty-printed, so that it is mergeable by line-based text merging,
+ as suggested by Iain Dalton <iain.dalton {_AT_} gmail.com>.
+
+2010-12-28 Ken Manheimer <ken.manheimer@gmail.com>
+
+ * allout.el (allout-v18/19-file-var-hack): Obsolete, remove.
+ (allout-mode): Argument "toggle" => "force".
+ Refine the docstring.
+ Remove special provisions for reactivation, besides the 'force'
+ argument.
+ Consolidate layout provisions coce directly into the activation
+ condition branch, now that we've removed those provisions.
+ (allout-unload-function): Explicitly activate the mode before
+ deactivating, if it's initially deactivated.
+ (allout-set-buffer-multibyte): Properly prevent byte-compiler
+ warnings for version of function used only where
+ set-buffer-multibyte is unavailable.
+
+2010-12-28 Chong Yidong <cyd@stupidchicken.com>
+
+ * tool-bar.el (tool-bar-setup): Remove :enable conditions, which
+ are handled by the menu-bar entries. As before, don't use
+ :visibile to avoid changing the tool-bar.
+
+2010-12-27 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/secrets.el (secrets-delete-alias): New defun.
+
+2010-12-27 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-default-user-alist): Do not add "ssh" based
+ methods, otherwise ~/.ssh/config would be ignored.
+
+2010-12-26 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/rx.el: Make it a superset of sregex.
+ (rx-constituents): Add `any => "."', mark `repeat' as taking any number
+ of args, add `regex' alias.
+ (rx-info): Add arg to distinguish head and standalone forms.
+ (rx-check, rx-form): Pass the corresponding arg.
+ (rx-**): Simplify.
+ (rx-repeat): Make it work for any number of args.
+ (rx-syntax): Make it accept syntax chars as is.
+ * obsolete/sregex.el: Move from emacs-lisp/.
+ * emacs-lisp/re-builder.el: Remove sregex support.
+ * emacs-lisp/edebug.el (sregexq, rx): Remove redundant defs.
+
+2010-12-25 Eli Zaretskii <eliz@gnu.org>
+
+ * mouse.el (mouse-yank-primary): On MS-Windows, try the (emulated)
+ PRIMARY first, then the clipboard. (Bug#7699)
+
+2010-12-22 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/bytecomp.el (byte-compile-output-docform): Fix up use of
+ print-number-table.
+
+2010-12-21 Chong Yidong <cyd@stupidchicken.com>
+
+ * help-fns.el (find-lisp-object-file-name): Locate .emacs from
+ .emacs.elc (Bug#7530).
+
+ * wid-edit.el (widget-image-find): Remove bogus :ascent spec from
+ image spec (Bug#7480).
+
+2010-12-21 Daiki Ueno <ueno@unixuser.org>
+
+ * obsolete/pgg-parse.el, obsolete/pgg-pgp5.el, obsolete/pgg-pgp.el,
+ * obsolete/pgg-gpg.el, obsolete/pgg-def.el, obsolete/pgg.el:
+ Move from lisp/.
+
+2010-12-20 Leo <sdl.web@gmail.com>
+
+ * dnd.el (dnd-get-local-file-name): Unhex of file name shall
+ always be performed (Bug#7680).
+
+2010-12-20 Chong Yidong <cyd@stupidchicken.com>
+
+ * menu-bar.el (menu-bar-kill-ring-save): Make obsolete.
+ (menu-bar-edit-menu): Bind "Copy" to kill-ring-save. Don't use
+ mouse-region-match.
+
+ * color.el: Move from gnus/.
+
+ * vc/diff.el (diff-better-file-name): Function deleted.
+ abbreviating file names causes problems with shell-quote-argument.
+ (diff-no-select): Just use expand-file-name.
+
+ * tool-bar.el (tool-bar--image-expression): New function.
+ (tool-bar-local-item, tool-bar--image-exp): Use it.
+ (tool-bar-setup): Initialize tool-bar-separator-image-expression.
+ Use :enable instead of :visible to avoid changing the tool-bar
+ configuration unnecessarily.
+
+ * info.el (info-tool-bar-map): Add separators.
+
+2010-12-17 Ken Brown <kbrown@cornell.edu>
+
+ * loadup.el: Use version numbers in Cygwin build.
+
+2010-12-17 Ryan Twitchell <metatheorem@gmail.com> (tiny change)
+
+ * ido.el (ido-file-internal): Ask for confirmation before
+ overwriting an existing file (Bug#1238).
+
+2010-12-16 Chong Yidong <cyd@stupidchicken.com>
+
+ * tool-bar.el (tool-bar-setup): Add separators.
+
+ * menu-bar.el (featurep): Use menu-bar-separator.
+
+2010-12-16 Ken Manheimer <ken.manheimer@gmail.com>
+
+ Migrate allout encryption provisions from pgg to epg.
+
+ * allout.el (allout-toggle-current-subtree-encryption)
+ (allout-toggle-subtree-encryption): Adjust docstrings to reflect
+ defaulting policy and other changes. Change fetch-pass to keymode-cue,
+ for simpler universal argument interpretation.
+ (allout-toggle-subtree-encryption): Adjust docstring to describe
+ changed encryption provisions. Change fetch-pass to keymode-cue, for
+ simpler universal argument interpretation. Remove provisions for
+ handling key type and identity - they'll all be within
+ allout-encrypt-string or epg/epg or even contained all the way in gpg.
+ (allout-encrypt-string): Include keymode-cue, for optionally prompting
+ for keypair recipients (universal argument > 1) and, in addition,
+ associating the specified recipients with the outline (universal
+ argument > 4) using a file local variable setting for
+ 'epa-file-encrypt-to'.
+ Require epa, for recipients handling.
+ Change how regexp filtering elements are named.
+ Describe the problem with caching of incorrect symmetric-decryption
+ keys.
+ Use the epa-passphrase-callback-function, in case the user is using
+ GnuPG v1.
+ Support saving of the selected keypair recipients when invoked with a
+ keymode-cue > 4.
+ Remove obsolete arguments 'fetch-pass', 'target-cache-id', 'retried'.
+ Require 'epa.
+ Establish epg-context with armoring and default epg-protocol.
+ Remove all passphrase cache, verification, and hinting code.
+ (allout-passphrase-verifier-handling, allout-passphrase-hint-handling):
+ No longer used, delete.
+ (allout-mode): Adjust docstring to describe changed encryption
+ provisions. Describe the problem with caching of incorrect
+ symmetric-decryption keys.
+ (allout-obtain-passphrase, allout-epg-passphrase-callback-function)
+ (allout-make-passphrase-state, allout-passphrase-state-passphrase)
+ (allout-encrypted-key-info, allout-update-passphrase-mnemonic-aids)
+ (allout-get-encryption-passphrase-verifier, allout-verify-passphrase):
+ Obsolete, remove.
+
+2010-12-16 Daiki Ueno <ueno@unixuser.org>
+
+ * epa-file.el (epa-file-select-keys): Accept 'silent to inhibit
+ key selection prompt; make 'silent as default (Bug#7487).
+
+2010-12-16 Leo <sdl.web@gmail.com>
+
+ * eshell/eshell.el (eshell-directory-name):
+ Use locate-user-emacs-file (Bug#7578).
+
+2010-12-15 Glenn Morris <rgm@gnu.org>
+
+ * loadup.el (symbol-file-load-history-loaded): Remove; unused.
+
+2010-12-15 Jari Aalto <jari.aalto@cante.net>
+ Scott Evans <gse@antisleep.com>
+
+ * rect.el (rectange--default-line-number-format)
+ (rectangle-number-line-callback): New functions.
+ (rectangle-number-lines): New command, bound to C-x r N (Bug#4382).
+
+2010-12-15 Chong Yidong <cyd@stupidchicken.com>
+
+ * rect.el (operate-on-rectangle-lines, string-rectangle-string):
+ Delete unused variables.
+ (move-to-column-force): Remove function obsolete since 21.2.
+
+2010-12-14 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-temp-buffer-file-name): Make it permanent-local.
+ (tramp-handle-insert-file-contents): Do not set permanent-local
+ property.
+
+ * net/tramp-cache.el (tramp-persistency-file-name):
+ Use `locate-user-emacs-file' if fboundp.
+
+ * net/tramp-sh.el (tramp-methods): Add "ksu".
+ (tramp-default-user-alist): Add "ksu". Use `regexp-opt' for
+ method list.
+
+2010-12-14 Glenn Morris <rgm@gnu.org>
+
+ * progmodes/js.el: Doc't require font-lock, etags, or easymenu.
+ (find-tag-marker-ring): Declare.
+ (js-find-symbol): Require etags.
+
+ * mail/sendmail.el: Don't require rmail or mailalias when compiling.
+ Require mail-utils.
+ (mail-alias-file): Don't autoload. Doc fix.
+ (mail-bury-selects-summary, mail-send-nonascii): Don't autoload.
+ (mail-mailer-swallows-blank-line): Default to nil. Doc fix.
+ Mark as obsolete, and risky.
+ (mail-setup): Simplify.
+
+ * mail/mailalias.el (build-mail-aliases): Make it interactive.
+ * mail/sendmail.el (build-mail-aliases): Update autoload.
+
+ * dired.el (dired-trivial-filenames, dired-chown-program)
+ (dired-auto-revert-buffer): Remove autoload cookies.
+ * mail/sendmail.el (mail-recover-1): Require 'dired.
+
+ * dired.el (dired-subdir-switches, dired-chown-program)
+ (dired-use-ls-dired, dired-chmod-program, dired-touch-program):
+ Make into defcustoms.
+ (dired-chown-program): Simplify initialization.
+
+ * mail/mail-utils.el: No need to require lisp-mode, it's in loadup.
+
+2010-12-13 Romain Francoise <romain@orebokech.com>
+
+ * net/gnutls.el (gnutls-negotiate): Fix setting of default trustfiles.
+
+2010-12-13 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * net/netrc.el (netrc-point-at-eol): Remove the unused
+ netrc-point-at-old and netrc-bound-and-true-p bindings.
+ (netrc-parse): Cache the netrc contents.
+
+2010-12-13 Eli Zaretskii <eliz@gnu.org>
+
+ * subr.el (posn-col-row): Evaluate header-line-format in the
+ context of the POSITION window's buffer.
+
+2010-12-13 Glenn Morris <rgm@gnu.org>
+
+ * subr.el (member-ignore-case, run-mode-hooks, insert-for-yank-1)
+ (with-silent-modifications): Doc fixes.
+
+2010-12-13 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-action-password, tramp-process-actions):
+ Revert previous from. Use `save-restriction'.
+
+2010-12-13 Stephen Berman <stephen.berman@gmx.net>
+
+ * calendar/diary-lib.el (diary-list-sexp-entries):
+ Handle case of no newline at end of file. (Bug#7536)
+
+2010-12-13 Glenn Morris <rgm@gnu.org>
+
+ * mail/smtpmail.el (smtpmail-send-it): Revert previous change.
+
+2010-12-13 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-action-password): Delete region, do not narrow.
+ (tramp-process-actions): Do not widen.
+
+ * net/tramp-sh.el (tramp-sh-handle-start-file-process):
+ Protect buffer-modified value. (Bug#7557)
+
+2010-12-13 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+
+ * log-edit.el (log-edit-changelog-entries):
+ Regexp quote filename. (Bug#7505)
+
+2010-12-13 Tom Breton <tehom@panix.com>
+
+ * cus-edit.el (custom-save-all):
+ Bind print-length and print-level to nil. (Bug#7581)
+
+2010-12-13 Glenn Morris <rgm@gnu.org>
+
+ * mouse.el (mouse-menu-major-mode-map, mouse-menu-bar-map):
+ Run hooks to update menu contents. (Bug#7586)
+
+ * mail/smtpmail.el (smtpmail-send-it): Avoid colons in the queued
+ file names, for the sake of MS Windows. (Bug#7588)
+
+2010-12-13 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * diff-mode.el (diff-refine-hunk): Make it work when the hunk contains
+ empty lines without a leading space.
+
+2010-12-13 Leo <sdl.web@gmail.com>
+
+ * dired-aux.el (dired-do-redisplay): Postpone dired-after-readin-hook
+ while mapping over marks (Bug#6810).
+
+2010-12-13 Chong Yidong <cyd@stupidchicken.com>
+
+ * image-dired.el (image-dired-db-file)
+ (image-dired-temp-image-file, image-dired-gallery-dir)
+ (image-dired-temp-rotate-image-file): Set default values relative
+ to image-dired-dir (Bug#7518).
+
+2010-12-13 Lawrence Mitchell <wence@gmx.li>
+
+ * format.el (format-decode-run-method): Pass args FROM and TO, not
+ point-min and point-max, to shell-command-on-region (Bug#7488).
+
+2010-12-13 Jan Djärv <jan.h.d@swipnet.se>
+
+ * frame.el (blink-cursor-mode): Make default t for ns.
+
+2010-12-13 Bob Rogers <rogers-emacs@rgrjr.dyndns.org>
+
+ * vc-dir.el (vc-dir-query-replace-regexp): Doc fix (Bug#7501).
+
+2010-12-13 Chong Yidong <cyd@stupidchicken.com>
+
+ * comint.el (comint-dynamic-list-input-ring)
+ (comint-dynamic-complete-filename)
+ (comint-replace-by-expanded-filename)
+ (comint-dynamic-simple-complete)
+ (comint-dynamic-list-filename-completions)
+ (comint-dynamic-list-completions): Doc fix (Bug#7499).
+
+ * subr.el (posn-x-y, posn-object-x-y, posn-object-width-height):
+ Doc fix (Bug#7471).
+
+2010-12-13 Martin Rudalics <rudalics@gmx.at>
+
+ * dired.el (dired-pop-to-buffer): Bind pop-up-frames to nil
+ (Bug#7533).
+
+2010-12-13 W. Martin Borgert <debacle@debian.org> (tiny change)
+
+ * files.el (auto-mode-alist): Handle .dbk (DocBook) with xml-mode.
+ (Bug#7491).
+
+2010-12-13 Eli Zaretskii <eliz@gnu.org>
+
+ * files.el (file-relative-name): Handle UNC file names on
+ DOS/Windows. (Bug#4674)
+
+2010-12-13 Daiki Ueno <ueno@unixuser.org>
+
+ * epg.el (epg-digest-algorithm-alist): Replace "RMD160" with
+ "RIPEMD160" (Bug#7490). Reported by Daniel Kahn Gillmor.
+ (epg-context-set-passphrase-callback): Mention that the callback
+ is not called when used with GnuPG 2.x.
+
+2010-12-13 Glenn Morris <rgm@gnu.org>
+
+ * ps-print.el (ps-line-lengths-internal, ps-nb-pages):
+ Ensure ps-footer-font-size-internal is initialized.
+ Call ps-get-page-dimensions before trying to use ps-font-for-text.
+
+2010-12-13 Kenichi Handa <handa@m17n.org>
+
+ * mail/rmailmm.el (rmail-mime-parse): Call rmail-mime-process
+ within condition-case.
+ (rmail-show-mime): Don't use condition-case.
+ (rmail-search-mime-message): New function.
+ (rmail-search-mime-message-function): Set to
+ rmail-search-mime-message.
+
+2010-12-13 Leo <sdl.web@gmail.com>
+
+ * ido.el (ido-common-initialization): New function. (bug#3274)
+ (ido-mode): Use it.
+ (ido-completing-read): Call it.
+
+2010-12-12 Karl Fogel <kfogel@red-bean.com>
+
+ * bookmark.el (bookmark-name-from-full-record): Rename back to
+ this original name from `bookmark-name-from-record' reverting part
+ of 2010-12-08T08:09:27Z!kfogel@red-bean.com / kfogel@red-bean.com-20101208080927-5j9jqnb2xvcw4ogm.
+ As Drew Adams pointed out, there was no reason to cause churn for
+ third-party callers. (Bug#7609)
+
+2010-12-12 Alan Mackenzie <acm@muc.de>
+
+ * progmodes/cc-engine.el (c-forward-type): Before scanning a
+ template arglist, check that the current language supports this.
+
+2010-12-11 Glenn Morris <rgm@gnu.org>
+
+ * vc/vc-bzr.el (vc-bzr-state-heuristic): Also check that the executable
+ state of the file matches. (Bug#7544)
+ (vc-bzr-register, vc-bzr-checkin)
+ (vc-bzr-annotate-extract-revision-at-line): Doc fixes.
+ (vc-directory-exclusion-list): Remove unnecessary eval-after-load.
+
+ * textmodes/sgml-mode.el (sgml-xml-guess): Add .xhtml extension.
+
+2010-12-11 Karel Klíč <kklic@redhat.com>
+
+ * files.el (auto-mode-alist): Use html-mode for *.xhtml. (Bug#7606)
+
+2010-12-10 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Derive from prog-mode, use derived-mode-p, and fix up various
+ minor style issues in lisp/progmodes.
+
+ * progmodes/vhdl-mode.el (vhdl-mode):
+ * progmodes/verilog-mode.el (verilog-mode):
+ * progmodes/vera-mode.el (vera-mode):
+ * progmodes/sql.el (sql-mode):
+ * progmodes/scheme.el (scheme-mode):
+ * progmodes/perl-mode.el (perl-mode):
+ * progmodes/octave-inf.el (inferior-octave-mode):
+ * progmodes/autoconf.el (autoconf-mode):
+ * progmodes/m4-mode.el (m4-mode):
+ * progmodes/inf-lisp.el (inferior-lisp-mode):
+ * progmodes/idlwave.el (idlwave-mode):
+ * progmodes/icon.el (icon-mode):
+ * progmodes/idlw-help.el (idlwave-help-mode):
+ * progmodes/dcl-mode.el (dcl-mode):
+ * progmodes/idlw-shell.el (idlwave-shell-mode):
+ * progmodes/ebrowse.el (ebrowse-tree-mode, ebrowse-electric-list-mode)
+ (ebrowse-member-mode, ebrowse-electric-position-mode):
+ Use define-derived-mode.
+
+ * progmodes/xscheme.el (exit-scheme-interaction-mode)
+ (xscheme-enter-interaction-mode, xscheme-enter-debugger-mode)
+ (xscheme-debugger-mode-p, xscheme-send-string-1):
+ * progmodes/tcl.el (inferior-tcl-proc, tcl-current-word)
+ (tcl-load-file, tcl-restart-with-file):
+ * progmodes/ps-mode.el (ps-run-running):
+ * progmodes/gdb-mi.el (gud-watch, gdb-mouse-set-clear-breakpoint):
+ * progmodes/js.el (js--get-all-known-symbols):
+ * progmodes/inf-lisp.el (inferior-lisp-proc):
+ * progmodes/idlwave.el (idlwave-beginning-of-statement)
+ (idlwave-template, idlwave-update-buffer-routine-info)
+ (idlwave-update-current-buffer-info)
+ (idlwave-get-routine-info-from-buffers, idlwave-choose)
+ (idlwave-scan-class-info, idlwave-fix-keywords)
+ (idlwave-list-buffer-load-path-shadows):
+ * progmodes/idlw-toolbar.el (idlwave-toolbar, idlwave-toolbar-add)
+ (idlwave-toolbar-remove):
+ * progmodes/idlw-shell.el (idlwave-shell-save-and-action)
+ (idlwave-shell-file-name, idlwave-shell-electric-debug-all-off)
+ (idlwave-shell-menu-def):
+ * progmodes/idlw-complete-structtag.el
+ (idlwave-prepare-structure-tag-completion):
+ * progmodes/gud.el (gud-set-buffer):
+ * progmodes/f90.el (f90-backslash-not-special):
+ * progmodes/delphi.el (delphi-find-unit): Use derived-mode-p.
+
+ * progmodes/xscheme.el (xscheme-start)
+ (local-set-scheme-interaction-buffer, scheme-interaction-mode):
+ * progmodes/which-func.el (which-function):
+ * progmodes/vhdl-mode.el (vhdl-set-style):
+ * progmodes/verilog-mode.el (verilog-set-compile-command)
+ (verilog-modify-compile-command, verilog-error-regexp-add-xemacs)
+ (verilog-set-define, verilog-auto-reeval-locals):
+ * progmodes/sql.el (sql-product-font-lock, sql-interactive-mode):
+ * progmodes/simula.el (simula-mode):
+ * progmodes/scheme.el (scheme-mode-variables, dsssl-mode):
+ * progmodes/python.el (python-check, python-mode):
+ * progmodes/prolog.el (prolog-mode-variables):
+ * progmodes/gud.el (gud-tooltip-activate-mouse-motions):
+ * progmodes/ebrowse.el (ebrowse-view-file-other-frame):
+ * progmodes/delphi.el (delphi-mode):
+ * progmodes/cc-styles.el (c-setup-paragraph-variables):
+ * progmodes/cc-mode.el (c-basic-common-init, c-common-init)
+ (c-font-lock-init): Move make-local-variable to their setq.
+
+ * progmodes/vhdl-mode.el (vhdl-write-file-hooks-init)
+ (vhdl-hs-minor-mode, vhdl-ps-print-init): Fix make-local-variable ->
+ make-local-hook.
+ * progmodes/sh-script.el (sh-require-final-newline): Remove.
+ (sh-set-shell): Don't set require-final-newline since it's already done
+ by prog-mode.
+ * progmodes/modula2.el (m2-mode): Don't make m2-end-comment-column
+ since we never set it.
+ * progmodes/ebrowse.el (ebrowse-set-tree-indentation):
+ Use read-string and standard prompt.
+ * progmodes/dcl-mode.el (dcl-mode-map): Move init into declaration.
+ * progmodes/meta-mode.el (meta-mode-abbrev-table): Merge init and decl.
+ (meta-common-mode-syntax-table): Rename from meta-mode-syntax-table.
+ (meta-common-mode-map): Rename from meta-mode-map.
+ Remove C-m binding, which is a user preference, not mode specific.
+ (meta-common-mode): New major mode; replace meta-common-initialization.
+ * progmodes/js.el (js-mode): Call syntax-propertize rather than messing
+ around with font-lock.
+ * progmodes/etags.el (select-tags-table-mode):
+ Derive from special-mode.
+ * progmodes/octave-mod.el (octave-mode):
+ * progmodes/gdb-mi.el (gdb-inferior-io-mode, gdb-threads-mode)
+ (gdb-memory-mode, gdb-disassembly-mode, gdb-breakpoints-mode)
+ (gdb-frames-mode, gdb-locals-mode, gdb-registers-mode):
+ Let define-derived-mode do its job.
+ * progmodes/cpp.el (cpp-edit-mode-map):
+ Move initialization into declaration.
+ (cpp-edit-mode): Use define-derived-mode.
+ (cpp-edit-load): Use derived-mode-p.
+ * progmodes/mixal-mode.el (mixal-mode):
+ * progmodes/f90.el (f90-mode):
+ * progmodes/cfengine.el (cfengine-mode): Don't bother setting
+ require-final-newline since prog-mode does it already.
+ * progmodes/cc-cmds.el (c-update-modeline): Use match-string.
+ * progmodes/asm-mode.el (asm-mode-map): Fix menu setup.
+ * progmodes/antlr-mode.el: Require cc-mode upfront.
+ (antlr-mode-syntax-table, antlr-action-syntax-table): Initialize in
+ the declaration.
+ (antlr-directory-dependencies, antlr-show-makefile-rules):
+ Use derived-mode-p.
+ (antlr-language-option): Don't assume point-min==1.
+ (antlr-mode): Use define-derived-mode.
+ * progmodes/ada-mode.el: Use derived-mode-p.
+ (ada-mode): Use define-derived-mode.
+ Use hack-local-variables-hook.
+
+2010-12-10 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * textmodes/texinfo.el (texinfo-mode-map): Bind texinfo-insert-@end.
+ (texinfo-mode): Don't disable adaptive-fill-mode.
+ (texinfo-insert-block): Adjust cursor placement for blocks with arg.
+ (texinfo-insert-@end, texinfo-insert-braces, texinfo-insert-@code)
+ (texinfo-insert-@dfn, texinfo-insert-@email, texinfo-insert-@emph)
+ (texinfo-insert-@example, texinfo-insert-@file, texinfo-insert-@item)
+ (texinfo-insert-@kbd, texinfo-insert-@node, texinfo-insert-@noindent)
+ (texinfo-insert-@quotation, texinfo-insert-@samp)
+ (texinfo-insert-@strong, texinfo-insert-@table, texinfo-insert-@var)
+ (texinfo-insert-@uref): Use define-skeleton.
+ (texinfo-insert-@-with-arg): Delete.
+
+2010-12-10 Eli Zaretskii <eliz@gnu.org>
+
+ * arc-mode.el (archive-zip-extract): If w32-quote-process-args is
+ nil, do quote archive member names. (Bug#6144)
+
+2010-12-10 Glenn Morris <rgm@gnu.org>
+
+ * files.el (diff-no-select): Declare.
+
+ * mail/emacsbug.el (report-emacs-bug): Use mail-user-agent properties.
+ (report-emacs-bug-create-existing-bugs-buffer): Avoid free variables.
+
+ * comint.el (comint-input-ring-file-name): Doc fix.
+
+2010-12-09 Eli Zaretskii <eliz@gnu.org>
+
+ * menu-bar.el (menu-bar-frame-for-menubar, menu-bar-positive-p):
+ New functions.
+ (menu-bar-showhide-menu) <menu-bar-mode, showhide-tool-bar>:
+ Use them instead of `nil' and `>', respectively.
+ (menu-bar-showhide-tool-bar-menu): Use menu-bar-frame-for-menubar
+ instead of `nil'.
+ (toggle-menu-bar-mode-from-frame): Use menu-bar-frame-for-menubar
+ and menu-bar-positive-p instead of `nil' and `>', respectively.
+ (Bug#1077)
+
+2010-12-09 Vinicius Jose Latorre <viniciusjl@ig.com.br>
+
+ * whitespace.el (whitespace-newline-mode): Code fix.
+
+2010-12-09 Glenn Morris <rgm@gnu.org>
+
+ * play/landmark.el (lm-print-y,s,noise-int, lm-print-y,s,noise):
+ Rename functions without commas, update callers.
+
+2010-12-08 Jeff Dairiki <dairiki@dairiki.org> (tiny change)
+
+ * whitespace.el (whitespace-cleanup-region):
+ Clean up spaces before tabs. (Bug#7582)
+
+2010-12-08 Karl Fogel <kfogel@red-bean.com>
+
+ * bookmark.el: Adjust parameter names and doc strings to resolve
+ confusion over whether "bookmark" meant a bookmark name or a
+ bookmark record. Along the way, shorten one function's name for
+ similar reasons. (Issue #7548)
+ (bookmark-name-from-record): New name for
+ `bookmark-name-from-full-record'. All callers changed.
+ (bookmark-get-bookmark, bookmark-get-bookmark-record)
+ (bookmark-default-annotation-text, bookmark-prop-get, bookmark-prop-set)
+ (bookmark-get-annotation, bookmark-set-annotation)
+ (bookmark-get-filename, bookmark-set-filename)
+ (bookmark-get-position, bookmark-set-position)
+ (bookmark-get-front-context-string, bookmark-set-front-context-string)
+ (bookmark-get-rear-context-string, bookmark-set-rear-context-string)
+ (bookmark-get-handler, bookmark-edit-annotation, bookmark--jump-via)
+ (bookmark-handle-bookmark, bookmark-location, bookmark-show-annotation):
+ Rename `bookmark' parameter to `bookmark-name-or-record', to
+ clearly show its role, and shorten or adjust doc strings accordingly.
+ (bookmark-set-name): Same, and pass the parameter directly to
+ `bookmark-get-bookmark' instead of redundantly doing the callee's work.
+ (bookmark-default-annotation-text, bookmark-send-edited-annotation)
+ (bookmark-relocate, bookmark-insert-location, bookmark-insert)
+ (bookmark-delete): Rename `bookmark' parameter to `bookmark-name',
+ and in some cases shorten doc string accordingly.
+ (bookmark-rename): Change `old' and `new' parameters to `old-name'
+ and `new-name', and adjust an internal variable to avoid confusion.
+ (bookmark-jump, bookmark-jump-noselect): Clarify `bookmark'
+ parameter in doc string.
+
+2010-12-08 Glenn Morris <rgm@gnu.org>
+
+ * progmodes/gdb-mi.el (gdb): Try to initialize comint input history
+ from gdb's history file. (Bug#7575)
+
+ * mail/emacsbug.el (report-emacs-bug):
+ Try to handle some other mail clients.
+
+2010-12-08 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * files.el (dir-locals-collect-variables): Don't let errors stop us.
+ Use string-prefix-p.
+ (file-name-version-regexp): New var.
+ (file-name-sans-versions):
+ * jka-cmpr-hook.el (jka-compr-build-file-regexp): Use it,
+ (jka-compr-get-compression-info): Use dolist.
+ (jka-compr-compression-info-list): Don't bother specifying
+ version/backup regexps.
+
+2010-12-07 Tassilo Horn <tassilo@member.fsf.org>
+
+ * simple.el (just-one-space): Make argument n default to 1 if
+ omitted.
+
+2010-12-07 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * electric.el (electric-indent-post-self-insert-function):
+ Delete trailing newlines even if we don't reindent.
+
+2010-12-06 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * minibuffer.el (completion-at-point): Remove the `arg'.
+ * bindings.el (complete-symbol): Move back from minibuffer.el.
+
+2010-12-06 Deniz Dogan <deniz.a.m.dogan@gmail.com>
+
+ * simple.el (just-one-space): Delete newlines for negative arg.
+
+2010-12-06 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * ansi-color.el (ansi-color-unfontify-region): Replace by trivial def.
+ (ansi-color-filter-apply): Simplify.
+ (ansi-color-apply): Use `font-lock-face' rather than `face'.
+
+2010-12-05 Bob Rogers <rogers-emacs@rgrjr.dyndns.org>
+
+ * vc/vc-dir.el (vc-dir-query-replace-regexp): Doc fix (Bug#7501).
+
+2010-12-04 Chong Yidong <cyd@stupidchicken.com>
+
+ * dired.el (dired-use-ls-dired): Set default to a special
+ "unspecified" value.
+ (dired-insert-directory): When called the first time, check
+ whether "ls --dired" succeeds and set dired-use-ls-dired (Bug#7546).
+
+2010-12-04 Tak Ota <Takaaki.Ota@am.sony.com>
+
+ * replace.el: Add "collect" feature to occur.
+ (occur-collect-regexp-history): New var.
+ (occur-read-primary-args): Return a replace string for nlines,
+ if needed.
+ (occur): Extend the meaning of nlines.
+
+2010-12-04 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/which-func.el (which-func-ff-hook): Log the error message.
+ (which-func-update-1): Distinguish symbols from strings.
+ (which-function): Stay within 80 columns.
+
+2010-12-03 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * subr.el (with-demoted-errors): Distinguish symbols from strings.
+
+ * newcomment.el (comment-styles): Add docs to each style (bug#7509).
+ Improve docstring.
+ (comment-style): Use comment-styles's docs to describe values.
+
+2010-12-03 Jan Djärv <jan.h.d@swipnet.se>
+
+ * term/common-win.el (x-setup-function-keys): Restore ns-new-frame
+ and ns-show-prefs (Bug#7535).
+
+ * term/ns-win.el (global-map): Restore ns-new-frame and ns-show-prefs
+ bindings (Bug#7535).
+
+2010-12-03 Glenn Morris <rgm@gnu.org>
+
+ * nxml/nxml-mode.el: Require rng-nxml.
+ (rng-nxml-mode-init, nxml-enable-unicode-char-name-sets):
+ Remove declarations.
+
+ * nxml/nxml-mode.el, nxml/nxml-outln.el, nxml/rng-loc.el:
+ * nxml/rng-nxml.el, nxml/rng-valid.el:
+ Remove leading `*' from defcustom docs.
+
+ * startup.el (normal-top-level-add-subdirs-to-load-path): Simplify.
+ (normal-top-level-add-to-load-path, tty-handle-args):
+ Convert comments to basic doc-strings.
+
+ * net/browse-url.el (browse-url-url-at-point)
+ (browse-url-default-browser): Remove autoload cookies.
+
+ * mail/emacsbug.el (report-emacs-bug-create-existing-bugs-buffer):
+ Remove more undefined cl functions.
+
+ * vc/diff.el (diff-sentinel): Make new arguments optional.
+ * ibuf-ext.el (diff-sentinel): Update declaration.
+
+2010-12-03 Daiki Ueno <ueno@unixuser.org>
+
+ * epg.el (epg-digest-algorithm-alist): Replace "RMD160" with
+ "RIPEMD160" (Bug#7490). Reported by Daniel Kahn Gillmor.
+ (epg-context-set-passphrase-callback): Mention that the callback
+ is not called when used with GnuPG 2.x.
+
+2010-12-02 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-local-host-regexp): Add "localhost6".
+ (tramp-file-name-port): Check also for `tramp-default-port'.
+ (tramp-get-connection-name): New defun.
+ (tramp-get-connection-process): Use it.
+ (tramp-debug-message): Extend function exclude list.
+ (tramp-drop-volume-letter): Fix doc string.
+
+ * net/tramp-cmds.el: Remove solved todo item.
+
+ * net/tramp-ftp.el:
+ * net/tramp-gvfs.el:
+ * net/tramp-gw.el:
+ * net/tramp-imap.el:
+ * net/tramp-smb.el: Fix regexps added to `tramp-default-method-alist'
+ and `tramp-default-user-alist', respectively.
+
+ * net/tramp-gw.el (tramp-gw-open-connection):
+ Use `tramp-get-connection-name' and `tramp-get-connection-buffer'.
+
+ * net/tramp-imap.el (tramp-imap-make-iht): Use just
+ `tramp-file-name-port'.
+
+ * net/tramp-sh.el (tramp-methods): Add recursive options to "pscp"
+ and "psftp". Exchange "%k" marker with options.
+ (tramp-do-copy-or-rename-file, tramp-sh-handle-file-local-copy):
+ Compute size of link target.
+ (tramp-do-copy-or-rename-file-out-of-band): Move setting of
+ `tramp-current-*' up due to gateway methods. Optimize computing of
+ copy arguments. Use `tramp-get-connection-name' and
+ `tramp-get-connection-buffer'. Improve debug messages.
+ (tramp-compute-multi-hops): Remove port determination.
+ (tramp-maybe-open-connection): Use `tramp-get-connection-name'.
+
+ * net/trampver.el: Update release number.
+
+2010-12-02 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/cl-macs.el (cl-parse-loop-clause):
+ Avoid infinite loop over windows. (Bug#7492)
+
+ * progmodes/flymake.el (flymake-check-file-limit):
+ Allow nil to mean "no limit".
+ (flymake-check-patch-master-file-buffer): Update for above change.
+ Allow a .tex file-name extension to be optional.
+ (flymake-master-tex-init): Also match \include statements.
+
+2010-11-30 Sam Steingold <sds@gnu.org>
+
+ * nxml/nxml-mode.el (nxml-parent-document): Add a variable.
+ (nxml-parent-document-set): A function to set `nxml-parent-document'.
+ (nxml-mode): Define using `define-derived-mode' instead of `defun'.
+ (nxml-mode-hook): Remove `defcustom' (auto-defined by
+ define-derived-mode').
+ * nxml/rng-valid.el (rng-dtd-trivial-p): Add a helper function for
+ users who want to call `nxml-parent-document-set'.
+
+2010-11-27 Chong Yidong <cyd@stupidchicken.com>
+
+ * log-edit.el (log-edit-font-lock-keywords): Don't try matching
+ stand-alone lines, since that is handled by log-edit-match-to-eoh
+ (Bug#6465).
+
+2010-11-27 Eduard Wiebe <usenet@pusto.de>
+
+ * dired.el (dired-get-filename): Replace backslashes with slashes
+ in file names on MS-Windows, needed by `locate'. (Bug#7308)
+ * locate.el (locate-default-make-command-line): Don't consider
+ drive letter and root directory part of
+ `directory-listing-before-filename-regexp'. (Bug#7308)
+ (locate-post-command-hook, locate-post-command-hook): New defcustoms.
+
+2010-11-27 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/smie.el (smie-prec2->grammar): Simplify handling
+ of :smie-open/close-alist.
+ (smie-next-sexp): Make it accept a "start token" as argument.
+ (smie-indent-keyword): Be careful not to misidentify tokens that span
+ more than one line, as empty lines. Add argument `token'.
+
+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-27 Kenichi Handa <handa@m17n.org>
+
+ * mail/rmailmm.el (rmail-mime-entity, rmail-mime-entity-type)
+ (rmail-mime-entity-disposition)
+ (rmail-mime-entity-transfer-encoding, rmail-mime-entity-header)
+ (rmail-mime-entity-body, rmail-mime-entity-children): New functions.
+ (rmail-mime-save): Handle the case that the button's `data' is a
+ MIME entity.
+ (rmail-mime-insert-text): New function.
+ (rmail-mime-insert-image): Handle the case that DATA is a MIME entity.
+ (rmail-mime-bulk-handler): Just call rmail-mime-insert-bulk.
+ (rmail-mime-insert-bulk): New function mostly copied from the old
+ rmail-mime-bulk-handler.
+ (rmail-mime-multipart-handler): Just call rmail-mime-process-multipart.
+ (rmail-mime-process-multipart): New function mostly copied from
+ the old rmail-mime-multipart-handler.
+ (rmail-mime-show): Just call rmail-mime-process.
+ (rmail-mime-process): New function mostly copied from the old
+ rmail-mime-show.
+ (rmail-mime-insert-multipart, rmail-mime-parse)
+ (rmail-mime-insert, rmail-show-mime)
+ (rmail-insert-mime-forwarded-message)
+ (rmail-insert-mime-resent-message): New functions.
+ (rmail-insert-mime-forwarded-message-function): Set to
+ rmail-insert-mime-forwarded-message.
+ (rmail-insert-mime-resent-message-function): Set to
+ rmail-insert-mime-resent-message.
+
+ * mail/rmailsum.el: Require rfc2047.
+ (rmail-header-summary): Handle multiline Subject: field.
+ (rmail-summary-line-decoder): Change the default to
+ rfc2047-decode-string.
+
+ * mail/rmail.el (rmail-enable-mime): Change the default to t.
+ (rmail-mime-feature): Change the default to `rmailmm'.
+ (rmail-quit): Delete the specifal code for rmail-enable-mime.
+ (rmail-display-labels): Likewise.
+ (rmail-show-message-1): Check rmail-enable-mime, and use
+ rmail-show-mime-function for a MIME message. Decode the headers
+ according to RFC2047.
+
+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-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-27 Chong Yidong <cyd@stupidchicken.com>
+
+ * 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-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-27 Chong Yidong <cyd@stupidchicken.com>
+
+ * lpr.el (lpr-buffer, print-buffer, lpr-region, print-region):
+ Prompt user before actually printing.
+
+2010-11-27 Glenn Morris <rgm@gnu.org>
+
+ * startup.el (package-enable-at-startup, package-initialize):
+ Remove unnecessary declarations.
+
+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 Jose E. Marchesi <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-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.
+ (smie-grammar): Loosen definition of valid values.
+ (smie-next-sexp, smie-down-list, smie-blink-matching-open)
+ (smie-indent--parent, smie-rule-parent, smie-indent-keyword)
+ (smie-indent-after-keyword): Adjust users.
+ (smie-indent-keyword): Don't indent empty lines.
+
+ * vc-hg.el (vc-hg-program): New var.
+ Suggested by Norman Gray <norman@astro.gla.ac.uk>.
+ (vc-hg-state, vc-hg-working-revision, vc-hg-command): Use it.
+
+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-18 Ulrich Mueller <ulm@gentoo.org>
+
+ * server.el (server-force-stop): Ensure the server is stopped (Bug#7409).
+
+2010-11-18 Eli Zaretskii <eliz@gnu.org>
+
+ * subr.el (posn-col-row): Pay attention to header line. (Bug#7390)
+
+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-18 Glenn Morris <rgm@gnu.org>
+
+ * novice.el (disabled-command-function):
+ Fix 2009-11-15 change. (Bug#7384)
+
+2010-11-18 Glenn Morris <rgm@gnu.org>
+
+ * calendar/calendar.el (diary-iso-date-forms): Make elements
+ mutually exclusive. (Bug#7377)
+
+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-18 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/bytecomp.el (byte-compile-warnings): Simplify the
+ safety predicate.
+
+ * files.el (safe-local-variable-p): Gracefully handle errors.
+
+ * emacs-lisp/smie.el (smie-rule-parent, smie-indent--rule):
+ Use smie-indent-virtual when indenting relative to an opener.
+ (smie-rule-separator): Use smie-rule-parent.
+ (smie-indent-keyword): Consult rules, even for openers at bol.
+ (smie-indent-comment-close): Try to align closer's content.
+
+2010-11-18 Glenn Morris <rgm@gnu.org>
+
+ * ls-lisp.el (ls-lisp-dired-ignore-case): Make it an obsolete alias.
+
+2010-11-18 Glenn Morris <rgm@gnu.org>
+
+ * printing.el (pr-menu-bind): Doc fix.
+
+ * speedbar.el (speedbar-toggle-images): Doc fix.
+
+ * progmodes/python.el (python-shell): Doc fix.
+
+ * 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):
+ Rename 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-09 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * minibuffer.el (minibuffer-completion-help): Specify the end of the
+ completion field (bug#7211).
+
+ * progmodes/python.el (python-font-lock-syntactic-keywords): (bug#7322)
+ Fix handling of backslash escapes.
+ (python-quote-syntax): Adjust accordingly.
+
+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-09 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * international/mule-cmds.el (princ-list): Mark as obsolete.
+
+2010-11-09 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/smie.el: New package.
+
+2010-11-09 Michael Albinus <michael.albinus@gmx.de>
+
+ * files.el (backup-by-copying-when-mismatch):
+ Set `permanent-local' property.
+
+ * net/tramp.el (tramp-handle-insert-file-contents): Do not set
+ `permanent-local' property for `backup-by-copying-when-mismatch'.
+
+2010-11-09 Eli Zaretskii <eliz@gnu.org>
+
+ * ls-lisp.el (insert-directory): Doc fix. (bug#7285)
+
+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
+ AUTOINOUT for SV style multidimensional arrays, bug294.
+ Reported by Eric Mastromarchi.
+ (verilog-preprocess): Use with-current-buffer and
+ font-lock-fontify-buffer to cleanup style issues.
+
+2010-11-09 Glenn Morris <rgm@gnu.org>
+
+ * locate.el (locate, locate-mode): Doc fixes.
+
+2010-11-09 Chong Yidong <cyd@stupidchicken.com>
+
+ * server.el (server-start): New arg INHIBIT-PROMPT prevents asking
+ user for confirmation.
+ (server-force-stop): Use it.
+ (server-start): Use server-force-stop for kill-emacs-hook, to
+ avoid user interaction while killing Emacs.
+
+2010-11-09 Glenn Morris <rgm@gnu.org>
+
+ * 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-11-08 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * 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.
+
+ * 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).
+
+2010-11-07 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * 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-11-03 Glenn Morris <rgm@gnu.org>
+
+ * progmodes/idlwave.el (idlwave-pset): Only used on XEmacs.
+ (props): Remove unnecessary declaration.
+
+ * textmodes/ispell.el (ispell-init-process): On Emacs, always use
+ set-process-query-on-exit-flag.
+
+ * 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.
+
+ * net/dbus.el (dbus-name-owner-changed-handler): Doc fix.
+
+ * 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.
+
+ * 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>
+
+ * 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.
+
+2010-11-03 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/perl-mode.el (perl-syntax-propertize-function):
+ Handle __DATA__ and __END__.
+
+2010-11-02 Noah Friedman <friedman@splode.com>
+
+ * 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-11-02 Chong Yidong <cyd@stupidchicken.com>
+
+ * 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-11-01 Vinicius Jose Latorre <viniciusjl@ig.com.br>
+
+ * subr.el (version-separator, version-regexp-alist): Remove '*'
+ from docstring.
+ (version-list-<=, version<=, version=): Doc fix.
+
+2010-11-01 Kenichi Handa <handa@m17n.org>
+
+ * faces.el (glyphless-char): Inherit underline for tty.
+
+2010-11-01 Kenichi Handa <handa@m17n.org>
+
+ Implement various display methods for glyphless characters.
+
+ * international/characters.el (char-acronym-table): New variable.
+ (glyphless-char-control): New variable.
+ (update-glyphless-char-display): New function.
+
+ * faces.el (glyphless-char): New face.
+
+2010-11-01 Glenn Morris <rgm@gnu.org>
+
+ * 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.
+
+ * emacs-lisp/smie.el (smie): New custom group.
+ (smie-blink-matching-inners, smie-indent-basic): Add :group.
+
+ * faces.el (xw-defined-colors, x-setup-function-keys):
+ * mouse-sel.el (x-select-text):
+ * term/w32console.el (x-setup-function-keys): Update declarations.
+
+ * progmodes/ruby-mode.el (ruby-syntax-propertize-heredoc): Declare.
+
+ * textmodes/ispell.el (comment-add): Declare.
+
+ * net/gnutls.el (gnutls-boot, gnutls-errorp, gnutls-error-string):
+ Declare.
+
+ * info.el (finder-keywords-hash, package-alist): Declare.
+
+2010-11-01 Chong Yidong <cyd@stupidchicken.com>
+
+ * finder.el (finder-compile-keywords): Don't use intern-soft,
+ since package names may not yet exist in the obarray.
+
+2010-11-01 Chong Yidong <cyd@stupidchicken.com>
+
+ * 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.
+
+2010-11-01 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/bytecomp.el (byte-recompile-file): Fix previous change.
+
+ * startup.el (package-enable-at-startup, package-initialize):
+ Silence compiler.
+
+ * progmodes/ada-mode.el (ada-font-lock-syntactic-keywords):
+ Silence compiler.
+
+2010-10-31 Julien Danjou <julien@danjou.info>
+
+ * 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'.
+
+2010-10-31 Glenn Morris <rgm@gnu.org>
+
+ * 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.
+
+2010-10-31 Jan Djärv <jan.h.d@swipnet.se>
+
+ * 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-31 Glenn Morris <rgm@gnu.org>
+
+ * speedbar.el (speedbar-mode):
+ * play/fortune.el (fortune-in-buffer, fortune):
+ * play/gomoku.el (gomoku-mode):
+ * play/landmark.el (lm-mode):
+ * textmodes/bibtex.el (bibtex-validate, bibtex-validate-globally):
+ Replace inappropriate uses of toggle-read-only. (Bug#7292)
+
+ * select.el (x-selection): Mark it as an obsolete alias.
+
+2010-10-31 Aaron S. Hawley <aaron.s.hawley@gmail.com>
+
+ * vc/add-log.el (find-change-log): Use derived-mode-p rather than
+ major-mode (bug#7284).
+
+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-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>
+
+ * progmodes/verilog-mode.el (verilog-directive-re): Make this variable
+ auto-built for efficiency of execution and updating.
+ (verilog-extended-complete-re): Support 'pure' fucntion & task
+ declarations (these have no bodies).
+ (verilog-beg-of-statement): General cleanup to enable support of
+ 'pure' fucntion & task declarations (these have no bodies).
+ These efforts together fix Verilog bug210 from veripool; which was also
+ noticed by Steve Pearlmutter.
+ (verilog-directive-re, verilog-directive-begin, verilog-indent-re)
+ (verilog-directive-nest-re, verilog-set-auto-endcomments):
+ Support `elsif. Reported by Shankar Giri.
+ (verilog-forward-ws&directives, verilog-in-attribute-p): Fixes for
+ attribute handling for lining up declarations and assignments.
+ (verilog-beg-of-statement-1): Fix issue where continued declaration
+ is indented differently if it is after a begin..end clock.
+ (verilog-in-attribute-p, verilog-skip-backward-comments)
+ (verilog-skip-forward-comment-p): Support proper treatment of
+ attributes by indent code. Reported by Jeff Steele.
+ (verilog-in-directive-p): Fix comment to correctly describe function.
+ (verilog-backward-up-list, verilog-in-struct-region-p)
+ (verilog-backward-token, verilog-in-struct-p)
+ (verilog-in-coverage-p, verilog-do-indent)
+ (verilog-pretty-declarations): Use verilog-backward-up-list as
+ wrapper around backward-up-list inorder to properly skip comments.
+ Reported by David Rogoff.
+ (verilog-property-re, verilog-endcomment-reason-re)
+ (verilog-beg-of-statement, verilog-set-auto-endcomments)
+ (verilog-calc-1 ): Fix for assert a; else b; indentation (new form
+ of if). Reported by Max Bjurling and
+ (verilog-calc-1): Fix for clocking block in modport
+ declaration. Reported by Brian Hunter.
+
+2010-10-24 Wilson Snyder <wsnyder@wsnyder.org>
+
+ * progmodes/verilog-mode.el (verilog-auto-inst, verilog-gate-ios)
+ (verilog-gate-keywords, verilog-read-sub-decls)
+ (verilog-read-sub-decls-gate, verilog-read-sub-decls-gate-ios)
+ (verilog-read-sub-decls-line, verilog-read-sub-decls-sig): Support
+ AUTOINST for gate primitives, bug284. Reported by Mark Johnson.
+ (verilog-read-decls): Fix spaces in V2K module parameters causing
+ mis-identification as interfaces, bug287.
+ (verilog-read-decls): Fix not treating "parameter string" as a
+ parameter in AUTOINSTPARAM.
+ (verilog-read-always-signals-recurse, verilog-read-decls): Fix not
+ treating `elsif similar to `endif inside AUTOSENSE.
+ (verilog-do-indent): Implement correct automatic or static task or
+ function end comment highlight. Reported by Steve Pearlmutter.
+ (verilog-font-lock-keywords-2): Fix highlighting of single
+ character pins, bug264. Reported by Michael Laajanen.
+ (verilog-auto-inst, verilog-read-decls, verilog-read-sub-decls)
+ (verilog-read-sub-decls-in-interfaced, verilog-read-sub-decls-sig)
+ (verilog-subdecls-get-interfaced, verilog-subdecls-new):
+ Support interfaces with AUTOINST, bug270. Reported by Luis Gutierrez.
+ (verilog-pretty-expr): Fix interactive arguments, bug272.
+ Reported by Mark Johnson.
+ (verilog-auto-tieoff, verilog-auto-tieoff-ignore-regexp):
+ Add 'verilog-auto-tieoff-ignore-regexp' for AUTOTIEOFF,
+ bug269. Suggested by Gary Delp.
+ (verilog-mode-map, verilog-preprocess, verilog-preprocess-history)
+ (verilog-preprocessor, verilog-set-compile-command):
+ Create verilog-preprocess and verilog-preprocessor to show
+ preprocessed output.
+ (verilog-get-beg-of-line, verilog-get-end-of-line)
+ (verilog-modi-file-or-buffer, verilog-modi-name)
+ (verilog-modi-point, verilog-within-string): Move defmacro's
+ before first use to avoid warning. Reported by Steve Pearlmutter.
+ (verilog-colorize-buffer, verilog-colorize-include-files-buffer)
+ (verilog-colorize-region, verilog-highlight-buffer)
+ (verilog-highlight-includes, verilog-highlight-modules)
+ (verilog-highlight-region, verilog-mode): Rename colorize to
+ highlight to match other packages. Disable module highlighting,
+ as received speed complaints, reenable for experimentation only
+ using new verilog-highlight-modules.
+ (verilog-read-decls): Fix regexp stack overflow in very large
+ AUTO_TEMPLATEs, bug250.
+ (verilog-auto, verilog-delete-auto, verilog-save-buffer-state)
+ (verilog-scan): Create verilog-save-buffer-state to standardize
+ making insignificant changes that shouldn't call hooks.
+ (verilog-save-no-change-functions, verilog-save-scan-cache)
+ (verilog-scan, verilog-scan-cache-ok-p, verilog-scan-region):
+ Create verilog-save-no-change-functions to wrap verilog-scan
+ preservation, and fix to work with nested preserved calls.
+ (verilog-auto-inst, verilog-auto-inst-dot-name): Support .name
+ port syntax for AUTOWIRE, and with new verilog-auto-inst-dot-name
+ generate .name with AUTOINST, bug245. Suggested by David Rogoff.
+ (verilog-submit-bug-report): Update variable list to be complete.
+ (verilog-auto, verilog-colorize-region): Fix AUTO expansion
+ breaking on-the-fly font-locking.
+ (verilog-colorize-buffer, verilog-colorize-include-files)
+ (verilog-colorize-include-files-buffer, verilog-colorize-region)
+ (verilog-load-file-at-mouse, verilog-load-file-at-point)
+ (verilog-mode, verilog-read-inst-module-matcher): With point on a
+ AUTOINST cell instance name, middle mouse button now finds-file on
+ it. Suggested by Brad Dobbie.
+ (verilog-alw-get-temps, verilog-auto-reset)
+ (verilog-auto-sense-sigs, verilog-read-always-signals)
+ (verilog-read-always-signals-recurse): Fix loop indexes being
+ AUTORESET. AUTORESET now assumes any variables in the
+ initialization section of a for() should be ignored.
+ Reported by Dan Dever.
+ (verilog-error-font-lock-keywords)
+ (verilog-error-regexp-emacs-alist)
+ (verilog-error-regexp-xemacs-alist): Fix error detection of
+ Cadence HAL, reported by David Asher. Repair drift between the
+ three similar error variables.
+ (verilog-modi-lookup, verilog-modi-lookup-cache)
+ (verilog-modi-lookup-last-current, verilog-modi-lookup-last-mod)
+ (verilog-modi-lookup-last-modi, verilog-modi-lookup-last-tick):
+ Fix slow verilog-auto expansion on very large files.
+ (verilog-read-sub-decls-expr, verilog-read-sub-decls-line):
+ Fix AUTOOUTPUT treating "1*2" as a signal name in submodule connection
+ "{1*2{...". Broke in last revision.
+ (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>
+
+ * textmodes/flyspell.el (flyspell-mode): If there was an error,
+ say what it was.
+
+ * frame.el (auto-hscroll-mode, cursor-in-non-selected-windows):
+ Sync docs with C version.
+
+ * 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-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.
+
+2010-10-21 Daiki Ueno <ueno@unixuser.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.
+
+2010-10-19 Alan Mackenzie <acm@muc.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.
+
+ * 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-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-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-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-sh.el (tramp-open-connection-setup-interactive-shell):
+ Suppress expansion of tabs to spaces. Reported by Dale Sedivec
+ <dale@codefu.org>.
+
+2010-10-14 Kenichi Handa <handa@m17n.org>
+
+ * mail/rmail.el (rmail-show-message-1): Catch an error of
+ base64-decode-region and just show an error message (bug#7165).
+
+ * ps-mule.el (ps-mule-font-spec-list): Delete it. Not used anymore.
+ (ps-mule-begin-job): Fix for the case that only ENCODING is set in
+ a font-spec (bug#7197).
+
+2010-10-14 Glenn Morris <rgm@gnu.org>
+
+ * mail/emacsbug.el (report-emacs-bug): Mention debbugs.gnu.org.
+
+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-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.
+ (mac-right-option-modifier): New alias for ns-right-option-modifier.
+
+ * cus-start.el (all): ns-right-alternate-modifier is new.
+
+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-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.
+ Remove hi-lock-mode off code. Remove inhibit hack.
+ (hi-lock-set-pattern): Only add keywords if font-lock-fontified
+ non-nil; removed hook inhibit hack.
+
+2010-10-12 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/shadow.el (find-emacs-lisp-shadows): Rename it...
+ (load-path-shadows-find): ... to this.
+ (list-load-path-shadows): Update for above change.
+
+ * 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/.
+
+ * emacs-lisp/shadow.el (lisp-shadow): Change prefix.
+ (shadows-compare-text-p): Make it an obsolete alias for...
+ (load-path-shadows-compare-text): ... new name.
+ (find-emacs-lisp-shadows): Update for above name change.
+ (load-path-shadows-same-file-or-nonexistent): New name for the old
+ shadow-same-file-or-nonexistent.
+
+2010-10-08 Chong Yidong <cyd@stupidchicken.com>
+
+ * minibuffer.el (completion--some, completion--do-completion)
+ (minibuffer-complete-and-exit, minibuffer-completion-help)
+ (completion-basic-try-completion)
+ (completion-basic-all-completions)
+ (completion-pcm--find-all-completions): Use lexical-let to
+ avoid some false matches in variable completion (Bug#7056)
+
+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-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-10-08 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * minibuffer.el (completion--replace):
+ Better preserve markers (bug#7138).
+
+2010-10-08 Juanma Barranquero <lekktu@gmail.com>
+
+ * server.el (server-process-filter): Doc fix.
+
+2010-10-08 Drew Adams <drew.adams@oracle.com>
+
+ * dired.el (dired-save-positions): Doc fix. (Bug#7119)
+
+2010-10-08 Glenn Morris <rgm@gnu.org>
+
+ * 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)
+
+2010-09-27 Kenichi Handa <handa@m17n.org>
+
+ * tar-mode.el (tar-header-block-tokenize): Decode filenames in
+ "ustar" format.
+
+2010-09-27 Kenichi Handa <handa@m17n.org>
+
+ * international/mule.el (define-coding-system): Docstring fixed.
+
+ * international/mule-diag.el (describe-character-set): Use princ
+ with proper print-length and print-level instead of insert.
+
+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)
+ (isearch-lazy-highlight-initial-delay)
+ (isearch-lazy-highlight-interval)
+ (isearch-lazy-highlight-max-at-a-time, isearch-lazy-highlight-face):
+ * net/net-utils.el (ipconfig-program-options):
+ Move aliases to options before the associated definitions.
+
+2010-09-23 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * newcomment.el (comment-normalize-vars): Better test validity of
+ comment-end-skip.
+
+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'.
+ (degrees-to-radians, radians-to-degrees):
+ * calendar/solar.el (solar-longitude):
+ * calculator.el (calculator-registers, calculator-funcall):
+ * textmodes/artist.el (artist-spray-random-points):
+ * play/bubbles.el (bubbles--initialize-images): Use new names.
+
+2010-09-23 Eric M. Ludlam <zappo@gnu.org>
+
+ Update to CEDET 1.0's version of EIEIO.
+
+ * emacs-lisp/eieio.el (eieio-specialized-key-to-generic-key):
+ New function.
+ (eieio-defmethod, eieio-generic-form, eieio-generic-call): Use it.
+ (eieio-default-eval-maybe): Eval val instead of unquoting only.
+ (class-precedence-list): If class is nil, return nil.
+ (eieio-generic-call): If class of first input arg is nil, don't
+ look up static methods, and do check for primary methods.
+ (initialize-instance): See if the default needs to be evaluated
+ during the constructor.
+ (eieio-perform-slot-validation-for-default): Don't do the check
+ for values that will eventually be evaluated.
+ (eieio-eval-default-p): New function.
+ (eieio-default-eval-maybe): Use it.
+
+2010-09-23 Jan Moringen <jan.moringen@uni-bielefeld.de>
+
+ * emacs-lisp/eieio.el (eieio-defclass): Allow :c3
+ method-invocation-order.
+ (eieio-c3-candidate, eieio-c3-merge-lists): New functions.
+ (eieio-class-precedence-dfs): Compute class precedence list using
+ dfs algorithm.
+ (eieio-class-precedence-bfs): Compute class precedence list using
+ bfs algorithm.
+ (eieio-class-precedence-c3): Compute class precedence list using
+ c3 algorithm.
+ (class-precedence-list): New function.
+ (eieiomt-method-list, eieiomt-sym-optimize): Use it.
+ (inconsistent-class-hierarchy): New error symbol.
+ (call-next-method): Stow the replacement argument list for future
+ call-next-method invocations.
+
+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.
+ (appt-make-list): Sort diary-list-entries, if we cannot guarantee
+ that it is in day order. (Bug#7019)
+
+ * calendar/appt.el (appt-check): Rather than showing the diary,
+ just turn off invisible display, and only if needed.
+
+ * 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-gvfs-handler-askquestion):
+ * net/tramp-sh.el (tramp-handle-vc-registered)
+ (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):
+ Add `when' argument. Update callers.
+
+ * subr.el (unintern): Declare the obarray arg mandatory.
+
+2010-09-14 Glenn Morris <rgm@gnu.org>
+
+ * calendar/diary-lib.el (diary-list-entries-hook, diary-sort-entries):
+ Doc fixes.
+
+ * calendar/diary-lib.el (diary-included-files): New variable.
+ (diary-list-entries): Maybe initialize diary-included-files.
+ (diary-include-other-diary-files): Append to diary-included-files.
+ * calendar/appt.el (appt-update-list): Also check the members of
+ diary-included-files. (Bug#6999)
+ (appt-check): Doc fix.
+
+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-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-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-14 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * font-lock.el (font-lock-beginning-of-syntax-function):
+ Mark as obsolete.
+
+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-14 Masatake YAMATO <yamato@redhat.com>
+
+ * progmodes/antlr-mode.el (antlr-font-lock-additional-keywords):
+ Fix typo. (Bug#6976)
+
+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
+ whitespace-toggle-options (Bug#6479). Allow to use fill-column
+ instead of whitespace-line-column (from EmacsWiki). New version 13.1.
+ (whitespace-style): Add 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.
+
+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.
+
+ * emacs-lisp/rx.el (rx-any): Don't explode ranges that end in special
+ chars like - or ] (bug#6984).
+ (rx-any-condense-range): Explode 2-char ranges.
+
+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-05 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * 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): Rename 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>
+
+ * international/mule-cmds.el (standard-display-european-internal):
+ Setup standard-display-table for 8-bit characters by storing 8-bit
+ characters in the element vector.
+
+ * disp-table.el (standard-display-8bit):
+ Setup standard-display-table for 8-bit characters by storing 8-bit
+ 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 Ł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.
+
+ * net/tramp-gvfs.el (tramp-gvfs-handle-write-region):
+ Protect deleting tmpfile.
+ (tramp-gvfs-maybe-open-connection): Use `tramp-compat-funcall'.
+
+ * net/tramp.el (tramp-handle-expand-file-name)
+ (tramp-completion-handle-file-name-all-completions)
+ (tramp-completion-handle-file-name-completion):
+ Use `tramp-connectable-p'.
+
+ * net/trampver.el: Update release number.
+
+2010-08-26 Chong Yidong <cyd@stupidchicken.com>
+
+ * help.el (help-map): Bind `C-h P' to describe-package.
+
+ * menu-bar.el (menu-bar-describe-menu): Add describe-package.
+
+ * 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-25 Kenichi Handa <handa@m17n.org>
+
+ * language/misc-lang.el ("Arabic"): New language environment.
+ Setup composition-function-table for Arabic characters.
+
+ * international/fontset.el (setup-default-fontset): Fix typo for
+ arabic OTF spec (fini->fina).
+
+2010-08-25 Jan Djärv <jan.h.d@swipnet.se>
+
+ * menu-bar.el (menu-bar-set-tool-bar-position): Set frame parameter
+ on all frames.
+
+2010-08-24 Vinicius Jose Latorre <viniciusjl@ig.com.br>
+
+ * 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): Add 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.
+
+2010-08-24 Chong Yidong <cyd@stupidchicken.com>
+
+ * emacs-lisp/package.el (list-packages): Alias for
+ package-list-packages.
+
+2010-08-24 Kevin Ryde <user42@zip.com.au>
+
+ * textmodes/flyspell.el (flyspell-check-tex-math-command): Doc fix
+ (Bug#5651).
+
+ * progmodes/ruby-mode.el (ruby): Add defgroup.
+
+2010-08-24 Chong Yidong <cyd@stupidchicken.com>
+
+ * 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)
+
+ * 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.
+ (ignore, bright, dim, keyword): Split list of nicknames before
+ passing to rcirc-add-or-remove (Bug#6894).
+
+2010-08-22 Chong Yidong <cyd@stupidchicken.com>
+
+ * emacs-lisp/easy-mmode.el (define-minor-mode): Doc fix (Bug#6880).
+
+2010-08-22 Leo <sdl.web@gmail.com>
+
+ Fix buffer-list rename&refresh after killing a buffer in ido.
+ * 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.
+ * iswitchb.el (iswitchb-kill-buffer): Re-make the list.
+
+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-22 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * subr.el (read-key): Don't echo keystrokes (bug#6883).
+
+2010-08-22 Glenn Morris <rgm@gnu.org>
+
+ * menu-bar.el (menu-bar-games-menu): Add landmark.
+
+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)
+
+ * mail/rmail.el (rmail-forward): Replace mail-text-start with its
+ expansion, so as not to need sendmail.
+ (mail-text-start): Remove declaration.
+ (rmail-retry-failure): Require sendmail.
+
+2010-08-22 Chong Yidong <cyd@stupidchicken.com>
+
+ * subr.el (read-key): Don't hide the menu-bar entries (bug#6881).
+
+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-22 Kenichi Handa <handa@m17n.org>
+
+ * files.el: Add `word-wrap' as safe local variable.
+
+2010-08-22 Glenn Morris <rgm@gnu.org>
+
+ * woman.el (woman-translate): Case matters. (Bug#6849)
+
+2010-08-22 Chong Yidong <cyd@stupidchicken.com>
+
+ * simple.el (kill-region): Doc fix (Bug#6787).
+
+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-22 Andreas Schwab <schwab@linux-m68k.org>
+
+ * subr.el (ignore-errors): Add debug declaration.
+
+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>
+
+ * 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
+ isearch-error, ensuring that highlighting is updated if the user
+ switches the search direction (Bug#6808).
+
+ * isearch.el (isearch-lazy-highlight-forward): New var.
+ (isearch-lazy-highlight-new-loop, isearch-lazy-highlight-search):
+ (isearch-lazy-highlight-update): Use it.
+
+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.
+
+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-08 Kenichi Handa <handa@m17n.org>
+
+ * language/cyrillic.el: Don't add "microsoft-cp1251" to
+ ctext-non-standard-encodings-alist here.
+
+ * international/mule.el (ctext-non-standard-encodings-alist):
+ Add "koi8-r" and "microsoft-cp1251".
+ (ctext-standard-encodings): New variable.
+ (ctext-non-standard-encodings-table): List only elements for
+ non-standard encodings.
+ (ctext-pre-write-conversion): Adjust for the above change.
+ Check ctext-standard-encodings.
+
+ * international/mule-conf.el (compound-text): Doc fix.
+ (ctext-no-compositions): Doc fix.
+ (compound-text-with-extensions): Doc fix.
+
+2010-08-08 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * simple.el (exchange-dot-and-mark): Mark obsolete, finally.
+
+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.
+
+ * 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-08 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * bindings.el (complete-symbol): Run completion-at-point as a fallback.
+
+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-08 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * bindings.el (function-key-map): Add a S-tab => backtab fallback.
+
+2010-08-08 Juanma Barranquero <lekktu@gmail.com>
+
+ * dabbrev.el (dabbrev-completion): Fix typo in docstring.
+
+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-08-08 Leo <sdl.web@gmail.com>
+
+ * eshell/esh-io.el (eshell-get-target): Better detection of
+ read-only file (Bug#6762).
+
+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-08-08 Stephen Peters <speters@itasoftware.com>
+
+ * 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-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. (Bug#193)
+
+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-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-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): Change keys from symbols to strings;
+ enhanced the widget definition.
+ (sql-mode-menu): Add submenu to select connections.
+ (sql-interactive-mode-menu): Add "Save Connection" item.
+ (sql-add-product): Fix menu item.
+ (sql-get-product-feature): Improved error handling.
+ (sql--alt-buffer-part, sql--alt-if-not-empty): Remove.
+ (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): Add 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): Rename sql-connect-* functions to
+ sql-comint-*.
+ (sql-product-alist, sql-mode-menu): Rename 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/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)
+
+2010-07-16 Eli Zaretskii <eliz@gnu.org>
+
+ * 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).
+
+2010-07-14 Chong Yidong <cyd@stupidchicken.com>
+
+ * 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>
+
+ * calendar/calendar.el (calendar-week-end-day): New function.
+ * calendar/cal-tex.el (cal-tex-cursor-month): Remove unused vars.
+ Respect calendar-week-start-day. (Bug#6606)
+ (cal-tex-insert-day-names, cal-tex-insert-blank-days)
+ (cal-tex-insert-blank-days-at-end): Respect calendar-week-start-day.
+ (cal-tex-first-blank-p, cal-tex-last-blank-p): Simplify, and
+ respect calendar-week-start-day.
+
+2010-07-10 Chong Yidong <cyd@stupidchicken.com>
+
+ * 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
+ builtins (BufferError, BytesWarning, WindowsError; callables
+ bin, bytearray, bytes, format, memoryview, next, print; __package__).
+
+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): Delete.
+ (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.
+
+2010-07-06 Chong Yidong <cyd@stupidchicken.com>
+
+ * mouse.el (mouse-appearance-menu): Add docstring.
+
+ * help.el (describe-key): Print up-event using key-description.
+
+2010-07-03 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/zeroconf.el (zeroconf-resolve-service)
+ (zeroconf-service-resolver-handler): Use `dbus-byte-array-to-string'.
+ (zeroconf-publish-service): Use `dbus-string-to-byte-array'.
+
+2010-07-03 Jan Moringen <jan.moringen@uni-bielefeld.de>
+
+ * net/zeroconf.el (zeroconf-service-remove-hook): New defun.
+
+2010-06-30 Dan Nicolaescu <dann@ics.uci.edu>
+
+ Avoid displaying files with a nil state in vc-dir.
+ * 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.
+
+2010-06-30 Chong Yidong <cyd@stupidchicken.com>
+
+ * xml.el (xml-parse-region): Avoid infloop (Bug#5281).
+
+2010-06-29 Leo <sdl.web@gmail.com>
+
+ * emacs-lisp/rx.el (rx): Doc fix. (Bug#6537)
+
+2010-06-27 Oleksandr Gavenko <gavenkoa@gmail.com> (tiny change)
+
+ * generic-x.el (bat-generic-mode): Fix regexp for command line
+ switches (Bug#5719).
+
+2010-06-27 Masatake YAMATO <yamato@redhat.com>
+
+ * htmlfontify.el (hfy-face-attr-for-class): Use append instead
+ of nconc to avoid pure storage error (Bug#6239).
+
+2010-06-27 Christoph Scholtes <cschol2112@googlemail.com>
+
+ * bookmark.el (bookmark-bmenu-2-window, bookmark-bmenu-other-window)
+ (bookmark-bmenu-other-window-with-mouse): Remove unnecessary
+ bindings of bookmark-automatically-show-annotations (Bug#6515).
+
+2010-06-25 Eli Zaretskii <eliz@gnu.org>
+
+ * arc-mode.el (archive-zip-extract): Don't quote the file name on
+ MS-Windows and MS-DOS. (Bug#6467, Bug#6144)
+
+2010-06-24 Štěpán Němec <stepnem@gmail.com> (tiny change)
+
+ * comint.el (make-comint, make-comint-in-buffer): Mention return
+ value in the docstrings. (Bug#6498)
+
+2010-06-24 Yoni Rabkin <yoni@rabkins.net>
+
+ * bs.el (bs-mode-font-lock-keywords): Remove "by" from Dired pattern,
+ since it is not present when using some non-default switches.
+
+2010-06-23 Karl Fogel <kfogel@red-bean.com>
+
+ * simple.el (compose-mail): Fix doc string to refer to
+ `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/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
+ ambiguity with the revision.
+ (vc-git-previous-revision): Pass a relative file name.
+
+2010-06-22 Glenn Morris <rgm@gnu.org>
+
+ * progmodes/js.el (js-mode-map): Use standard capitalization and
+ ellipses for menu entries.
+
+ * wid-edit.el (widget-complete): Doc fix.
+
+2010-06-22 Jürgen Hötzel <juergen@hoetzel.info> (tiny change)
+
+ * wid-edit.el (widget-complete): Fix typo in 2009-12-02 change.
+
+2010-06-22 Dan Nicolaescu <dann@ics.uci.edu>
+
+ Fix annotating other revisions for renamed files in vc-annotate.
+ * 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.
+ (Bug#6487).
+
+ Fix vc-annotate-show-changeset-diff-revision-at-line for git.
+ * 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/vc.el (vc-find-revision): Add an optional argument for
+ the VC backend. Use it when non-nil.
+ * 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/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>
+
+ * progmodes/cc-mode.el (c-before-hack-hook): When the mode is set
+ in file local variables, set it first.
+
+2010-06-19 Glenn Morris <rgm@gnu.org>
+
+ * descr-text.el (describe-char-unicode-data): Insert separating
+ space when needed. (Bug#6422)
+
+ * progmodes/idlwave.el (idlwave-action-and-binding):
+ Fix typo in 2009-12-03 change. (Bug#6450)
+
+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).
+ (font-lock-set-defaults):
+ * font-core.el (font-lock-default-function): Adjust users.
+ (font-lock-mode): Don't set it at all.
+
+2010-06-16 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * vc/vc-annotate.el (vc-annotate): Use vc-read-revision.
+
+2010-06-16 Glenn Morris <rgm@gnu.org>
+
+ * calendar/appt.el (appt-time-msg-list): Doc fix.
+ (appt-check): Let-bind appt-warn-time.
+ (appt-add): Make the 3rd argument optional.
+ Simplify argument names. Doc fix. Check for integer WARNTIME.
+ Only add WARNTIME to the output list if non-nil.
+
+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-16 Bob Rogers <rogers-emacs@rgrjr.dyndns.org>
+
+ * vc/vc-svn.el (vc-svn-after-dir-status): Fix regexp for Subversions
+ older than version 1.6. (Bug#6361)
+
+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):
+ Define warning-suppress-types before we let-bind it (bug#6275).
+
+ * vc-dispatcher.el: Rename mode-line-hook to vc-mode-line-hook;
+ declare it, make it buffer-local and permanent-local (bug#6324).
+ (vc-resynch-window): Adjust name.
+ * vc-hooks.el (vc-find-file-hook): Adjust name.
+
+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.
+
+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>
+
+ * net/dbus.el (dbus-register-method): Declare function.
+ (dbus-handle-event, dbus-property-handler): Fix typos in docstrings.
+ (dbus-introspect): Doc fix.
+ (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>
+
+ * vc-bzr.el (vc-bzr-revision-completion-table): Apply
+ `file-directory-p' to the filename part rather than to the whole text.
+
+2010-05-31 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * man.el (Man-completion-table): Let the user type "-k " (bug#6319).
+
+2010-05-31 Drew Adams <drew.adams@oracle.com>
+
+ * files.el (directory-files-no-dot-files-regexp): Doc fix (bug#6298).
+
+2010-05-31 Juanma Barranquero <lekktu@gmail.com>
+
+ * 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).
+ (ansi-color-drop-regexp): New constant.
+ (ansi-color-apply, ansi-color-filter-region)
+ (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-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):
+ Use font-lock-constant-face, not obsolete font-lock-reference-face.
+
+2010-05-27 Masatake YAMATO <yamato@redhat.com>
+
+ * 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-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>
+
+ * 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.
+
+ * minibuffer.el (completion-pcm--pattern->regex):
+ Fix last change (bug#6160).
+
+2010-05-10 Juri Linkov <juri@jurta.org>
+
+ 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.
+
+2010-05-10 Michael Albinus <michael.albinus@gmx.de>
+
+ * 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-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-08 Eli Zaretskii <eliz@gnu.org>
+
+ * composite.el (compose-region, reference-point-alist): Fix typos
+ in the doc strings.
+
+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-05-08 Juanma Barranquero <lekktu@gmail.com>
+
+ * abbrev.el (last-abbrev-text): Doc fix.
+ (abbrev-prefix-mark): Don't escape parenthesis.
+
+2010-05-08 Andreas Schwab <schwab@linux-m68k.org>
+
+ * composite.el (find-composition): Doc fix.
+
+2010-05-08 Juanma Barranquero <lekktu@gmail.com>
+
+ * progmodes/sql.el (sql-electric-stuff): Fix typo in tag.
+ (sql-oracle-program, sql-sqlite-options)
+ (sql-query-placeholders-and-send): Doc fixes.
+ (sql-set-product, sql-interactive-mode): Reflow docstrings.
+ (sql-imenu-generic-expression, sql-buffer)
+ (sql-mode-ansi-font-lock-keywords, 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-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-ingres, sql-ms, sql-postgres, sql-interbase, sql-db2, sql-linter):
+ Fix typos in docstrings.
+
+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-05-08 Juri Linkov <juri@jurta.org>
+
+ * image-mode.el (image-mode-as-text): Fix typo in docstring.
+
+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-05-08 Kenichi Handa <handa@m17n.org>
+
+ * language/indian.el (gurmukhi-composable-pattern): Fix typo.
+ (gujarati-composable-pattern): Fix typo.
+
+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-05-08 Chong Yidong <cyd@stupidchicken.com>
+
+ * files.el (copy-directory): Handle symlinks (Bug#5982).
+
+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-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-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-19 Glenn Morris <rgm@gnu.org>
+
+ * htmlfontify.el (htmlfontify-buffer)
+ (htmlfontify-copy-and-link-dir): Autoload entry points.
+
+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-19 Glenn Morris <rgm@gnu.org>
+
+ * vc-git.el (vc-git-print-log): Doc fix.
+
+2010-04-19 Óscar Fuentes <ofv@wanadoo.es>
+
+ * ido.el (ido-file-internal): Fix 2009-12-02 change.
+
+2010-04-19 Christoph Scholtes <cschol2112@googlemail.com>
+
+ * progmodes/grep.el (grep-compute-defaults): Fix handling of host
+ default settings (Bug#5928).
+
+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-19 Kenichi Handa <handa@m17n.org>
+
+ * language/indian.el (malayalam-composable-pattern): Fix previous
+ change (add U+0D4D "SIGN VIRAMA").
+ (oriya-composable-pattern): Add U+0B30 and fix typo in the regexp.
+ (tamil-composable-pattern): Fix typo in the regexp.
+ (telugu-composable-pattern): Fix U+0C4D and typo in the regexp.
+ (kannada-composable-pattern): Fix U+0CB0 and typo in the regexp.
+ (malayalam-composable-pattern): Fix U+0D4D and typo in the regexp.
+
+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-19 Juri Linkov <juri@jurta.org>
+
+ Put breadcrumbs on overlay instead of inserting to buffer (bug#5809).
+
+ * info.el (Info-find-node-2): Comment out code that skips
+ breadcrumbs line.
+ (Info-mouse-follow-link): New command.
+ (Info-link-keymap): New keymap.
+ (Info-breadcrumbs): Rename from `Info-insert-breadcrumbs'.
+ Return a string with links instead of inserting breadcrumbs
+ to the Info buffer.
+ (Info-fontify-node): Comment out code that inserts breadcrumbs.
+ Instead of putting the `invisible' text property over the Info
+ header, make an overlay over the Info header with the `invisible'
+ property and `after-string' set to the string returned by
+ `Info-breadcrumbs'.
+
+2010-04-19 Chong Yidong <cyd@stupidchicken.com>
+
+ * help.el (help-window-setup-finish): Doc fix (Bug#5830).
+ Reported by monkey@sandpframing.com.
+
+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-31 Kenichi Handa <handa@m17n.org>
+
+ * language/sinhala.el (composition-function-table): Fix regexp for
+ the new Unicode specification.
+
+ * language/indian.el (devanagari-composable-pattern)
+ (tamil-composable-pattern, kannada-composable-pattern)
+ (malayalam-composable-pattern): Adjust for the new Unicode
+ specification.
+ (bengali-composable-pattern, gurmukhi-composable-pattern)
+ (gujarati-composable-pattern, oriya-composable-pattern)
+ (telugu-composable-pattern): New variables to cope with the new
+ Unicode specification. Use them in composition-function-table.
+
+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-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
+ electric punctuation for "{}();,:" (Bug#5586).
+
+ * mail/sendmail.el (mail-default-directory): Doc fix.
+
+2010-03-31 Chong Yidong <cyd@stupidchicken.com>
+
+ * mail/sendmail.el (mail-default-directory): Doc fix.
+
+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-02-31 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc.el (vc-root-diff): Doc fix.
+
+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-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.
+
+2010-03-24 Juanma Barranquero <lekktu@gmail.com>
+
+ * faces.el (set-face-attribute): Fix typo in docstring.
+ (face-valid-attribute-values): Reflow docstring.
+
+2010-03-24 Glenn Morris <rgm@gnu.org>
+
+ * textmodes/flyspell.el (sgml-lexical-context): Autoload it (Bug#5752).
+
+2010-03-24 Chong Yidong <cyd@stupidchicken.com>
+
+ * indent.el (indent-for-tab-command): Doc fix.
+
+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.
+
+ * json.el (json-object-type, json-array-type, json-key-type)
+ (json-false, json-null, json-read-number):
+ * minibuffer.el (completion-in-region-functions):
+ * calendar/cal-tex.el (cal-tex-daily-end, cal-tex-number-weeks)
+ (cal-tex-cursor-week):
+ * emacs-lisp/trace.el (trace-function):
+ * eshell/em-basic.el (eshell/printnl):
+ * eshell/em-dirs.el (eshell-last-dir-ring, eshell-parse-drive-letter)
+ (eshell-read-last-dir-ring, eshell-write-last-dir-ring):
+ * obsolete/levents.el (allocate-event, event-key, event-object)
+ (event-point, event-process, event-timestamp, event-to-character)
+ (event-window, event-x, event-x-pixel, event-y, event-y-pixel):
+ * textmodes/reftex-vars.el (reftex-index-macros-builtin)
+ (reftex-section-levels, reftex-auto-recenter-toc, reftex-toc-mode-hook)
+ (reftex-cite-punctuation, reftex-search-unrecursed-path-first)
+ (reftex-highlight-selection): Fix typos in docstrings.
+
+2010-03-24 Juanma Barranquero <lekktu@gmail.com>
+
+ * minibuffer.el (completion-in-region-functions): Fix docstring typos.
+
+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-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-24 Kenichi Handa <handa@m17n.org>
+
+ * language/indian.el (devanagari-composable-pattern): Add more
+ consonants.
+
+2010-03-24 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/trampver.el: Update release number.
+
+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
+ output of "wc -l" more robust.
+ (tramp-find-shell): Use another shell but /bin/sh on OpenSolaris.
+ (tramp-open-connection-setup-interactive-shell): Remove workaround
+ for OpenSolaris bug, it is not needed anymore.
+
+2010-03-24 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/cl-macs.el (defsubst*): Add autoload cookie. (Bug#4427)
+
+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 (compilation-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,
+ instead of "format:"; this ensures that the output is
+ newline-terminated.
+
+2010-03-08 Chong Yidong <cyd@stupidchicken.com>
+
+ * mail/rfc822.el (rfc822-addresses): Use nested catches to ensure
+ that all errors are caught, and that the return value is always a
+ list (Bug#5692).
+
+2010-03-08 Kenichi Handa <handa@m17n.org>
+
+ * language/misc-lang.el (windows-1256): New coding system.
+ (cp1256): New alias of windows-1256 (bug#5690).
+
+2010-03-07 Andreas Schwab <schwab@linux-m68k.org>
+
+ * mail/rfc822.el (rfc822-addresses): Move catch clause down around
+ call to rfc822-bad-address. (Bug#5692)
+
+2010-03-07 Štěpán Němec <stepnem@gmail.com> (tiny change)
+
+ * vc-git.el (vc-git-annotate-extract-revision-at-line):
+ Use vc-git-root as default directory for revision path (Bug#5657).
+
+2010-03-06 Chong Yidong <cyd@stupidchicken.com>
+
+ * calculator.el (calculator): Don't bind split-window-keep-point
+ (Bug#5674).
+
+2010-03-06 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * vc-git.el: Re-flow to fit into 80 columns.
+ (vc-git-after-dir-status-stage, vc-git-dir-status-goto-stage):
+ Remove spurious `quote' element in each case alternative.
+ (vc-git-show-log-entry): Use prog1.
+ (vc-git-after-dir-status-stage): Remove unused var `remaining'.
+
+2010-03-05 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * man.el (Man-files-regexp): Tighten up the regexp (bug#5686).
+
+2010-03-03 Chong Yidong <cyd@stupidchicken.com>
+
+ * macros.el (insert-kbd-macro): Look up keyboard macro using the
+ definition, not the name (Bug#5481).
+
+2010-03-03 Štěpán Němec <stepnem@gmail.com> (tiny change)
+
+ * subr.el (momentary-string-display): Don't overwrite the MESSAGE
+ argument with a local variable. (Bug#5670)
+
+2010-03-02 Juri Linkov <juri@jurta.org>
+
+ * info.el (Info-index-next): Decrement line number by 2. (Bug#5652)
+
+2010-03-02 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-do-copy-or-rename-file-out-of-band): Fix an
+ error when FILENAME and NEWNAME are existing remote directories.
+
+ * net/tramp-compat.el (tramp-compat-make-temp-file): Add optional
+ parameter DIR-FLAG.
+
+2010-03-02 Glenn Morris <rgm@gnu.org>
+
+ * calendar/cal-hebrew.el (holiday-hebrew-passover): Fix date
+ of Yom HaAtzma'ut when it falls on a Monday (rule changed in 2004).
+
+2010-03-01 Kenichi Handa <handa@m17n.org>
+
+ * language/burmese.el (burmese-composable-pattern): Rename from
+ myanmar-composable-pattern.
+
+ * international/characters.el (script-list):
+ * international/fontset.el (script-representative-chars):
+ Change myanmar to burmese.
+ (otf-script-alist): Likewise.
+ (setup-default-fontset): Likewise. Re-fix :otf spec.
+
+2010-02-28 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * menu-bar.el (menu-bar-manuals-menu): Fix typo.
+
+2010-02-28 Jan Djärv <jan.h.d@swipnet.se>
+
+ * scroll-bar.el (scroll-bar-drag-1): Add save-excursion, bug #5654.
+
+2010-02-28 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-handle-write-region): START can be a string.
+ Take care in the checks. Reported by Dan Davison
+ <davison@stats.ox.ac.uk>.
+
+2010-02-28 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/dbus.el (dbus-introspect, dbus-get-property)
+ (dbus-set-property, dbus-get-all-properties):
+ Use `dbus-call-method' when noninteractive. (Bug#5645)
+
+2010-02-28 Chong Yidong <cyd@stupidchicken.com>
+
+ * textmodes/reftex-toc.el (reftex-toc-promote-prepare):
+ * emacs-lisp/elint.el (elint-add-required-env):
+ * calendar/icalendar.el (icalendar--add-diary-entry):
+ * calc/calcalg2.el (math-tracing-integral):
+ * files.el (recover-session-finish): Use with-current-buffer
+ instead of save-excursion.
+
+2010-02-27 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Fix in-buffer completion when after-change-functions modify the buffer.
+ * minibuffer.el (completion--replace): New function.
+ (completion--do-completion): Use it and use relative movement.
+
+2010-02-27 Chong Yidong <cyd@stupidchicken.com>
+
+ * international/fontset.el (setup-default-fontset): Fix :otf spec.
+
+2010-02-27 Jeremy Whitlock <jcscoobyrs@gmail.com> (tiny change)
+
+ * progmodes/python.el (python-pdbtrack-stack-entry-regexp):
+ Allow the characters _<> in the stack entry (Bug#5653).
+
+2010-02-26 Kenichi Handa <handa@m17n.org>
+
+ * language/burmese.el: Fix entries in composition-function-table.
+ (myanmar-composable-pattern): New variable.
+
+ * international/fontset.el (setup-default-fontset): Add an entry
+ for myanmar.
+
+ * international/characters.el (script-list): Add Myanmar
+ Extended-A.
+
+2010-02-26 Glenn Morris <rgm@gnu.org>
+
+ * custom.el (custom-initialize-delay): Doc fix.
+
+ * mail/sendmail.el (send-mail-function): Autoload the call
+ to custom-initialize-delay, not otherwise preserved in loaddefs.el.
+
+2010-02-24 Chong Yidong <cyd@stupidchicken.com>
+
+ * files.el (hack-local-variables-filter): For eval forms, also
+ check safe-local-variable-p (Bug#5636).
+
+2010-02-22 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-do-copy-or-rename-file-out-of-band): Protect
+ setting the modes by `ignore-errors'. It might fail, for example
+ if the file is not owned by the user but the group.
+ (tramp-handle-write-region): Ensure, that `tmpfile' is always readable.
+
+2010-02-21 Chong Yidong <cyd@stupidchicken.com>
+
+ * files.el (directory-listing-before-filename-regexp):
+ Use stricter matching for iso-style dates, to avoid false matches with
+ date-like filenames (Bug#5597).
+
+ * htmlfontify.el (htmlfontify): Doc fix.
+
+ * eshell/eshell.el (eshell): Doc fix.
+
+ * startup.el (fancy-about-screen): In mode-line, apply
+ mode-line-buffer-id face only to the buffer name (Bug#5613).
+
+2010-02-20 Kevin Ryde <user42@zip.com.au>
+
+ * progmodes/compile.el (compilation-error-regexp-alist-alist):
+ In `watcom' anchor regexp to start of line, to avoid slowness
+ (Bug#5599).
+
+2010-02-20 Eli Zaretskii <eliz@gnu.org>
+
+ * subr.el (remove-yank-excluded-properties): Explain in a comment
+ why `category' property is removed.
+
+2010-02-19 Chong Yidong <cyd@stupidchicken.com>
+
+ * isearch.el (isearch-update-post-hook, isearch-update):
+ Revert 2010-02-17 change.
+
+2010-02-19 Ulf Jasper <ulf.jasper@web.de>
+
+ * calendar/icalendar.el (icalendar--convert-ordinary-to-ical)
+ (icalendar--convert-weekly-to-ical)
+ (icalendar--convert-yearly-to-ical)
+ (icalendar--convert-block-to-ical)
+ (icalendar--convert-cyclic-to-ical)
+ (icalendar--convert-anniversary-to-ical): Take care of time
+ specifications where hour has 1-digit only (Bug#5549).
+
+2010-02-19 Nick Roberts <nickrob@snap.net.nz>
+
+ * progmodes/gdb-ui.el (gdb-assembler-handler): Accommodate change
+ of disassemble output in GDB 7.1.
+
+2010-02-19 Glenn Morris <rgm@gnu.org>
+
+ * progmodes/f90.el (f90-electric-insert): Give it a delete-selection
+ property. (Bug#5593)
+
+2010-02-18 Sam Steingold <sds@gnu.org>
+
+ * vc-cvs.el (vc-cvs-merge-news): Yet another fix of message parsing.
+
+2010-02-18 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Use abbreviated file names in bookmarks (bug#5591).
+ * bookmark.el (bookmark-maybe-load-default-file): Remove redundant
+ calls to expand-file-name.
+ (bookmark-relocate): Use abbreviated file names in bookmarks.
+ (bookmark-load): Use abbreviated file names in messages.
+
+2010-02-18 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-handle-directory-files): When FULL, do not
+ expand "." and "..". Reported by Thierry Volpiatto
+ <thierry.volpiatto@gmail.com>.
+
+2010-02-18 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-handle-insert-file-contents): Set always the
+ permissions of the temporary file to "0600". In case the remote
+ file has no read permissions for the owner, there might be
+ problems otherwise. Reported by Ole Laursen <olau@iola.dk>.
+
+22010-02-18 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/authors.el (authors-renamed-files-alist):
+ Add entries for INSTALL.CVS.
+
+2010-02-17 Mark A. Hershberger <mah@everybody.org>
+
+ * vc-bzr.el: Fix typo in Known Bugs section.
+
+ * isearch.el (isearch-update-post-hook): New hook.
+ (isearch-update): Use the new hook.
+
+2010-02-16 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-do-copy-or-rename-file-out-of-band):
+ Fix errors in copying directories.
+ (tramp-handle-add-name-to-file, tramp-handle-copy-directory)
+ (tramp-do-copy-or-rename-file, tramp-handle-delete-directory)
+ (tramp-handle-delete-file)
+ (tramp-handle-dired-recursive-delete-directory)
+ (tramp-handle-write-region): Flush also the cache for the upper
+ directory.
+
+2010-02-16 Chong Yidong <cyd@stupidchicken.com>
+
+ * simple.el (save-interprogram-paste-before-kill): Doc fix.
+
+ * cus-edit.el (hardware): Doc fix.
+
+ * man.el (man): Add to external custom group.
+
+ * delim-col.el (columns): Move to wp custom group.
+
+ * doc-view.el (doc-view): Add to data custom group.
+
+ * nxml/nxml-mode.el (nxml-faces): Remove from font-lock-faces group.
+
+ * textmodes/flyspell.el (flyspell-word): Obey the offset specified
+ by ispell-parse-output (Bug#5575).
+
+2010-02-16 Kenichi Handa <handa@m17n.org>
+
+ * international/ja-dic-cnv.el (iso-2022-7bit-short): Delete it.
+ (skkdic-convert-okuri-ari): Ignore lines starting with '>'.
+ (skkdic-convert): Use `euc-japan' coding system for writing.
+
+2010-02-16 Glenn Morris <rgm@gnu.org>
+
+ * textmodes/tex-mode.el (tex-bibtex-file): Expand the result of
+ tex-main-file before using it. (Bug#5562)
+
+2010-02-15 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/advice.el (ad-compile-function): Suppress byte-compiler
+ warnings, since it is annoying for the user to see them each time he
+ runs the code.
+
+2010-02-15 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-process-actions, tramp-read-passwd):
+ * net/tramp-gvfs.el (tramp-gvfs-maybe-open-connection): Use VEC
+ instead of PROC for caching "first-password-request". Otherwise,
+ new processes would not profit from passwords already entered.
+
+ * net/tramp-cache.el (tramp-dump-connection-properties):
+ Don't save "first-password-request" property.
+
+2010-02-14 Juanma Barranquero <lekktu@gmail.com>
+
+ * outline.el (outline-head-from-level):
+ * simple.el (with-wrapper-hook):
+ * emacs-lisp/elint.el (elint-extra-errors, elint-current-buffer)
+ (elint-defun, elint-buffer-env, elint-top-form-logged)
+ (elint-unbound-variable):
+ * textmodes/reftex-toc.el (reftex-toc-newhead-from-alist):
+ Fix typos in docstrings.
+
+2010-02-14 Michael Albinus <michael.albinus@gmx.de>
+
+ * files.el (insert-directory): When WILDCARD-REGEXP and
+ FULL-DIRECTORY-P are nil, insert the file entry instead of the
+ whole directory. (Bug#5551)
+
+ * net/ange-ftp.el (ange-ftp-insert-directory): Insert " " for
+ dired's alignment sanity. (Bug#5516)
+
+2010-02-14 Juri Linkov <juri@jurta.org>
+
+ * man.el (Man-fontify-manpage, Man-cleanup-manpage):
+ Remove remaining ^H with their preceding chars. (Bug#5566)
+
+2010-02-13 Glenn Morris <rgm@gnu.org>
+
+ * simple.el (transpose-subr): Give it a doc-string.
+
+ * textmodes/paragraphs.el (transpose-paragraphs, transpose-sentences):
+ Doc fixes.
+
+2010-02-12 Juri Linkov <juri@jurta.org>
+
+ * arc-mode.el (archive-unique-fname): Make directories for nested
+ archives. (Bug#5540)
+
+2010-02-12 Juri Linkov <juri@jurta.org>
+
+ * ffap.el (dired-at-point): Fix docstring. (Bug#5565)
+
+2010-02-11 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * subr.el (copy-overlay): Handle deleted overlays.
+
+ * man.el (Man-completion-table): Don't signal an error if we can't run
+ manual-program (bug#4056).
+
+2010-02-10 Juanma Barranquero <lekktu@gmail.com>
+
+ * textmodes/artist.el (artist-mt): Fix typos in docstring.
+
+2010-02-10 Thierry Volpiatto <thierry.volpiatto@gmail.com>
+
+ * info.el (Info-bookmark-jump): Simplify.
+
+ * bookmark.el (bookmark-handle-bookmark): Catch the right error.
+ (bookmark-default-handler): Accept new bookmark field `buffer'.
+
+2010-02-10 Chong Yidong <cyd@stupidchicken.com>
+
+ * iswitchb.el (iswitchb-completions): Revert last change.
+
+2010-02-10 Michael Albinus <michael.albinus@gmx.de>
+
+ * ls-lisp.el (ls-lisp-insert-directory): When WILDCARD-REGEXP and
+ FULL-DIRECTORY-P are nil, and FILE is absolute, expand it.
+ This prevents file names like "~/" being listed literally.
+
+2010-02-10 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * term/xterm.el (xterm-maybe-set-dark-background-mode):
+ Remove dead code. (Bug#5546)
+
+2010-02-09 Chong Yidong <cyd@stupidchicken.com>
+
+ * eshell/em-ls.el (eshell-ls-applicable): Frob file attributes
+ correctly (Bug#5548).
+
+2010-02-08 Jose E. Marchesi <jemarch@gnu.org>
+
+ * progmodes/ada-mode.el (ada-in-numeric-literal-p): New function.
+ (ada-adjust-case): Don't adjust case in hexadecimal number literals.
+
+2010-02-08 Kenichi Handa <handa@m17n.org>
+
+ * international/mule-util.el (with-coding-priority): Add autoload
+ cookie for putting `lisp-indent-function'.
+
+2010-02-07 Glenn Morris <rgm@gnu.org>
+
+ * progmodes/f90.el (f90-font-lock-keywords-1, f90-font-lock-keywords-2):
+ Move F2003 named interfaces from keywords-2 to keywords-1, and
+ use function-name-face rather than constant-face.
+ Simplify "abstract interface" regexp.
+
+2010-02-07 Chong Yidong <cyd@stupidchicken.com>
+
+ * eshell/esh-util.el (eshell-file-attributes): New optional arg
+ ID-FORMAT. Pass it to `file-attributes'.
+
+ * eshell/em-ls.el (eshell-do-ls): Use it (Bug#5528).
+
+2010-02-07 sj <prime.wizard+emacs@gmail.com> (tiny change)
+
+ * faces.el (set-face-attribute): Allow calling
+ internal-set-lisp-face-attribute with 'unspecified family and
+ foundry argument (Bug#5536).
+
+2010-02-07 Glenn Morris <rgm@gnu.org>
+
+ * progmodes/f90.el (f90-font-lock-keywords-2)
+ (f90-looking-at-type-like, f90-looking-at-program-block-end):
+ Handle F2003 named interfaces.
+
+2010-02-06 Chong Yidong <cyd@stupidchicken.com>
+
+ * progmodes/cc-mode.el (c-common-init): Bind temporary variables
+ beg and end before calling c-get-state-before-change-functions.
+
+2010-02-06 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-bzr.el (vc-bzr-dir-extra-headers):
+ Disable the pending merges header.
+
+2010-02-05 Juri Linkov <juri@jurta.org>
+
+ * doc-view.el (doc-view-mode):
+ * image-mode.el (image-mode): Put property mode-class=special.
+ (Bug#4896)
+
+2010-02-05 Mark A. Hershberger <mah@everybody.org>
+
+ * vc-svn.el (vc-svn-revision-table): New function.
+
+2010-02-05 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/ange-ftp.el (ange-ftp-insert-directory):
+ * net/tramp-imap.el (tramp-imap-handle-insert-directory):
+ * net/tramp-smb.el (tramp-smb-handle-insert-directory):
+ Handle also directories. (Bug#5478)
+
+2010-02-05 Glenn Morris <rgm@gnu.org>
+
+ * progmodes/f90.el (f90-font-lock-keywords-2): Fix `enum'.
+
+2010-02-05 Chong Yidong <cyd@stupidchicken.com>
+
+ * startup.el (command-line-1): Convert options beginning with a
+ single dash as well (Bug#5519).
+
+2010-02-05 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Make `initials' completion work for /hh -> /home/horn again (bug#5524).
+ * minibuffer.el (completion-initials-expand): Only check the presence
+ of delims *within* the boundaries, since otherwise the / delim is
+ always found for files.
+
+ Fix up various corner case problems.
+ * doc-view.el (doc-view-last-page-number): New function.
+ (doc-view-mode, doc-view-last-page, doc-view-goto-page): Use it.
+ (doc-view-goto-page): Avoid inf-loops when the conversion fails.
+ (doc-view-kill-proc): Avoid inf-loop in freak cases.
+ (doc-view-reconvert-doc): Use the new recursive delete-directory.
+ (doc-view-convert-current-doc): Don't create the resolution.el file
+ here any more.
+ (doc-view-pdf/ps->png): Do it here instead.
+ (doc-view-already-converted-p): Check that resolution.el is present.
+ (doc-view-pdf->png): Don't rely on doc-view-pdf/ps->png for the few
+ windows that are not yet showing images.
+
+2010-02-04 Michael Albinus <michael.albinus@gmx.de>
+
+ * dired.el (dired-revert): If DIRED-DIRECTORY is a cons cell, call
+ `dired-uncache' for every elemnt which is an absolute file name.
+
+ * net/tramp.el (tramp-handle-dired-uncache): When DIR is not a
+ directory, handle its directory component.
+ (tramp-handle-file-remote-p): Let-bind `tramp-verbose' to 3; this
+ function is called permanently and creates noise, otherwise.
+
+ * net/tramp-imap.el (tramp-imap-handle-insert-directory):
+ * net/tramp-smb.el (tramp-smb-handle-insert-directory):
+ Handle the case, FILENAME is not in `default-directory'. (Bug#5478)
+
+2010-02-04 David Burger <dburger@google.com> (tiny change)
+
+ * macros.el (apply-macro-to-region-lines):
+ Minor simplification. (Bug#5485)
+
+2010-02-04 Glenn Morris <rgm@gnu.org>
+
+ * mail/rmail.el (rmail-show-message-1): Handle malformed
+ quoted-printable text. (Bug#5441)
+
+ * mail/mail-utils.el (mail-unquote-printable-region): Doc fix.
+
+ * simple.el (visual-line-mode): Capitalize lighter.
+
+2010-02-03 John Wiegley <jwiegley@gmail.com>
+
+ * iswitchb.el (iswitchb-completions): Add bookmark files to the
+ list of files considered for "virtual buffer" completions.
+
+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
+ when dired is called with a list of files, which are not in
+ `default-directory'. (Bug#5478)
+
+2010-02-03 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * vc-hooks.el (vc-path): Make it an obsolete var, rather than function.
+
+2010-02-02 Juri Linkov <juri@jurta.org>
+
+ * textmodes/ispell.el (ispell-message-text-end): Remove final newline
+ from unidiff to allow function-line after @@.
+
+2010-02-02 Juri Linkov <juri@jurta.org>
+
+ * ediff-util.el (ediff-file-checked-in-p): Replace '(nil CVS) by
+ '(RCS SCCS) with inverted condition.
+
+2010-02-02 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/ange-ftp.el (ange-ftp-skip-msgs): Ignore all ""^500 .*AUTH"
+ messages.
+
+2010-02-01 Juri Linkov <juri@jurta.org>
+
+ * arc-mode.el (archive-zip-extract): Use `member-ignore-case' to
+ compare with "pkunzip" and "pkzip" instead of only "pkzip".
+ In the `archive-extract-by-stdout' branch use `shell-quote-argument'
+ only when (car archive-zip-extract) is "unzip". (Bug#5475)
+
+2010-02-01 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * doc-view.el (doc-view-new-window-function): Be a bit more defensive.
+ (doc-view-revert-buffer): New command.
+ (doc-view-mode-map): Use it.
+
+2010-02-01 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-bzr.el (vc-bzr-dir-extra-headers): Add a header when a
+ pending merge is detected.
+
+2010-01-31 Juri Linkov <juri@jurta.org>
+
+ * progmodes/grep.el (zrgrep): Call `grep-compute-defaults' at the
+ beginning of interactive spec like all other grep commands do.
+ Put "all" in front of "gz". (Bug#5260)
+
+2010-01-29 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-bzr.el (vc-bzr-after-dir-status): Match another renaming indicator.
+
+2010-01-29 Chong Yidong <cyd@stupidchicken.com>
+
+ * dirtrack.el (dirtrack): Warn instead of signalling error if the
+ regexp is incorrect (Bug#5476).
+
+2010-01-29 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-handle-insert-directory): Handle also
+ symlinks, when FILENAME is not in `default-directory'.
+
+2010-01-28 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/ange-ftp.el (ange-ftp-insert-directory): Handle the case,
+ FILE is not in `default-directory'. (Bug#5478)
+
+ * net/tramp.el (tramp-handle-insert-directory): Simplify handling
+ of SWITCHES. Handle the case, FILENAME is not in
+ `default-directory'. (Bug#5478)
+ (tramp-register-file-name-handlers): Add safe-magic property.
+
+2010-01-28 Chong Yidong <cyd@stupidchicken.com>
+
+ * arc-mode.el (archive-zip-extract): Quote the argument passed to
+ unzip (Bug#5475).
+
+2010-01-28 Nil Geisweiller <ngeiswei@googlemail.com> (tiny change)
+
+ * progmodes/flymake.el (flymake-allowed-file-name-masks)
+ (flymake-master-make-header-init): Add other C++ filename masks.
+ (flymake-find-possible-master-files)
+ (flymake-check-patch-master-file-buffer): Doc fixes (Bug#5488).
+
+2010-01-28 Michael Albinus <michael.albinus@gmx.de>
+
+ Fix some busybox annoyances.
+
+ * net/tramp.el (tramp-wrong-passwd-regexp): Add "Timeout, server
+ not responding." string.
+ (tramp-open-connection-setup-interactive-shell): Dump stty
+ settings. Enable "neveropen" arg for all `tramp-send-command'
+ calls. Handle "=" in variable values properly.
+ (tramp-find-inline-encoding): Raise an error, when no encoding is
+ found.
+ (tramp-wait-for-output): Check, whether PROC buffer is available.
+ Remove spurious " ^H" sequences, sent by busybox.
+ (tramp-get-ls-command): Suppress coloring, if possible.
+
+2010-01-28 Glenn Morris <rgm@gnu.org>
+
+ * vc-svn.el (vc-svn-update): Use "svn --non-interactive". (Bug#4280)
+
+ * log-edit.el (log-edit-strip-single-file-name): Add missing
+ :safe, :group, and :version tags.
+
+2010-01-27 Stephen Berman <stephen.berman@gmx.net>
+
+ * calendar/diary-lib.el (diary-unhide-everything): Handle narrowed
+ buffers. (Bug#5477)
+
+2010-01-27 David De La Harpe Golden <david@harpegolden.net>
+
+ * files.el (delete-directory): Handle moving to trash without
+ first doing recursion (Bug#5436).
+
+2010-01-26 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-hooks.el (vc-path): Mark as obsolete.
+
+2010-01-25 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-annotate.el (vc-annotate-revision-at-line): Compare file
+ names too.
+
+ * vc-bzr.el (vc-bzr-print-log): Use the more compact --line option
+ for the short log.
+ (vc-bzr-log-view-mode): Adjust regexp for the above change.
+
+2010-01-25 Mark A. Hershberger <mah@everybody.org>
+
+ * progmodes/python.el: Replace reference to obsolete c-subword-mode.
+
+ * vc-bzr.el (vc-bzr-revision-table): New function.
+
+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).
+
+2010-01-24 Dan Nicolaescu <dann@ics.uci.edu>
+
+ Remove support for adding --signoff on commit.
+ Future support will use an incompatible generic mechanism.
+ * vc-git.el (vc-git-add-signoff): Remove variable.
+ (vc-git-toggle-signoff): Remove function.
+ (vc-git-extra-menu-map): Do not bind vc-git-toggle-signoff.
+
+ * term/xterm.el (xterm-maybe-set-dark-background-mode):
+ Rename from xterm-set-background-mode. Return t if the background mode
+ was set.
+ (terminal-init-xterm): Move tty-set-up-initial-frame-faces
+ earlier, call it again in case the background mode has changed.
+
+2010-01-23 Dmitri Paduchikh <dpaduch@k66.ru> (tiny change)
+
+ * emacs-lisp/advice.el (ad-set-orig-definition): Fix typo
+ (Bug#3541).
+
+2010-01-23 Chong Yidong <cyd@stupidchicken.com>
+
+ * emacs-lisp/assoc.el (aelement): Doc fix.
+ (aput, adelete, amake): Use lexical-let (Bug#5450).
+
+2010-01-23 Stephen Leake <stephen_leake@member.fsf.org>
+
+ * progmodes/ada-mode.el (ada-in-paramlist-p): Pragma syntax
+ is the same as subprogram call, not declaration. (Bug#5435).
+
+2010-01-23 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-smb.el (tramp-smb-conf): New defcustom.
+ (tramp-smb-maybe-open-connection): Use it.
+
+2010-01-22 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-imap.el (top): Autoload needed packages. (Bug#5448)
+
+2010-01-22 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * mail/rmailmm.el (rmail-mime-handle): Don't set the buffer to unibyte
+ just because we see "encoding: 8bit".
+ * mail/rmail.el (rmail-show-message-1): Decode the body's QP into bytes.
+
+2010-01-22 Chong Yidong <cyd@stupidchicken.com>
+
+ * isearch.el (isearch-allow-scroll): Doc fix (Bug#5446).
+
+2010-01-22 Eli Zaretskii <eliz@gnu.org>
+
+ * jka-compr.el (jka-compr-load): If load-file is not in
+ load-history, try its file-truename version. (bug#5447)
+
+2010-01-21 Alan Mackenzie <acm@muc.de>
+
+ Fix a situation where deletion of a cpp construct throws an error.
+ * progmodes/cc-engine.el (c-invalidate-state-cache):
+ Before invoking c-with-all-but-one-cpps-commented-out, check that the
+ special cpp construct is still in the buffer.
+ (c-parse-state): Record the special cpp with markers, not numbers.
+
+2010-01-21 Kenichi Handa <handa@m17n.org>
+
+ * textmodes/sgml-mode.el (sgml-maybe-name-self): No need to
+ process last-command-event, as it is now decoded first (Bug#5380).
+
+2010-01-20 Chong Yidong <cyd@stupidchicken.com>
+
+ * term.el (term-send-raw-meta): Revert 2009-12-04 change (Bug#5330).
+
+2010-01-20 Glenn Morris <rgm@gnu.org>
+
+ * indent.el (tab-always-indent): Fix custom-type.
+
+2010-01-19 Alan Mackenzie <acm@muc.de>
+
+ * progmodes/cc-defs.el: Fix bug#5395: typing '#' in an empty
+ buffer throws "args out of range".
+ (c-set-cpp-delimiters, c-clear-cpp-delimiters): Check for EOB
+ playing the role of delimiter.
+
+2010-01-18 Stephen Leake <stephen_leake@member.fsf.org>
+
+ * progmodes/ada-mode.el: Fix bug#5400.
+ (ada-matching-decl-start-re): Move into ada-goto-decl-start.
+ (ada-goto-decl-start): Rename from ada-goto-matching-decl-start; callers
+ changed. Delete RECURSIVE parameter; never used. Improve doc string.
+ Improve comments in "is" portion. Handle null procedure declaration.
+ (ada-move-to-end): Improve doc string.
+
+2010-01-18 Óscar Fuentes <ofv@wanadoo.es>
+
+ * ido.el (ido-cur-list): Initialize to nil.
+ Remove obsolete information from commentary.
+ (ido-choice-list): Initialize to nil.
+ (ido-get-bufname): Reject minibuffers.
+ (ido-make-buffer-list): If "default" is a nonexistent
+ buffer, ignore it, as per the function's comment.
+ (ido-kill-buffer-internal): New function.
+ (ido-kill-buffer-at-head): Use it.
+ (ido-visit-buffer): Likewise.
+
+2010-01-18 Chong Yidong <cyd@stupidchicken.com>
+
+ * calendar/time-date.el (date-to-time): Doc fix (Bug#5408).
+
+2010-01-18 Juanma Barranquero <lekktu@gmail.com>
+
+ * emacs-lisp/chart.el (chart-file-count, chart-rmail-from):
+ Fix typos in chart titles.
+
+ * whitespace.el (whitespace-style, global-whitespace-newline-mode):
+ * emacs-lisp/eieio.el (eieio-error-unsupported-class-tags)
+ (eieio-generic-form, eieio-help-mode-augmentation-maybee, eieio-browse)
+ (describe-class, eieio-describe-generic, describe-generic):
+ * emacs-lisp/eieio-speedbar.el (eieio-speedbar-handle-click)
+ (eieio-speedbar-expand):
+ * emulation/viper-cmd.el (viper-exec-form-in-vi)
+ (viper-exec-form-in-emacs, viper-harness-minor-mode, viper-ESC)
+ (viper-repeat, viper-replace-state-exit-cmd, viper-toggle-search-style)
+ (viper-del-backward-char-in-replace, viper-backward-indent)
+ (viper-brac-function, viper-register-to-point, viper-submit-report):
+ * net/tramp.el (tramp-remote-coding-commands):
+ * term/x-win.el (emacs-session-save, x-menu-bar-open, icon-map-list):
+ Fix typos in docstrings.
+
+2010-01-17 Chong Yidong <cyd@stupidchicken.com>
+
+ * mail/sendmail.el (mail-yank-original): Set the mark if the
+ specified function for yanking does not do it.
+
+2010-01-17 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc.el (with-vc-properties): Deal with directory arguments. (Bug#5298)
+
+ * vc-dir.el (vc-dir-resynch-file): Update the vc-dir header when
+ resyncing a directory.
+
+2010-01-17 Stephen Leake <stephen_leake@member.fsf.org>
+
+ * progmodes/ada-mode.el: Fix bug#1920.
+ (ada-ident-re): Delete ., allow multibyte characters.
+ (ada-goto-label-re): New; matches goto labels.
+ (ada-block-label-re): New; matches block labels.
+ (ada-label-re): New; matches both.
+ (ada-named-block-re): Delete; callers changed to use
+ `ada-block-label-re' instead.
+ (ada-get-current-indent, ada-get-indent-noindent, ada-get-indent-loop):
+ Use `ada-block-label-re'.
+ (ada-indent-on-previous-lines): Improve handling of goto labels.
+ (ada-get-indent-block-start): Special-case block label.
+ (ada-get-indent-label): Split into `ada-indent-block-label' and
+ `ada-indent-goto-label'.
+ (ada-goto-stmt-start, ada-goto-next-non-ws):
+ Optionally ignore goto labels.
+ (ada-goto-next-word): Simplify.
+ (ada-indent-newline-indent-conditional): Insert newline before
+ trying to fix indentation; doc fix.
+
+2010-01-17 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc.el (calc-command-flags): Give it an initial value.
+
+2010-01-17 Juanma Barranquero <lekktu@gmail.com>
+
+ * files.el (minibuffer-with-setup-hook):
+ * textmodes/artist.el (artist-mt, artist-key-undraw-continously)
+ (artist-key-draw-continously, artist-key-do-continously-continously)
+ (artist-key-set-point-continously, artist-mouse-draw-continously):
+ Fix typos in docstrings.
+
+2010-01-16 Lennart Borgman <lennart.borgman@gmail.com>
+
+ * nxml/nxml-mode.el (nxml-extend-after-change-region):
+ Never return t (Bug#3898).
+
+2010-01-16 Frédéric Perrin <frederic.perrin@resel.fr> (tiny change)
+
+ * vc-dispatcher.el (vc-do-command): Set LC_MESSAGES, so that we
+ can parse the output of the external commands (Bug#5279).
+
+2010-01-16 Jari Aalto <jari.aalto@cante.net>
+
+ * pcmpl-unix.el (pcmpl-unix-read-passwd-file): Doc fix.
+
+2010-01-16 Chong Yidong <cyd@stupidchicken.com>
+
+ * emacs-lisp/advice.el (ad-add-advice): Doc fix (Bug#5274)
+
+ * emacs-lisp/cl-macs.el (defstruct): Doc fix (Bug#5267).
+
+ * startup.el (command-line): Remove unused --icon-type arg.
+ Handle --display arg, passing it to command-line-1 (Bug#5392).
+
+2010-01-16 Mario Lang <mlang@delysid.org>
+
+ * emacs-lisp/chart.el (chart-translate-namezone):
+ * textmodes/artist.el (artist-compute-popup-menu-table):
+ Remove duplicated words in doc-strings.
+
+2010-01-15 David Abrahams <dave@boostpro.com> (tiny change)
+
+ * net/mairix.el (mairix-widget-send-query): Send -1 instead of nil
+ to mairix-search to suppress threading (Bug#5342).
+
+2010-01-15 Kenichi Handa <handa@m17n.org>
+
+ * international/mule-cmds.el (canonicalize-coding-system-name):
+ Convert "msXXX", "ibmXXX", "windows-XXX" to "cpXXX" (Bug#5387).
+
+2010-01-15 Glenn Morris <rgm@gnu.org>
+
+ * log-view.el (top-level): Require 'wid-edit. (Bug#5311)
+
+ * wid-edit.el (widget-keymap): Doc fix.
+
+ * vc-svn.el (vc-svn-print-log): Use --limit rather than -l since the
+ former seems to be more widely accepted by various svn versions.
+
+2010-01-14 Juanma Barranquero <lekktu@gmail.com>
+
+ * find-cmd.el (find-constituents):
+ * vc-arch.el (vc-arch-root):
+ * window.el (window-body-height, pop-up-frames):
+ * emacs-lisp/eieio-base.el (eieio-singleton, slot-missing):
+ * progmodes/ada-stmt.el (ada-if):
+ * progmodes/gdb-ui.el (gdb-jsonify-buffer):
+ * textmodes/ispell.el (ispell-grep-options, ispell-dictionary-alist)
+ (ispell-encoding8-command, ispell-aspell-supports-utf8)
+ (ispell-last-program-name, ispell-help): Fix typos in docstrings.
+
+ * progmodes/flymake.el (flymake-post-syntax-check):
+ Fix typo in error message.
+
+2010-01-14 Juanma Barranquero <lekktu@gmail.com>
+
+ * hexl.el (hexl-printable-character): Fix check of `hexl-iso',
+ which is always a string. (Bug#5313)
+
+2010-01-14 Juanma Barranquero <lekktu@gmail.com>
+
+ * progmodes/ada-xref.el (ada-default-prj-properties):
+ Simplify previous change.
+
+2010-01-14 Stephen Leake <stephen_leake@member.fsf.org>
+
+ * progmodes/ada-xref.el (ada-default-prj-properties):
+ Default ada_project_path to $ADA_PROJECT_PATH.
+
+2010-01-14 Stephen Leake <stephen_leake@member.fsf.org>
+
+ * progmodes/ada-mode.el (ada-create-keymap):
+ Override `narrow-to-defun' with `ada-narrow-to-defun'.
+
+2010-01-14 Stephen Leake <stephen_leake@member.fsf.org>
+
+ * progmodes/ada-mode.el: Deal with Ada 2005 "overriding" keyword.
+ (ada-subprog-start-re, ada-imenu-subprogram-menu-re): Add keyword.
+ (ada-get-current-indent, ada-imenu-generic-expression)
+ (ada-which-function): Check for it.
+
+2010-01-14 Stephen Leake <stephen_leake@member.fsf.org>
+
+ * progmodes/ada-mode.el (ada-clean-buffer-before-saving): Make obsolete.
+ (ada-mode): Don't obey `ada-clean-buffer-before-saving' anymore.
+
+2010-01-14 Glenn Morris <rgm@gnu.org>
+
+ * frame.el (show-trailing-whitespace): Safe if boolean. (Bug#5312)
+
+2010-01-14 Kenichi Handa <handa@m17n.org>
+
+ * composite.el (auto-composition-mode): Make it a buffer local
+ variable (permanent-local).
+ (auto-composition-function): Set the default value to
+ auto-compose-chars.
+ (auto-composition-mode): Make it a simple function, not a minor mode.
+ (global-auto-composition-mode): Likewise.
+ (turn-on-auto-composition-if-enabled): Delete it.
+
+2010-01-13 Karl Fogel <kfogel@red-bean.com>
+
+ * bookmark.el (bookmark-bmenu-execute-deletions): Doc fix (Bug#5276).
+
+2010-01-12 Michael Albinus <michael.albinus@gmx.de>
+
+ * files.el (copy-directory): Compute target for recursive
+ directories with identical names. (Bug#5343)
+
+2010-01-12 Glenn Morris <rgm@gnu.org>
+
+ * mail/emacsbug.el (report-emacs-bug-pretest-address):
+ Set it to bug-gnu-emacs rather than emacs-pretest-bug.
+
+2010-01-11 Sam Steingold <sds@gnu.org>
+
+ * imenu.el (imenu-default-create-index-function): Detect infinite
+ loops caused by imenu-prev-index-position-function.
+
+2010-01-11 Juanma Barranquero <lekktu@gmail.com>
+
+ * htmlfontify.el (htmlfontify-load-rgb-file)
+ (htmlfontify-unload-rgb-file, hfy-fallback-colour-values)
+ (htmlfontify-manual, htmlfontify, hfy-page-header, hfy-page-footer)
+ (hfy-src-doc-link-style, hfy-src-doc-link-unstyle, hfy-link-extn)
+ (hfy-link-style-fun, hfy-index-file, hfy-instance-file)
+ (hfy-html-quote-regex, hfy-init-kludge-hook, hfy-post-html-hooks)
+ (hfy-default-face-def, hfy-etag-regex, hfy-html-quote-map)
+ (hfy-etags-cmd-alist-default, hfy-etags-bin, hfy-ignored-properties)
+ (hfy-which-etags, hfy-etags-cmd, hfy-istext-command, hfy-display-class)
+ (hfy-optimisations, hfy-tags-cache, hfy-tags-sortl, hfy-tags-rmap)
+ (hfy-style-assoc, hfy-sheet-assoc, hfy-facemap-assoc, hfy-interq)
+ (hfy-colour-vals, hfy-default-header, hfy-link-style-string)
+ (hfy-triplet, hfy-slant, hfy-weight, hfy-combined-face-spec)
+ (hfy-face-attr-for-class, hfy-face-to-style-i, hfy-size-to-int)
+ (hfy-flatten-style, hfy-face-to-style, hfy-face-or-def-to-name)
+ (hfy-face-to-css, hfy-p-to-face, hfy-p-to-face-lennart, hfy-face-at)
+ (hfy-fontified-p, hfy-merge-adjacent-spans, hfy-buffer)
+ (hfy-html-enkludge-buffer, hfy-html-quote, hfy-html-dekludge-buffer)
+ (hfy-force-fontification, htmlfontify-buffer, hfy-dirname)
+ (hfy-make-directory, hfy-text-p, hfy-mark-tag-names, hfy-relstub)
+ (hfy-href-stub, hfy-href, hfy-mark-tag-hrefs, hfy-prepare-index-i)
+ (hfy-prepare-index, hfy-prepare-tag-map, hfy-subtract-maps)
+ (htmlfontify-run-etags): Fix typos in docstrings and remove superfluous
+ backslash-quoting from parentheses, etc.
+
+2010-01-11 Chong Yidong <cyd@stupidchicken.com>
+
+ * progmodes/js.el: Autoload javascript-mode alias.
+
+2010-01-11 Juanma Barranquero <lekktu@gmail.com>
+
+ * ffap.el (ffap-shell-prompt-regexp, ffap-all-subdirs, ffap-url-p)
+ (ffap-alist, ffap-tex-path, ffap-url-at-point, ffap-gopher-regexp)
+ (ffap-gopher-at-point, ffap-file-at-point, ffap-read-file-or-url)
+ (ffap-read-url-internal, ffap-menu, ffap-at-mouse):
+ Fix typos in docstrings.
+ (ffap-url-regexp): Doc fix.
+ (ffap-at-mouse): Fix typo in message.
+
+2010-01-11 Glenn Morris <rgm@gnu.org>
+
+ * version.el (emacs-copyright): Set copyright year to 2010.
+
+2010-01-10 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * format.el (format-annotate-function): Only set
+ write-region-post-annotation-function after running to-fn so as not to
+ affect nested write-region calls (bug#5273).
+
+2010-01-10 Chong Yidong <cyd@stupidchicken.com>
+
+ * Makefile.in (ELCFILES): Add wisent/python-wy.el and
+ wisent/python.el.
+
+2010-01-09 Chong Yidong <cyd@stupidchicken.com>
+
+ * man.el (Man-goto-section): Signal error if the section is not
+ found (Bug#5317).
+
+2010-01-09 Juanma Barranquero <lekktu@gmail.com>
+
+ * vc-bzr.el (vc-bzr-working-revision): On Windows and MS-DOS, accept
+ URLs with a leading triple slash in the file: scheme. (Bug#5345)
+
+2010-01-09 Chong Yidong <cyd@stupidchicken.com>
+
+ * progmodes/compile.el: Don't treat compile-command as safe if
+ compilation-read-command might be nil (Bug#4218).
+
+2010-01-09 Jan Djärv <jan.h.d@swipnet.se>
+
+ * startup.el (command-line-1): Use orig-argi to check for ignored X and
+ NS options.
+
+2010-01-08 Kenichi Handa <handa@m17n.org>
+
+ * international/fontset.el (build-default-fontset-data):
+ Exclude characters in scripts kana, hangul, han, or cjk-misc.
+
+2010-01-07 Juanma Barranquero <lekktu@gmail.com>
+
+ * vc-dir.el (vc-dir-prepare-status-buffer): Pass a (fake) filename
+ to `create-file-buffer' as it expects, not just a buffer name.
+ (vc-dir-mode): Include the buffer name in `list-buffers-directory',
+ to help uniquify. (Bug#3224)
+
+2010-01-06 Jan Djärv <jan.h.d@swipnet.se>
+
+ * font-setting.el (font-setting-change-default-font): Use user-spec
+ instead of name.
+
+2010-01-06 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-bzr.el (vc-bzr-after-dir-status): Ignore pending merges.
+
+2010-01-05 Tom Tromey <tromey@redhat.com>
+
+ * progmodes/python.el (python-font-lock-keywords):
+ Handle qualified decorators (Bug#881).
+
+2010-01-05 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-bzr.el (vc-bzr-working-revision): Fix looking for a revision
+ in a lightweight checkout.
+
+2010-01-05 Kenichi Handa <handa@m17n.org>
+
+ * language/indian.el (malayalam-composable-pattern): Fix ZWNJ and ZWJ.
+
+2010-01-05 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-bzr.el (vc-bzr-diff): Obey vc-disable-async-diff.
+
+2010-01-04 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-bzr.el (vc-bzr-state-heuristic): Make it work for lightweight
+ checkouts. (Bug#618)
+ (vc-bzr-log-view-mode): Also highlight the author.
+ (vc-bzr-shelve-map): Change binding for vc-bzr-shelve-apply-at-point.
+ (vc-bzr-shelve-menu-map):
+ (vc-bzr-dir-extra-headers): Improve menu and tooltip text.
+ (vc-bzr-shelve-apply): Make prompt more explicit.
+
+2010-01-02 Chong Yidong <cyd@stupidchicken.com>
+
+ * net/browse-url.el (browse-url-encode-url): Don't escape commas.
+ They are valid characters in URL paths (rfc3986), and at least
+ Firefox does not understand the encoded version (Bug#3166).
+
+2010-01-02 Daniel Elliott <danelliottster@gmail.com> (tiny change)
+
+ * progmodes/octave-mod.el (octave-end-keywords)
+ (octave-block-begin-or-end-regexp, octave-block-match-alist):
+ Add "end" keyword (Bug#3061).
+ (octave-end-as-array-index-p): New function.
+ (calculate-octave-indent): Use it.
+
+2010-01-02 Karl Fogel <kfogel@red-bean.com>
+
+ * bookmark.el: Consistently put the text property on the bookmark name.
+ (bookmark-bmenu-marks-width): Bump back to 2, to include
+ annotation marks.
+ (bookmark-bmenu-hide-filenames): Adjust for above, and put the text
+ property on the bookmark name, instead of not putting it at all.
+ (bookmark-bmenu-list): Fix where we put the text property.
+
+2010-01-02 Karl Fogel <kfogel@red-bean.com>
+
+ * bookmark.el (bookmark-bmenu-save): Just depend on the new logic
+ for showing buffer modified state (as added in the previous change).
+
+2010-01-02 Karl Fogel <kfogel@red-bean.com>
+
+ * bookmark.el: Show modified state of bookmark buffer more accurately.
+ (bookmark-bmenu-list): Initialize buffer-modified-p properly.
+ (bookmark-send-edited-annotation): Mark bookmark-alist as modified.
+ (with-buffer-modified-unmodified): New macro.
+ (bookmark-bmenu-show-filenames, bookmark-bmenu-hide-filenames)
+ (bookmark-bmenu-mark, bookmark-bmenu-unmark, bookmark-bmenu-delete):
+ Use new macro to preserve the buffer modified state.
+
+2010-01-02 Karl Fogel <kfogel@red-bean.com>
+
+ * bookmark.el (bookmark-bmenu-select, bookmark-bmenu-1-window)
+ (bookmark-bmenu-2-window, bookmark-bmenu-this-window)
+ (bookmark-bmenu-other-window, bookmark-bmenu-switch-other-window)
+ (bookmark-bmenu-show-annotation, bookmark-bmenu-edit-annotation)
+ (bookmark-bmenu-rename, bookmark-bmenu-locate)
+ (bookmark-bmenu-relocate, bookmark-bmenu-goto-bookmark):
+ Remove unnecessary calls to `bookmark-bmenu-ensure-position'.
+
+2010-01-02 Eli Zaretskii <eliz@gnu.org>
+
+ * emacs-lisp/easy-mmode.el (define-globalized-minor-mode):
+ Make the lines in the generated doc string shorter. (Bug#4668)
+
+2010-01-02 Ryan Yeske <rcyeske@gmail.com>
+
+ * net/rcirc.el: Add follow-link binding (Bug#4738).
+
+2010-01-02 Eli Zaretskii <eliz@gnu.org>
+
+ * Makefile.in (bzr-update): Rename from cvs-update.
+ (cvs-update): New target for backward compatibility.
+
+ * makefile.w32-in (bzr-update): Rename from cvs-update.
+ (cvs-update): New target for backward compatibility.
+
+2010-01-02 Karl Fogel <kfogel@red-bean.com>
+
+ * bookmark.el: Remove gratuitous gratitude.
+
+2010-01-02 Karl Fogel <kfogel@red-bean.com>
+
+ * 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>
+
+ * bookmark.el (bookmark-bmenu-marks-width): Define to 1, not 2.
+ (bookmark-bmenu-list, bookmark-bmenu-bookmark): Calculate property
+ positions by using `bookmark-bmenu-marks-width', instead of hardcoding.
+ This fixes the `bookmark-bmenu-execute-deletions' bug reported here:
+
+ http://lists.gnu.org/archive/html/emacs-devel/2009-12/msg00819.html
+ From: Sun Yijiang <sunyijiang {_AT_} gmail.com>
+ To: emacs-devel {_AT_} gnu.org
+ Subject: bookmark.el bug report
+ Date: Mon, 28 Dec 2009 14:19:16 +0800
+ Message-ID: 5065e2900912272219y3734fc9fsdaee41167ef99ad7@mail.gmail.com
+
+2010-01-02 Karl Fogel <kfogel@red-bean.com>
+
+ * bookmark.el: Improvements suggested by Drew Adams:
+ (bookmark-bmenu-ensure-position): New name for
+ `bookmark-bmenu-check-position'. Just ensure the position,
+ don't return any meaningful value.
+ (bookmark-bmenu-header-height, bookmark-bmenu-marks-width):
+ New constants.
+
+2010-01-02 Juanma Barranquero <lekktu@gmail.com>
+
+ * bookmark.el (bookmarks-already-loaded): Doc fix (don't use `iff').
+ (bookmark-yank-point, bookmark-bmenu-check-position):
+ Fix typos in docstrings.
+ (bookmark-save-flag, bookmark-bmenu-toggle-filenames)
+ (bookmark-name-from-full-record, bookmark-get-position)
+ (bookmark-set-position, bookmark-set, bookmark-handle-bookmark)
+ (bookmark-delete, bookmark-save, bookmark-save, bookmark-bmenu-mode):
+ Remove useless quoting of parenthesis, etc. in docstrings.
+
+ * ediff-mult.el (ediff-prepare-meta-buffer): Fix typo in help message.
+ (ediff-append-custom-diff): Fix typo in error message.
+ (ediff-meta-mark-equal-files): Fix typos in messages.
+
+ * mpc.el (mpc-playlist-delete): Fix typo in error messages.
+
+ * net/imap-hash.el (imap-hash-make): Doc fix.
+ (imap-hash-test): Fix typo in error message; reflow docstring.
+ (imap-hash-p, imap-hash-get, imap-hash-put, imap-hash-make-message)
+ (imap-hash-count, imap-hash-server, imap-hash-port, imap-hash-ssl)
+ (imap-hash-mailbox, imap-hash-user, imap-hash-password):
+ Fix typos in docstrings.
+ (imap-hash-open-connection): Fix typo in error message.
+
+ * play/gomoku.el (gomoku): Fix typos in docstring.
+
+ * progmodes/gdb-ui.el (gdb-location-alist): Reflow docstring.
+ (gdb-jsonify-buffer): Fix typos in docstring.
+ (gdb-goto-breakpoint): Fix typo in error message.
+ ("Display Other Windows"): Fix typo in help message.
+ (gdb-speedbar-expand-node): Fix typo in question.
+
+ * progmodes/idlw-help.el (idlwave-help-browse-url-available)
+ (idlwave-html-system-help-location, idlwave-html-help-location)
+ (idlwave-help-browser-function, idlwave-help-browser-generic-program)
+ (idlwave-help-browser-generic-args, idlwave-help-directory)
+ (idlwave-html-help-is-available, idlwave-help-mode-line-indicator)
+ (idlwave-help-mode-map, idlwave-help-mode, idlwave-do-context-help)
+ (idlwave-online-help, idlwave-help-html-link)
+ (idlwave-help-show-help-frame, idlwave-help-assistant-command):
+ Fix typos in docstrings.
+ (idlwave-help-with-source, idlwave-help-find-routine-definition):
+ Reflow docstrings.
+ (idlwave-help-assistant-start): Fix typo in error message.
+
+ * progmodes/octave-mod.el (octave-mode, octave-electric-semi)
+ (octave-electric-space): Fix typos in docstrings.
+
+2010-01-01 Chong Yidong <cyd@stupidchicken.com>
+
+ * files.el (minibuffer-with-setup-hook): Doc fix (Bug#5149).
+
+2010-01-01 Juri Linkov <juri@jurta.org>
+
+ * comint.el (comint-input-ring-size): Make it a defcustom and
+ increase the default to 500 (Bug#5148).
+
+2009-12-31 Nick Roberts <nickrob@snap.net.nz>
+
+ Further changes from EMACS_23_1_RC branch (2009-12-29 contd).
+ * term/x-win.el (x-gtk-stock-map): Map some GUD buttons.
+ * progmodes/gud.el (gud-menu-map): Add reverse-execution commands.
+
+2009-12-30 Nick Roberts <nickrob@snap.net.nz>
+
+ Show working revision correctly for mercurial.
+ * vc-hg.el (vc-hg-working-revision): Use hg parent instead of
+ hg log as suggested by Alex Harsanyi <alexharsanyi@gmail.com>.
+
+2009-12-29 Juanma Barranquero <lekktu@gmail.com>
+
+ Declare some functions for the byte-compiler.
+ * progmodes/gdb-ui.el (speedbar-change-initial-expansion-list)
+ (speedbar-timer-fn, speedbar-change-expand-button-char)
+ (speedbar-delete-subblock, speedbar-center-buffer-smartly): Declare.
+
+2009-12-29 Nick Roberts <nickrob@snap.net.nz>
+
+ This changeset reverts GDB Graphical Interface to use annotations.
+ * progmodes/gdb-ui.el, progmodes/gud.el: Import from EMACS_23_1_RC.
+
+2009-12-29 Dan Nicolaescu <dann@ics.uci.edu>
+
+ Make vc-dir work on subdirectories of the bzr root.
+ * vc-bzr.el (vc-bzr-after-dir-status): Add new argument.
+ Return file names relative to it.
+ (vc-bzr-dir-status, vc-bzr-dir-status-files): Pass the bzr root
+ relative directory to vc-bzr-after-dir-status.
+
+2009-12-28 Tassilo Horn <tassilo@member.fsf.org>
+
+ * font-lock.el (font-lock-refresh-defaults): New function, which
+ can be used to let font-lock react to external changes in
+ variables like font-lock-defaults and keywords.
+ See http://thread.gmane.org/gmane.emacs.devel/118777/focus=118802
+
+2009-12-28 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-rcs.el (vc-rcs-register): Fix registering a specific version.
+
+ * vc-bzr.el (vc-bzr-log-view-mode): Fix short log regexp.
+
+2009-12-28 Juanma Barranquero <lekktu@gmail.com>
+
+ Supersede color.diff settings in git log (bug#5211).
+
+ * vc-git.el (vc-git-print-log): Pass "--no-color" to log to avoid
+ escape chars in its output when the user has color.diff set to `always'.
+ This fix works on git 1.4.2 and newer (released on 2006-08-13).
+
+2009-12-26 Kevin Ryde <user42@zip.com.au>
+
+ * info-look.el (sh-mode): Look for coreutils new "Concept Index"
+ node. Keep previous "Index" name to work with past coreutils too.
+
+ * man.el (man): Revise docstring a bit to show -a and -l as
+ examples. Add -k description since support for it has otherwise
+ been a secret. (Further to bug#3717.)
+ (Man-bgproc-sentinel): When "-k foo" produces no output show error
+ "no matches" rather than "Can't find manpage", as the latter reads
+ like -k was interpreted as a page name, which is not so. (Bug#5431)
+
+2009-12-26 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-handle-insert-directory): Quote "'" in the
+ switches. Check also for //SUBDIRED// line.
+
+2009-12-25 Kenichi Handa <handa@m17n.org>
+
+ * language/indian.el (devanagari-composable-pattern): Fix to
+ handle ZWNJ and ZWJ. Use it in composition-function-table for
+ Devanagari.
+ (malayalam-composable-pattern): Fix previous change.
+
+2009-12-23 Vinicius Jose Latorre <viniciusjl@ig.com.br>
+
+ * ps-print.el (ps-face-attributes): It was not returning the
+ attribute face for faces specified as string. Reported by harven
+ <harven@free.fr>. (Bug#5254)
+ (ps-print-version): New version 7.3.5.
+
+2009-12-18 Ulf Jasper <ulf.jasper@web.de>
+
+ * calendar/icalendar.el (icalendar--convert-tz-offset):
+ Fix timezone names.
+ (icalendar--convert-tz-offset): Fix the "last-day-problem".
+ (icalendar--add-diary-entry): Remove the trailing blank that
+ diary-make-entry inserts.
+
+2009-12-17 Michael Albinus <michael.albinus@gmx.de>
+
+ Make `file-expand-wildcards' work for remote files.
+
+ * files.el (file-expand-wildcards): In case of remote files, check
+ only local file name part for wildcards. Provide feature 'files
+ and subfeature 'remote-wildcards. (Bug#5198)
+
+ * net/tramp.el (tramp-handle-file-remote-p): Expand file name only
+ if there is already an established connection.
+ (tramp-advice-file-expand-wildcards): Remove it.
+
+ * net/tramp-compat.el (top): Autoload `tramp-handle-file-remote-p'.
+ (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>
+
+ Some doc fixes (more needed).
+
+ * find-cmd.el (find-constituents): Reflow docstring.
+ (find-cmd, find-prune, find-command): Fix typos in docstrings.
+ (find-generic): Doc fix.
+
+2009-12-17 Juri Linkov <juri@jurta.org>
+
+ Fix regression from 23.1 to allow multiple modes in Local Variables.
+
+ * files.el (hack-local-variables-filter): While ignoring duplicates,
+ don't take `mode' into account.
+ (hack-local-variables-filter, hack-dir-local-variables):
+ Don't remove duplicate `mode' from local-variables-alist (like `eval').
+
+2009-12-17 Juri Linkov <juri@jurta.org>
+
+ 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.
+
+2009-12-17 Andreas Schwab <schwab@linux-m68k.org>
+
+ * emacs-lisp/autoload.el (batch-update-autoloads): Only exclude
+ unconditionally preloaded files.
+
+2009-12-16 Juri Linkov <juri@jurta.org>
+
+ Revert to old 23.1 logic of using the file at the mark as default.
+ * dired-aux.el (dired-diff): Use the file at the mark as default
+ if it's not the same as the current file, and the target dir is
+ the current dir or the mark is active. Add the current file
+ as the arg of `dired-dwim-target-defaults'. Use the default file
+ in the prompt. (Bug#5225)
+
+2009-12-15 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-echo-mark-marker-length): New defconst.
+ (tramp-echo-mark, tramp-echoed-echo-mark-regexp): Use it.
+ (tramp-check-for-regexp): Check also, when an echoing shell stops
+ to echo sent commands.
+
+2009-12-14 Chong Yidong <cyd@stupidchicken.com>
+
+ * Makefile.in: Revert last change (Bug#5191).
+
+2009-12-14 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-hg.el (vc-hg-print-log): Fix argument order.
+ (vc-hg-working-revision): Make sure the command is executed in a
+ known environment so that we can parse the output. (Bug#4417)
+
+2009-12-14 Chong Yidong <cyd@stupidchicken.com>
+
+ * progmodes/python.el (python-symbol-completions): Remove text
+ properties from symbol string before calling python-send-receive.
+
+2009-12-14 Nick Roberts <nickrob@snap.net.nz>
+
+ * progmodes/gdb-mi.el (gdb-frame-handler): Only set gud-lat-frame
+ when there are values for both file and line. (Bug#5060)
+
+2009-12-14 Juri Linkov <juri@jurta.org>
+
+ * ediff-ptch.el (ediff-context-diff-label-regexp): Don't match
+ whitespace after the file name of the first line of unified format,
+ because git-diff doesn't output whitespace and file modification time
+ after the file name.
+
+2009-12-14 David Kastrup <dak@gnu.org>
+
+ * info.el (Info-hide-cookies-node): Before hiding a cookie,
+ check if it already has the `display' property added by
+ `Info-display-images-node', and not put the `invisible' property
+ in this case.
+
+2009-12-13 Glenn Morris <rgm@gnu.org>
+
+ * mail/emacsbug.el (message-sort-headers): Define for compiler.
+ (report-emacs-bug): In message-mode, sort manually before storing
+ original report text. (Bug#5178)
+ Remove superfluous save-excursion.
+
+2009-12-12 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/dbus.el (dbus-property-handler): Filter lambda forms out
+ when responding to "GetAll" properties.
+
+2009-12-12 Chong Yidong <cyd@stupidchicken.com>
+
+ * simple.el (compose-mail): Remove mail-setup-with-from from
+ customization checks.
+
+2009-12-12 Eli Zaretskii <eliz@gnu.org>
+
+ * arc-mode.el (archive-rar-summarize): Support Attribute fields in
+ RAR archives created on Unix systems.
+
+2009-12-12 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * minibuffer.el (minibuffer-local-must-match-filename-map): Re-instate
+ the varalias that was accidentally removed by the 2009-11-19 change
+ (bug#5186).
+
+2009-12-12 Kenichi Handa <handa@m17n.org>
+
+ * language/indian.el (indian-compose-regexp): New function.
+ (malayalam-composable-pattern): Fix the pattern.
+ (composition-function-table): Set malayalam-composable-pattern for
+ Malayalam characters.
+
+2009-12-11 Chong Yidong <cyd@stupidchicken.com>
+
+ * progmodes/bug-reference.el (bug-reference-map): Bind mouse-2
+ rather than down-mouse-1, based on follow-link conventions.
+
+ * makefile.w32-in: Ensure that Lisp files in CEDET subdirectories
+ are compiled.
+
+2009-12-11 Michael McNamara <mac@mail.brushroad.com>
+
+ * progmodes/verilog-mode.el (verilog-vmm-begin-re, verilog-vmm-end-re)
+ (verilog-vmm-statement-re, verilog-ovm-statement-re)
+ (verilog-defun-level-not-generate-re, verilog-calculate-indent)
+ (verilog-leap-to-head, verilog-backward-token):
+ Fix indenting VMM macros. Reported by Jonathan Ashbrook.
+
+2009-12-11 Wilson Snyder <wsnyder@wsnyder.org>
+
+ * progmodes/verilog-mode.el (verilog-auto-lineup)
+ (verilog-nameable-item-re): Cleanup user-visible spelling and
+ documentation errors. One reported by Gary Delp.
+ (verilog-submit-bug-report): Mention bug tracking and CC co-author.
+ (verilog-read-decls): Fix AUTOWIRE with types declared in a
+ package, bug195. Reported by Pierre-David Pfister.
+
+2009-12-11 Glenn Morris <rgm@gnu.org>
+
+ * progmodes/cc-engine.el (safe-pos-list): Define for compiler.
+
+ * mail/emacsbug.el: No longer require sendmail.
+ Replace sendmail's `mail-text' by `rfc822-goto-eoh'. (Bug#5174)
+ (report-emacs-bug-orig-text): Doc fix.
+ (report-emacs-bug-send-command, report-emacs-bug-send-hook):
+ New local variables, to adapt to different mail-user-agents.
+ (report-emacs-bug): Fix test for a gnu.org address.
+ Use overlays for emphasis, since font-lock defeats 'face property.
+ Pretest bugs also end up at the newsgroup these days.
+ Stop message-mode stripping text properties.
+ Set and use the new buffer-local variables.
+ (report-emacs-bug-hook): Add doc-string.
+ Remove some unnecessary save-excursions and simplify.
+ Use the appropriate hook and send-command.
+
+ * emacs-lisp/lisp-mode.el (emacs-lisp-mode-map): Standardize the
+ capitalization of some menu entries.
+
+2009-12-10 Vinicius Jose Latorre <viniciusjl@ig.com.br>
+
+ * whitespace.el (whitespace-display-char-on):
+ Ensure `buffer-display-table' is unique when two or more windows are
+ visible. Reported by Martin Pohlack <mp26@os.inf.tu-dresden.de>.
+ New version 12.1.
+
+2009-12-10 Eli Zaretskii <eliz@gnu.org>
+
+ * arc-mode.el (archive-rar-summarize): Allow between 6 and 7
+ characters in the Attribute field.
+
+2009-12-10 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-svn.el (vc-svn-after-dir-status): Fix regexp. (Bug#4741)
+
+2009-12-10 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Let loaddefs.el adjust to changes in autoload-excludes (bug#5162).
+ * emacs-lisp/autoload.el (autoload-generate-file-autoloads):
+ Disregard autoload-excludes.
+ (update-directory-autoloads): Obey autoload-excludes here instead.
+ But don't store its contents in no-autoloads and remove entries that
+ refer to excludes files.
+
+2009-12-10 Glenn Morris <rgm@gnu.org>
+
+ * mail/feedmail.el (top-level): Move require 'mail-utils to start.
+ (expand-mail-aliases): Define for compiler.
+
+ * vc-annotate.el (log-view-vc-backend, log-view-vc-fileset):
+ Define for compiler.
+
+ * mail/emacsbug.el (report-emacs-bug): Use whichever send command is
+ appropriate for the mail-user-agent in use.
+
+2009-12-09 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-handle-insert-directory): Suppress error messages.
+
+2009-12-09 Dan Nicolaescu <dann@ics.uci.edu>
+
+ Fix short log parsing and fontification.
+ * vc-bzr.el (vc-bzr-log-view-mode): Match dot in revision number.
+ Fix fontification for the [merge] label.
+
+2009-12-09 Vivek Dasmohapatra <vivek@etla.org>
+
+ Drop some properties to avoid surprises (bug#5002).
+ * htmlfontify.el (hfy-ignored-properties): New defcustom.
+ (hfy-fontify-buffer): Use it.
+
+2009-12-09 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Minor cleanup.
+ * ffap.el (ffap-symbol-value): Replace ffap-soft-value.
+ Adjust all callers.
+ (ffap-locate-file): Remove unused arg `dir-ok' and make other
+ args compulsory. Adjust callers.
+ (ffap-gopher-at-point): Remove unused var `name'.
+
+ Get rid of the ELCFILES abomination.
+ * Makefile.in (update-elclist, ELCFILES, compile-last): Remove.
+ (compile-elcfiles): New phony target.
+ (compile-main): Compute ELCFILES dynamically.
+ (compile-clean): New target to remove left-over elc files.
+ (compile, all): Use it.
+
+2009-12-09 Kenichi Handa <handa@etlken>
+
+ * international/mule-diag.el: Require help-mode instead of help-fns.
+
+2009-12-09 Kenichi Handa <handa@m17n.org>
+
+ * international/mule-cmds.el (ucs-names): Supply sufficiently
+ fine ranges instead of pre-calculating accurate ranges.
+ Iterate with bigger gc-cons-threshold.
+
+2009-12-08 Dan Nicolaescu <dann@ics.uci.edu>
+
+ Add support for stashing a snapshot of the current tree.
+ * vc-git.el (vc-git-stash-snapshot): New function.
+ (vc-git-stash-map, vc-git-extra-menu-map): Add a mapping for it.
+
+2009-12-08 Jose E. Marchesi <jemarch@gnu.org>
+
+ * play/gomoku.el (gomoku-mode-map): Remap `move-(beginning|end)-of-line'
+ instead of `(beginning|end)-of-line'.
+
+2009-12-08 Glenn Morris <rgm@gnu.org>
+
+ * vc-mtn.el (vc-mtn-print-log): Fix typo in previous.
+
+ * Makefile.in (ELCFILES): Regenerate.
+
+2009-12-07 Juri Linkov <juri@jurta.org>
+
+ Don't lazy-highlight the comint output in history Isearch mode.
+
+ * comint.el (comint-history-isearch-search): Instead of
+ `comint-line-beginning-position', use `comint-after-pmark-p'
+ to check if point if before the process mark, and go to
+ `process-mark' in this case.
+
+2009-12-07 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * textmodes/tex-mode.el (latex-complete)
+ (latex-indent-or-complete): Remove.
+ (latex-mode): Set completion-at-point-functions instead.
+
+ Provide a standard completion command and hook it into TAB.
+ * minibuffer.el (completion-at-point-functions): New var.
+ (completion-at-point): New command.
+ * indent.el (indent-for-tab-command): Handle the `complete' behavior.
+ * progmodes/python.el (python-mode-map): Use completion-at-point.
+ (python-completion-at-point): Rename from python-partial-symbol and
+ adjust for use in completion-at-point-functions.
+ (python-mode): Setup completion-at-point for Python completion.
+ * emacs-lisp/lisp.el (lisp-completion-at-point): New function
+ extracted from lisp-complete-symbol.
+ (lisp-complete-symbol): Use it.
+ * emacs-lisp/lisp-mode.el (emacs-lisp-mode): Use define-derived-mode,
+ setup completion-at-point for Elisp completion.
+ (emacs-lisp-mode-map, lisp-interaction-mode-map):
+ Use completion-at-point.
+ * ielm.el (ielm-map): Use completion-at-point.
+ (inferior-emacs-lisp-mode): Setup completion-at-point-functions.
+ * progmodes/sym-comp.el: Move to...
+ * obsolete/sym-comp.el: Move from progmodes.
+
+2009-12-07 Eli Zaretskii <eliz@gnu.org>
+
+ Prevent save-buffer in Rmail buffers from using the coding-system
+ of the current message, and from clobbering the encoding mnemonics
+ in the mode line (Bug#4623).
+
+ * mail/rmail.el (rmail-swap-buffers): Swap encoding and modified
+ flag, too.
+ (rmail-message-encoding): New variable.
+ (rmail-write-region-annotate): Record the encoding of the current
+ message in rmail-message-encoding.
+ (rmail-after-save-hook): New function, restores the encoding of
+ the current message after the message collection is saved.
+
+2009-12-07 Juri Linkov <juri@jurta.org>
+
+ * progmodes/grep.el (grep-read-files): Use `completing-read'
+ instead of `read-string'. Set its `collection' arg to
+ `read-file-name-internal'. (Bug#4301)
+
+2009-12-07 Juri Linkov <juri@jurta.org>
+
+ Correctly restore original Isearch point. (Bug#4994)
+
+ * isearch.el (isearch-mode): Move `isearch-push-state' after
+ `(run-hooks 'isearch-mode-hook)'.
+ (isearch-cancel): When `isearch-push-state-function' is defined,
+ let-bind `isearch-cmds' to the first state (the last element of
+ `isearch-cmds') and call `isearch-top-state' (it calls pop-state
+ function and restores the original point). Otherwise, move point
+ to `isearch-opoint'.
+
+2009-12-07 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * international/mule-cmds.el (ucs-names): Weed out at compile-time the
+ chars that don't have names, so the table can be built much faster at
+ run-time.
+
+2009-12-07 Chong Yidong <cyd@stupidchicken.com>
+
+ * vc-bzr.el (vc-bzr-annotate-command): More elegant form for last
+ change. Suggested by David Kastrup.
+
+ * simple.el (compose-mail): Check for incompatibilities and warn.
+ (compose-mail-user-agent-warnings): New option.
+
+2009-12-07 Dan Nicolaescu <dann@ics.uci.edu>
+
+ Support showing a single log entry from vc-annotate.
+ * vc.el (print-log): Add a new argument: START-REVISION.
+ (vc-print-log-internal): Add a new optional argument and
+ pass it to the backend.
+ (vc-print-log, vc-print-root-log): Adjust callers.
+ * vc-annotate.el (vc-annotate-show-log-revision-at-line): If a
+ buffer already displays the requested log entry, use it.
+ Otherwise display only the log entry in question.
+ * vc-svn.el (vc-svn-print-log):
+ * vc-mtn.el (vc-mtn-print-log):
+ * vc-hg.el (vc-hg-state):
+ * vc-git.el (vc-git-print-log): Add support for new argument START-REVISION.
+ (vc-git-show-log-entry): Return t on success.
+ * vc-bzr.el (vc-bzr-print-log): Add support new argument START-REVISION.
+ (vc-bzr-show-log-entry): Return t on success.
+ * vc-rcs.el (vc-rcs-print-log):
+ * vc-sccs.el (vc-sccs-print-log):
+ * vc-cvs.el (vc-cvs-print-log): Add new argument, ignore it.
+
+2009-12-07 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * ediff-mult.el (ediff-setup-meta-map, ediff-prepare-meta-buffer):
+ Add menus to the meta mode. (Bug#5043)
+
+2009-12-07 Michael Kifer <kifer@cs.stonybrook.edu>
+
+ * ediff-init.el (ediff-event-key): Use event-to-character instead of
+ event-key.
+
+ * ediff.el (ediff-buffers-internal): Add unwind-protect.
+
+2009-12-07 Michael Albinus <michael.albinus@gmx.de>
+
+ Handle prompt rules of ksh in OpenBSD 4.5. Reported by Raphaël
+ Berbain <raphael.berbain@gmail.com>.
+
+ * net/tramp.el (tramp-end-of-output): Move up. Use `#' and `$'
+ characters.
+ (tramp-initial-end-of-output): New defconst.
+ (tramp-methods, tramp-find-shell)
+ (tramp-open-connection-setup-interactive-shell)
+ (tramp-maybe-open-connection): Use it.
+ (tramp-shell-prompt-pattern, tramp-wait-for-output):
+ Handle existence of `#' and `$'.
+
+ * net/tramp-fish.el (tramp-fish-maybe-open-connection):
+ Use `tramp-initial-end-of-output'.
+
+2009-12-07 Dan Nicolaescu <dann@ics.uci.edu>
+
+ Get the background mode from the terminal for xterm, and set
+ faces accordingly.
+ * term/xterm.el (xterm-set-background-mode): New function.
+ (terminal-init-xterm): Use it in case xterm supports background
+ color queries. Recompute faces after getting the background
+ color.
+
+2009-12-07 Ulrich Mueller <ulm@gentoo.org>
+
+ * emacs-lisp/bytecomp.el (byte-compile-insert-header): Put the version
+ number comment back on its own line, for easier parsing.
+
+2009-12-07 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Make it work for non-file buffers (bug#5102).
+ * doc-view.el (doc-view-current-cache-dir):
+ Use doc-view-buffer-file-name rather than buffer-file-name.
+ (doc-view-mode): Use buffer-name when buffer-file-name is nil.
+
+2009-12-06 Óscar Fuentes <ofv@wanadoo.es>
+
+ * vc-bzr.el (vc-bzr-annotate-command): Handle the case where the
+ author field is too short.
+
+2009-12-06 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-git.el (vc-git-print-log): Handle a limit argument.
+ Display the short log in graph form and with labels.
+ (vc-git-log-view-mode): Handle labels.
+
+ Make vc-revert change VC state from 'added to 'unregistered.
+ * vc-git.el (vc-git-revert): Call git reset first.
+
+2009-12-06 Ulf Jasper <ulf.jasper@web.de>
+
+ * net/newst-backend.el, net/newst-plainview.el:
+ * net/newst-reader.el, net/newst-ticker.el:
+ * net/newst-treeview.el, net/newsticker.el:
+ Require/provide newst-... (instead of newsticker-...). (Bug#5096)
+
+2009-12-06 Chong Yidong <cyd@stupidchicken.com>
+
+ * log-view.el (log-view-mode-map): Bind "=" to log-view-diff too.
+
+ * vc-bzr.el (vc-bzr-annotate-command): Show author in annotation.
+ Handle empty author field (Bug#4144). Suggested by Óscar Fuentes.
+ (vc-bzr-annotate-time, vc-bzr-annotate-extract-revision-at-line):
+ Update annotation regexp.
+
+ * simple.el (beginning-of-visual-line): Constrain to field
+ boundaries (Bug#5106).
+
+2009-12-06 Ulf Jasper <ulf.jasper@web.de>
+
+ * xml.el (xml-substitute-numeric-entities):
+ Move newsticker--decode-numeric-entities in newst-backend.el to
+ xml-substitute-numeric-entities in xml.el. (Bug#5008)
+ * net/newst-backend.el (newsticker--parse-generic-feed)
+ (newsticker--parse-generic-items)
+ (newsticker--decode-numeric-entities):
+ Move newsticker--decode-numeric-entities in newst-backend.el to
+ xml-substitute-numeric-entities in xml.el. (Bug#5008)
+
+2009-12-06 Daniel Colascione <dan.colascione@gmail.com>
+
+ * progmodes/js.el (js--js-not): Add null to the list of values.
+
+2009-12-06 Chong Yidong <cyd@stupidchicken.com>
+
+ * ansi-color.el (ansi-color-for-comint-mode): Add :version keyword.
+
+2009-12-06 Roland Winkler <Roland.Winkler@physik.uni-erlangen.de>
+
+ * textmodes/bibtex.el (bibtex-enclosing-field): Exclude entry
+ delimiter if it is at the end of the current line.
+ (bibtex-generate-url-list): Fix docstring.
+
+2009-12-06 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * minibuffer.el (minibuffer-complete-and-exit): Don't replace the
+ minibuffer's content with itself.
+ Fold the confirm-after-completion case into the `confirm' case.
+ (completion-pcm-word-delimiters): Add : and / to the delimiters.
+
+2009-12-06 Kevin Ryde <user42@zip.com.au>
+
+ * ffap.el (ffap-rfc-path): Make this a defcustom since
+ `ffap-rfc-directories' is also a defcustom. (Bug#4514.)
+
+ * info-look.el: Add setup for apropos-mode to use emacs-lisp-mode
+ manuals, similar to existing setup for help-mode. (Bug#3913.)
+
+2009-12-05 Juri Linkov <juri@jurta.org>
+
+ Save and restore dired buffer's point positions too. (Bug#4880)
+
+ * dired.el (dired-save-positions): Return in the first element
+ buffer's position in format (BUFFER DIRED-FILENAME BUFFER-POINT).
+ Doc fix.
+ (dired-restore-positions): First restore buffer's position.
+ While restoring window's positions, check if window still displays
+ the original buffer.
+
+2009-12-05 Chong Yidong <cyd@stupidchicken.com>
+
+ * bindings.el (complete-symbol): Call semantic-ia-complete-symbol
+ if possible.
+
+ * shell.el (shell): Require ansi-color (Bug#5113).
+
+ * ansi-color.el (ansi-color-for-comint-mode): Default to t.
+
+ * hl-line.el (global-hl-line-highlight): Minor doc fix (Bug#4925).
+
+2009-12-05 Alan Mackenzie <acm@muc.de>
+
+ * progmodes/cc-mode.el (c-before-hack-hook)
+ (c-postprocess-file-styles): Revert change 2009-07-18T21:03:43Z!acm@muc.de to permit
+ `c-file-style' to work again. This reversion restores the current
+ software to its state in Emacs 23.1. (Bug#4146)
+
+2009-12-05 Kevin Ryde <user42@zip.com.au>
+
+ * textmodes/sgml-mode.el (sgml-lexical-context):
+ Recognise comment-start-skip to comment-end-skip as comment (Bug#4781).
+
+2009-12-05 Juri Linkov <juri@jurta.org>
+
+ * info.el (Info-find-node-2): Set `Info-current-subfile' to nil
+ for virtual nodes. (Bug#4147)
+ (Info-find-node-2): Set `Info-current-node-virtual' to nil
+ when moving from a virtual node.
+ (Info-mode-menu): Add `Info-virtual-index' to the menu.
+ (Info-mode): Add `Info-virtual-index' to the docstring.
+
+2009-12-05 Roland Winkler <Roland.Winkler@physik.uni-erlangen.de>
+
+ * textmodes/bibtex.el (bibtex-map-entries): Use marker to keep
+ track of the buffer position of the end of a BibTeX entry as this
+ position may change during reformatting.
+ (bibtex-format-entry): Remove whitespace before processing
+ numerical fields so that we recognize the latter properly.
+ (bibtex-reformat): Do not use push which changes the global value
+ of bibtex-entry-format.
+ (bibtex-field-braces-alist, bibtex-field-strings-alist)
+ (bibtex-field-re-init): Replace only space characters by regexp
+ for whitespace.
+ (bibtex-generate-url-list, bibtex-cite-matcher-alist): Fix docstring.
+ (bibtex-initialize): Also update bibtex-strings.
+ (bibtex-kill-field): Preserve white space at end of entry.
+ (bibtex-kill-entry, bibtex-yank-pop, bibtex-insert-kill):
+ Update bibtex-reference-keys.
+
+2009-12-05 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * minibuffer.el (completion-pcm--merge-try): Also consider placing
+ point after a star, if that's the only place where modifications can
+ make progress.
+
+2009-12-05 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-dir.el (vc-dir): Use the correct markup for showing keymaps
+ in docstrings.
+
+2009-12-04 Juri Linkov <juri@jurta.org>
+
+ * proced.el (proced): Call `(proced-update t)' to update process
+ information instead of only running proced-post-display-hook.
+ (proced-send-signal): Add a leading space to the buffer name
+ " *Marked Processes*" to make this buffer ephemeral.
+
+2009-12-04 Juri Linkov <juri@jurta.org>
+
+ * dired.el (dired-auto-revert-buffer): New defcustom.
+ (dired-internal-noselect): Use it.
+
+2009-12-04 Juri Linkov <juri@jurta.org>
+
+ Change roles of modes and functions in image-mode.el (Bug#5062).
+
+ * image-mode.el: Replace `image-mode-maybe' with `image-mode'
+ in `auto-mode-alist'.
+ (image-mode-previous-major-mode): New variable.
+ (image-minor-mode-map): Rename from `image-mode-text-map'.
+ (image-mode): Move graceful error-handling code from
+ `image-minor-mode' to here. On errors call `image-mode-as-text'.
+ (image-minor-mode): Remove all image-handling code.
+ Replace `image-mode-text-map' with `image-minor-mode-map'.
+ Check for `image-type' in mode-line format string.
+ (image-mode-maybe): Make obsolete with an alias to `image-mode'.
+ (image-mode-as-text): New function with most code from
+ `image-mode-maybe'.
+ (image-toggle-display-text): Move code that removes image
+ properties from `image-toggle-display' to here.
+ (image-toggle-display-image): New function with code that adds
+ image properties copied from `image-toggle-display'.
+ (image-toggle-display): Remove most code with leaving only code
+ that toggles between `image-mode-as-text' and `image-mode'.
+
+2009-12-04 Ulf Jasper <ulf.jasper@web.de>
+
+ * net/newst-treeview.el
+ (newsticker--treeview-list-highlight-start): Restored call to
+ save-excursion: Selected item was stuck.
+ (newsticker--treeview-list-select): New.
+ (newsticker--treeview-item-show-text)
+ (newsticker--treeview-item-show)
+ (newsticker--treeview-item-update): Use new
+ newsticker-treeview-item-mode.
+ (newsticker-treeview-update): Keep current item.
+ (newsticker-treeview-next-new-or-immortal-item): Doc change.
+ (newsticker--treeview-first-feed): Doc change.
+ (newsticker-treeview-list-menu)
+ (newsticker-treeview-item-menu): Add menu entries.
+ (newsticker-treeview-item-mode): New.
+
+ * net/newst-backend.el (newsticker-customize): Delete other
+ windows.
+
+2009-12-04 Sam Steingold <sds@gnu.org>
+
+ * log-view.el (log-view-mode-map): "q" calls quit-window,
+ like in all the other non-self-insert buffers.
+
+2009-12-04 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Minor cleanup.
+ * term.el (term-send-raw, term-send-raw-meta): Use read-key-sequence's
+ key decoding rather than do it manually via last-input-event +
+ ascii-character.
+ (term-exec): Use delete-and-extract-region.
+ (term-handle-ansi-terminal-messages): Remove unused var `end'.
+ (term-process-pager): Remove unused var `i'.
+ (term-dynamic-simple-complete): Make obsolete.
+ (serial-update-config-menu): Remove unused vars `y' and `str'.
+ (term-update-mode-line): Remove unused var `temp'.
+
+2009-12-03 Dan Nicolaescu <dann@ics.uci.edu>
+
+ Limit the number of log entries displayed by default.
+ * vc.el (vc-print-log-internal): Fix check for limit-unsupported.
+ (vc-print-log, vc-print-root-log): Use vc-log-show-limit when not
+ using a prefix argument.
+
+2009-12-03 Glenn Morris <rgm@gnu.org>
+
+ * progmodes/idlwave.el (class): Restore still useful declaration.
+
+2009-12-03 Alan Mackenzie <acm@muc.de>
+
+ Enhance `c-parse-state' to run efficiently in "brace deserts".
+
+ * progmodes/cc-mode.el (c-basic-common-init):
+ Call c-state-cache-init.
+ (c-neutralize-syntax-in-and-mark-CPP): Rename from
+ c-extend-and-neutralize-syntax-in-CPP. Mark each CPP construct by
+ placing `category' properties value 'c-cpp-delimiter at its boundaries.
+
+ * progmodes/cc-langs.el (c-before-font-lock-function):
+ c-extend-and-neutralize-syntax-in-CPP has been renamed
+ c-neutralize-syntax-in-and-mark-CPP.
+
+ * progmodes/cc-fonts.el (c-cpp-matchers): Mark template brackets
+ with `category' properties now, not `syntax-table' ones.
+
+ * progmodes/cc-engine.el (c-syntactic-end-of-macro): A new
+ enhanced (but slower) version of c-end-of-macro that won't land
+ inside a literal or on another awkward character.
+ (c-state-cache-too-far, c-state-cache-start)
+ (c-state-nonlit-pos-interval, c-state-nonlit-pos-cache)
+ (c-state-nonlit-pos-cache-limit, c-state-point-min)
+ (c-state-point-min-lit-type, c-state-point-min-lit-start)
+ (c-state-min-scan-pos, c-state-brace-pair-desert)
+ (c-state-old-cpp-beg, c-state-old-cpp-end): New constants and
+ buffer local variables.
+ (c-state-literal-at, c-state-lit-beg)
+ (c-state-cache-non-literal-place, c-state-get-min-scan-pos)
+ (c-state-mark-point-min-literal, c-state-cache-top-lparen)
+ (c-state-cache-top-paren, c-state-cache-after-top-paren)
+ (c-get-cache-scan-pos, c-get-fallback-scan-pos)
+ (c-state-balance-parens-backwards, c-parse-state-get-strategy)
+ (c-renarrow-state-cache)
+ (c-append-lower-brace-pair-to-state-cache)
+ (c-state-push-any-brace-pair, c-append-to-state-cache)
+ (c-remove-stale-state-cache)
+ (c-remove-stale-state-cache-backwards, c-state-cache-init)
+ (c-invalidate-state-cache-1, c-parse-state-1)
+ (c-invalidate-state-cache): New defuns/defmacros/defsubsts.
+ (c-parse-state): Enhance and refactor.
+ (c-debug-parse-state): Amend to deal with all the new variables.
+
+ * progmodes/cc-defs.el (c-<-as-paren-syntax, c-mark-<-as-paren)
+ (c->-as-paren-syntax, c-mark->-as-paren, c-unmark-<->-as-paren):
+ modify to use category text properties rather than syntax-table ones.
+ (c-suppress-<->-as-parens, c-restore-<->-as-parens): New defsubsts
+ to switch off/on the syntactic paren property of C++ template
+ delimiters using the category property.
+ (c-with-<->-as-parens-suppressed): Macro to invoke code with
+ template delims suppressed.
+ (c-cpp-delimiter, c-set-cpp-delimiters, c-clear-cpp-delimiters):
+ New constant/macros which apply category properties to the start
+ and end of preprocessor constructs.
+ (c-comment-out-cpps, c-uncomment-out-cpps): Defsubsts which
+ "comment out" the syntactic value of characters in preprocessor
+ constructs.
+ (c-with-cpps-commented-out)
+ (c-with-all-but-one-cpps-commented-out): Macros to invoke code
+ with characters in all or all but one preprocessor constructs
+ "commented out".
+
+2009-12-03 Roland Winkler <Roland.Winkler@physik.uni-erlangen.de>
+
+ * proced.el (proced-filter-alist): Use regexp-quote.
+
+2009-12-03 Michael Albinus <michael.albinus@gmx.de>
+
+ Cleanup.
+ * eshell/em-unix.el (top): Require 'esh-opt and 'pcomplete.
+ (eshell/su, eshell/sudo): Require 'tramp. Fix problems reading
+ arguments. Expand `default-directory'.
+
+ * net/tramp.el (tramp-handle-file-remote-p): Expand FILENAME for
+ the benefit of returning an expanded localname.
+ (tramp-tramp-file-p): Handle the case NAME is not a string.
+
+2009-12-03 Dan Nicolaescu <dann@ics.uci.edu>
+
+ Add support for bzr shelve/unshelve.
+ * vc-bzr.el (vc-bzr-shelve-map, vc-bzr-shelve-menu-map)
+ (vc-bzr-extra-menu-map): New variables.
+ (vc-bzr-extra-menu, vc-bzr-extra-status-menu, vc-bzr-shelve)
+ (vc-bzr-shelve-apply, vc-bzr-shelve-list)
+ (vc-bzr-shelve-get-at-point, vc-bzr-shelve-delete-at-point)
+ (vc-bzr-shelve-apply-at-point, vc-bzr-shelve-menu): New functions.
+ (vc-bzr-dir-extra-headers): Display shelves.
+
+ * vc-bzr.el (vc-bzr-print-log): Deal with nil arguments better.
+
+2009-12-03 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * textmodes/bibtex.el (bibtex-complete-internal):
+ Use completion-in-region.
+ (bibtex-text-in-field-bounds): Remove unused var `opoint'.
+
+2009-12-03 Dan Nicolaescu <dann@ics.uci.edu>
+
+ Support applying stashes. Improve UI.
+ * vc-git.el (vc-git-dir-extra-headers): Add tooltips.
+ (vc-git-stash-apply, vc-git-stash-pop)
+ (vc-git-stash-apply-at-point, vc-git-stash-pop-at-point)
+ (vc-git-stash-menu): New functions.
+ (vc-git-stash-menu-map): New variable.
+ (vc-git-stash-map): Add bindings to popup a menu and to apply stashes.
+
+2009-12-03 Glenn Morris <rgm@gnu.org>
+
+ * vc.el (log-view-vc-backend, log-view-vc-fileset): Declare.
+ (vc-print-log-internal): Fix previous change.
+ (vc-revert): Correct pluralization.
+
+2009-12-03 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/make-mode.el (makefile-special-targets-list): No need for
+ it to be an alist any more.
+ (makefile-complete): Use completion-in-region.
+
+ * progmodes/octave-mod.el (octave-complete-symbol):
+ Use completion-in-region.
+
+ Misc cleanup.
+ * progmodes/idlwave.el (idlwave-comment-hook): Simplify with `or'.
+ (idlwave-code-abbrev, idlwave-display-user-catalog-widget)
+ (idlwave-complete-class): Don't quote lambda.
+ (idlwave-find-symbol-syntax-table, idlwave-mode-syntax-table)
+ (idlwave-mode-map): Move initialization into declaration.
+ (idlwave-action-and-binding): Use backquotes.
+ (idlwave-in-quote, idlwave-reset-sintern, idlwave-complete-in-buffer):
+ Simplify.
+ (idlwave-is-pointer-dereference): Remove unused var `pos'.
+ (idlwave-xml-create-rinfo-list): Remove unused var `entry'.
+ (idlwave-convert-xml-clean-sysvar-aliases): Remove unused vars `new',
+ `parts', and `all-parts'.
+ (idlwave-xml-create-sysvar-alist): Remove unused var `fields'.
+ (idlwave-convert-xml-system-routine-info): Remove unused string
+ `version-string'.
+ (idlwave-display-user-catalog-widget): Use dolist.
+ (idlwave-scanning-lib): Declare dynamically-scoped var.
+ (idlwave-scan-library-catalogs): Remove unused var `flags'.
+ (completion-highlight-first-word-only): Declare to silence bytecomp.
+ (idlwave-popup-select): Tighten scope of `resp'.
+ (idlwave-find-struct-tag): Remove unused var `beg'.
+ (idlwave-after-load-rinfo-hook): Declare.
+ (idlwave-sintern-class-info): Remove unused var `taglist'.
+ (idlwave-find-class-definition): Remove unused var `list'.
+ (idlwave-complete-sysvar-tag-help): Remove unused var `main-base'.
+ (idlwave-what-module-find-class): Remove unused var `classes'.
+
+2009-12-03 Juanma Barranquero <lekktu@gmail.com>
+
+ * progmodes/pascal.el: Require CL when compiling (for lexical-let).
+
+2009-12-03 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * hippie-exp.el (try-expand-dabbrev-visible): Preserve point in the
+ buffers visited. Remove redundant current-buffer-saving.
+
+2009-12-02 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Use completion-in-buffer and remove uses of dynamic scoping.
+ * progmodes/pascal.el (pascal-str, pascal-all, pascal-pred)
+ (pascal-buffer-to-use, pascal-flag): Don't declare.
+ (pascal-func-completion, pascal-type-completion, pascal-var-completion)
+ (pascal-get-completion-decl, pascal-keyword-completion):
+ Add `pascal-str' argument, save-excursion,
+ return the found completions, and don't filter with pascal-pred.
+ (pascal-completion-cache): New var.
+ (pascal-completion): Don't switch buffer any more (it was never
+ necessary). Don't save-excursion any more (it's done by the called
+ subroutines). Use a cache to avoid redundant computations.
+ Use complete-with-action rather than pascal-completion-response and
+ let it apply the predicate as well.
+ (pascal-complete-word): Use completion-in-buffer when
+ pascal-toggle-completions is nil.
+ (pascal-show-completions): Don't bind pascal-buffer-to-use since it's
+ not used any more.
+ (pascal-comp-defun): Don't change buffer any more.
+ Use complete-with-action rather than pascal-completion-response and
+ let it apply the predicate as well.
+ (pascal-goto-defun): Change buffer before calling pascal-comp-defun
+ when neded.
+
+2009-12-02 Kenichi Handa <handa@m17n.org>
+
+ * language/indian.el: Include ZWJ and ZWNJ in the patterns to
+ shape for all Indic scripts.
+
+2009-12-02 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Use completion-in-buffer.
+ * wid-edit.el (widget-field-text-end): New function.
+ (widget-field-value-get): Use it.
+ (widget-string-complete, widget-file-complete)
+ (widget-color-complete): Use it and completion-in-region.
+ (widget-complete): Don't narrow the buffer.
+
+2009-12-02 Glenn Morris <rgm@gnu.org>
+
+ * mail/rmail.el (rmail-pop-to-buffer): New function. (Bug#2282)
+ (rmail-select-summary): Use rmail-pop-to-buffer.
+ * mail/rmailsum.el: Replace all pop-to-buffer calls with
+ rmail-pop-to-buffer, to prevent horizontal splits.
+
+ * calendar/diary-lib.el (diary-list-entries): Replace superfluous
+ save-excursion with save-current-buffer.
+ Widen before searching. (Bug#5093)
+ (diary-list-sexp-entries): Remove superfluous save-excursion.
+
+2009-12-02 Michael Welsh Duggan <mwd@cert.org>
+
+ * woman.el (woman-make-bufname): Handle man-pages with "." in the
+ name. (Bug#5038)
+
+2009-12-02 Andreas Politz <politza@fh-trier.de> (tiny change)
+
+ * ido.el (ido-file-internal): Handle filenames at point that do
+ not have a directory part. (Bug#5049)
+
+2009-12-02 Juanma Barranquero <lekktu@gmail.com>
+
+ * mpc.el (mpc-intersection, mpc-host, mpc-songs-playlist)
+ (mpc-songs-jump-to, mpc-resume): Doc fixes.
+
+2009-12-01 Rob Riepel <riepel@networking.Stanford.EDU>
+
+ * emulation/tpu-extras.el (tpu-cursor-free-mode): Emit message.
+ (tpu-set-cursor-free, tpu-set-cursor-bound): Don't emit a message
+ any more.
+
+2009-12-01 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * comint.el (comint-insert-input): Ignore clicks to the right of
+ the field. Reported by Bob Nnamtrop <bobnnamtrop@gmail.com>.
+
+ * vc.el (vc-print-log-internal): Don't wait for the process to
+ terminate before setting up the major mode.
+
+ * pcmpl-unix.el (pcomplete/cd): Complete more than one argument, just
+ in case.
+
+ * pcomplete.el (pcomplete-std-complete): Don't try to complete past
+ the last element.
+
+ * simple.el (normal-erase-is-backspace-mode): Fix thinko in message.
+
+2009-12-01 Glenn Morris <rgm@gnu.org>
+
+ * window.el (window--display-buffer-2): Fix previous changes.
+
+2009-12-01 Chong Yidong <cyd@stupidchicken.com>
+
+ * mail/sendmail.el (mail-setup-hook, mail-send-hook): Doc fixes.
+
+2009-12-01 Glenn Morris <rgm@gnu.org>
+
+ * Makefile.in (ELCFILES): Add mpc.elc.
+
+2009-12-01 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * mpc.el: New file.
+
+2009-12-01 Glenn Morris <rgm@gnu.org>
+
+ * window.el (window-to-use): Define for compiler.
+
+ * emacs-lisp/bytecomp.el (byte-compile-save-excursion): Make message
+ consistent with others (no final period).
+
+ * mail/rmailmm.el (rmail-mime-handle): Doc fix.
+ (rmail-mime-show): Downcase the encoding. (Bug#5070)
+
+2009-12-01 Dan Nicolaescu <dann@ics.uci.edu>
+
+ Make vc-print-log buttons work.
+ * log-view.el (log-view-mode-map): Inherit from widget-keymap.
+
+2009-11-30 Ryan C. Thompson <rct@thompsonclan.org> (tiny change)
+
+ * savehist.el (savehist-autosave-interval): Allow setting to nil
+ through customize. (Bug#5056)
+
+2009-11-30 Juanma Barranquero <lekktu@gmail.com>
+
+ Fix references to jit-lock properties.
+ * progmodes/perl-mode.el (perl-font-lock-syntactic-keywords):
+ Refer to jit-lock-defer-multiline, not jit-lock-multiline.
+ (perl-font-lock-special-syntactic-constructs):
+ Quote jit-lock-defer-multiline property.
+
+2009-11-30 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-git.el (vc-git-registered): Call vc-git-root only once.
+
+2009-11-30 Juri Linkov <juri@jurta.org>
+
+ * misearch.el (multi-isearch-search-fun): Always provide a non-nil
+ value `buffer' of `multi-isearch-next-buffer-current-function'.
+ Use `(current-buffer)' when `buffer' is nil.
+ (multi-isearch-next-buffer-from-list): Don't fallback to
+ `(current-buffer)' when `buffer' is nil. (Bug#4947)
+
+2009-11-30 Juri Linkov <juri@jurta.org>
+
+ * misearch.el (multi-isearch-read-buffers): Move canonicalization
+ of buffers with `get-buffer' to `multi-isearch-buffers'.
+ (multi-isearch-buffers, multi-isearch-buffers-regexp):
+ Canonicalize BUFFERS with `get-buffer'. Doc fix.
+ (multi-isearch-files, multi-isearch-files-regexp): Canonicalize
+ FILES with `expand-file-name' converting relative file names
+ to absolute. Doc fix. (Bug#4727)
+
+2009-11-30 Juri Linkov <juri@jurta.org>
+
+ * misearch.el (multi-isearch-read-buffers)
+ (multi-isearch-read-matching-buffers): New functions.
+ (multi-isearch-buffers, multi-isearch-buffers-regexp):
+ Use them in the `interactive' spec. Doc fix.
+ (multi-isearch-read-files, multi-isearch-read-matching-files):
+ New functions.
+ (multi-isearch-files, multi-isearch-files-regexp):
+ Use them in the `interactive' spec. Doc fix. (Bug#4725)
+
+2009-11-30 Juri Linkov <juri@jurta.org>
+
+ * doc-view.el (doc-view-continuous):
+ Rename from `doc-view-continuous-mode'.
+ (doc-view-menu): Move "Toggle display" to the top.
+ Add submenu "Continuous" with radio buttons "Off"/"On"
+ and "Save as Default".
+ (doc-view-scroll-up-or-next-page)
+ (doc-view-scroll-down-or-previous-page)
+ (doc-view-next-line-or-next-page)
+ (doc-view-previous-line-or-previous-page):
+ Rename `doc-view-continuous-mode' to `doc-view-continuous'. (Bug#4896)
+
+2009-11-30 Juri Linkov <juri@jurta.org>
+
+ * comint.el (comint-mode-map): Rebind `M-r' from
+ `comint-previous-matching-input' to
+ `comint-history-isearch-backward-regexp'.
+ Unbind `M-s' to allow global key binding `M-s'.
+ Add menu items for `comint-history-isearch-backward' and
+ `comint-history-isearch-backward-regexp'. (Bug#3746)
+
+2009-11-30 Juri Linkov <juri@jurta.org>
+
+ * replace.el (perform-replace): Let-bind recenter-last-op to nil.
+ For def=recenter, replace `recenter' with `recenter-top-bottom'
+ that is called with `this-command' and `last-command' let-bound
+ to `recenter-top-bottom'. When the last `def' was not `recenter',
+ set `recenter-last-op' to nil. (Bug#4981)
+
+2009-11-30 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Minor cleanup and simplification.
+ * filecache.el (file-cache-add-directory)
+ (file-cache-add-directory-recursively)
+ (file-cache-add-from-file-cache-buffer)
+ (file-cache-delete-file-regexp, file-cache-delete-directory)
+ (file-cache-files-matching-internal, file-cache-display): Use dolist.
+ (file-cache-temp-minibuffer-message): Delete function.
+ (file-cache-minibuffer-complete): Use minibuffer-message instead.
+
+ * progmodes/perl-mode.el (perl-font-lock-special-syntactic-constructs):
+ Don't signal an error when bumping into EOB in tr, s, or y.
+
+2009-11-29 Juri Linkov <juri@jurta.org>
+
+ * startup.el (fancy-about-text): Fix wording of Guided Tour.
+ (Bug#4960)
+
+ * descr-text.el (describe-char-unidata-list): Use lowercase name
+ for "Unicode name" like in other tags.
+
+2009-11-29 Juri Linkov <juri@jurta.org>
+
+ * ediff-util.el (ediff-minibuffer-with-setup-hook):
+ New compatibility macro.
+ (ediff-read-file-name): Use it instead of `minibuffer-with-setup-hook'.
+
+2009-11-29 Juri Linkov <juri@jurta.org>
+
+ Add defcustom to define the cycling order of `recenter-top-bottom'.
+ (Bug#4981)
+
+ * window.el (recenter-last-op): Doc fix.
+ (recenter-positions): New defcustom.
+ (recenter-top-bottom): Rewrite to use `recenter-positions'.
+ (move-to-window-line-top-bottom): Rewrite to use `recenter-positions'.
+
+2009-11-29 Michael Albinus <michael.albinus@gmx.de>
+
+ Improve integration of Tramp and ange-ftp in eshell.
+
+ * eshell/em-unix.el (eshell/whoami): Make it a defun but a defalias.
+ (eshell/su): Flatten args. Apply better args parsing. Use "cd".
+ (eshell/sudo): Flatten args. Let-bind `default-directory'.
+
+ * eshell/esh-util.el (top): Require also Tramp when compiling.
+ (eshell-directory-files-and-attributes): Check for FTP remote
+ connection.
+ (eshell-parse-ange-ls): Let-bind `ange-ftp-name-format',
+ `ange-ftp-ftp-name-arg', `ange-ftp-ftp-name-res'.
+ (eshell-file-attributes): Handle ".". Return `entry'.
+
+ * net/ange-ftp.el (ange-ftp-parse-filename): Use `save-match-data'.
+ (ange-ftp-directory-files-and-attributes)
+ (ange-ftp-real-directory-files-and-attributes): New defuns.
+
+ * net/tramp.el (tramp-maybe-open-connection): Open the remote
+ shell with "exec" when possible. This prevents trailing prompts
+ in `start-file-process'.
+
+2009-11-28 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Try and remove assumptions about point-min==1.
+ * nxml/rng-valid.el (rng-validate-mode): Don't hardcode point-min==1.
+ (rng-compute-mode-line-string): Show the validation percentage in
+ terms of the narrowed text, not the widened text.
+ (rng-do-some-validation): Don't catch internal errors when debugging.
+ (rng-first-error): Simplify.
+ (rng-after-change-function): Remove work around. AFAIK the bug has
+ been fixed a while ago.
+
+ * image-mode.el (image-minor-mode): Exit more gracefully when the image
+ cannot be displayed (e.g. when doing C-x C-f some-new-file.svg RET).
+
+ * man.el (Man-completion-table): Make it easier to enter "<sec> <name>".
+
+ * eshell/em-prompt.el (eshell-prompt-function): Abbreviate pwd, since
+ `cd' doesn't always do it for us (bug#5067).
+
+ * pcomplete.el (pcomplete-entries): Revert change installed mistakenly
+ on 2009-10-25 as part of some other change (bug#5067).
+
+2009-11-27 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/bytecomp.el (byte-compile-warning-types): New type
+ `suspicious'.
+ (byte-compile-warnings): Use byte-compile-warning-types.
+ (byte-compile-save-excursion): Warn about use of set-buffer right
+ after save-excursion.
+
+ * progmodes/gud.el (gud-basic-call): Don't only save the buffer but
+ the excursion as well.
+
+2009-11-27 Michael Albinus <michael.albinus@gmx.de>
+
+ * eshell/em-unix.el (eshell/su, eshell/sudo): New defuns,
+ providing a Tramp related implementation of "su" and "sudo".
+ (eshell-unix-initialize): Add "su" and "sudo".
+
+2009-11-27 Daiki Ueno <ueno@unixuser.org>
+
+ * net/socks.el (socks-send-command): Convert binary request to
+ unibyte before sending. This fixes mishandling of some port
+ numbers such as 129.
+
+2009-11-27 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * help.el (describe-bindings-internal): Remove `interactive'.
+
+ * man.el (Man-completion-table): Trim a terminating "(".
+ Remove the space between name page a section.
+ Add the command's description on the `help-echo' property.
+ Remove `process-connection-type' binding since it's unused by
+ call-process.
+ Provide completion for the "<section> <name>" format as well.
+ (Man-default-man-entry): Remove spurious var shadowing the argument.
+
+2009-11-26 Kevin Ryde <user42@zip.com.au>
+
+ * log-view.el: Add "Keywords: tools", since its other keywords
+ aren't in finder-known-keywords, and following vc.el.
+
+ * sha1.el (sha1-string-external): default-directory "/" in case
+ otherwise non-existent. process-connection-type pipe for touch of
+ efficiency recommended by elisp manual. (An aside in Bug#3911.)
+
+2009-11-26 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Misc coding convention cleanups.
+ * htmlfontify.el (hfy-init-kludge-hook): Rename from
+ hfy-init-kludge-hooks.
+ (hfy-etags-cmd, hfy-flatten-style, hfy-invisible-name, hfy-face-at)
+ (hfy-fontify-buffer, hfy-prepare-index-i, hfy-subtract-maps)
+ (hfy-save-kill-buffers, htmlfontify-copy-and-link-dir): Use dolist
+ and push.
+ (hfy-slant, hfy-weight): Use tables rather than code.
+ (hfy-box-to-border-assoc, hfy-box-to-style, hfy-decor)
+ (hfy-face-to-style-i, hfy-fontify-buffer): Use `case'.
+ (hfy-face-attr-for-class): Initialize `face-spec' directly.
+ (hfy-face-to-css): Remove `nconc' with single arg.
+ (hfy-p-to-face-lennart): Use `or'.
+ (hfy-face-at): Hoist common code. Remove spurious quotes in `case'.
+ (hfy-overlay-props-at, hfy-mark-tag-hrefs): Eta-reduce.
+ (hfy-compile-stylesheet, hfy-merge-adjacent-spans)
+ (hfy-compile-face-map, hfy-parse-tags-buffer): Use push.
+ (hfy-force-fontification): Use run-hooks.
+
+2009-11-26 Vivek Dasmohapatra <vivek@etla.org>
+
+ Various minor fixes.
+ * htmlfontify.el (hfy-default-header): Add toggle_invis since
+ Javascript belongs in the header, not the body.
+ (hfy-javascript): Remove.
+ (hfy-fontify-buffer): Don't insert it any more.
+ (hfy-face-at): Handle (face0 face1 face2) style face properties.
+ Fix bug in invis handling when there were no invis props in a chunk.
+
+2009-11-26 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * vc-bzr.el (vc-bzr-annotate-command): Make operation asynchronous.
+
+2009-11-26 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * finder.el (finder-mode-map): Add a menu.
+
+2009-11-26 Michael McNamara <mac@mail.brushroad.com>
+
+ * progmodes/verilog-mode.el (verilog-at-struct-p): Support "signed" and
+ "unsigned" structs.
+
+ (verilog-leap-to-head, verilog-backward-token): Handle "disable
+ fork" statement better.
+
+2009-11-26 Wilson Snyder <wsnyder@wsnyder.org>
+
+ * progmodes/verilog-mode.el (verilog-auto-insert-lisp)
+ (verilog-delete-auto, verilog-delete-empty-auto-pair)
+ (verilog-library-filenames): Fix AUTOINSERTLISP to support insert-file.
+ Reported by Clay Douglass.
+
+ (verilog-auto-inst, verilog-auto-star-safe)
+ (verilog-delete-auto-star-implicit, verilog-read-sub-decls):
+ Fix removing "// Interfaces" when saving .* expansions.
+ Reported by Pierre-David Pfister.
+
+2009-11-26 Glenn Morris <rgm@gnu.org>
+
+ * eshell/em-dirs.el (eshell/cd): Don't throw to a tag outside
+ the scope.
+
+2009-11-25 Johan Bockgård <bojohan@gnu.org>
+
+ * vc-annotate.el (vc-annotate-revision-previous-to-line):
+ Really use previous revision.
+
+2009-11-25 Kevin Ryde <user42@zip.com.au>
+
+ * man.el (Man-completion-table): default-directory "/" in case
+ doesn't otherwise exist. process-environment COLUMNS=999 so as
+ not to truncate long names. process-connection-type pipe to avoid
+ any chance of hitting the pseudo-tty TIOCGWINSZ.
+ (man): completion-ignore-case t for friendliness and since man
+ itself is case-insensitive on the command line.
+ Further to Bug#3717.
+
+ * arc-mode.el: Add "Keywords: files", so the details in its
+ commentary can be reached from finder-by-keyword.
+ * textmodes/dns-mode.el: Add "Keywords: comm". It's only an
+ editing mode, but it's comms related and sgml-mode.el has "comm"
+ on that basis too.
+ * textmodes/bibtex-style.el: Add "Keywords: tex".
+ * international/isearch-x.el, international/ja-dic-cnv.el:
+ * international/ja-dic-utl.el, international/kkc.el:
+ Add "Keywords: i18n", so they can be reached from finder-by-keyword.
+
+2009-11-25 Juri Linkov <juri@jurta.org>
+
+ * man.el (Man-completion-table): Modify regexp to include
+ section names to completion strings. (Bug#3717)
+
+2009-11-25 Juri Linkov <juri@jurta.org>
+
+ Search recursively in gzipped files. (Bug#4982)
+
+ * progmodes/grep.el (grep-highlight-matches): Add new options
+ `always' and `auto'. Doc fix.
+ (grep-process-setup): Check `grep-highlight-matches' for
+ `auto-detect' to determine the need to compute grep defaults.
+ Move Windows/DOS specific --colors settings handling
+ to `grep-compute-defaults'. Check `grep-highlight-matches'
+ to get the value of "--color=".
+ (grep-compute-defaults): Compute `grep-highlight-matches' when it
+ has the value `auto-detect'. Move Windows/DOS specific settings
+ from `grep-process-setup'.
+ (zrgrep): New command with alias `rzgrep'.
+
+2009-11-25 Juri Linkov <juri@jurta.org>
+
+ * doc-view.el (doc-view-mode): Set buffer-local `view-read-only'
+ to nil instead of switching off view-mode. (Bug#4896)
+
+2009-11-25 Juri Linkov <juri@jurta.org>
+
+ Mouse-wheel scrolling for DocView Continuous mode. (Bug#4896)
+
+ * mwheel.el (mwheel-scroll-up-function)
+ (mwheel-scroll-down-function): New defvars.
+ (mwheel-scroll): Funcall `mwheel-scroll-up-function' instead of
+ `scroll-up', and `mwheel-scroll-down-function' instead of
+ `scroll-down'.
+
+ * doc-view.el (doc-view-scroll-up-or-next-page)
+ (doc-view-scroll-down-or-previous-page): Add optional ARG.
+ Use this ARG in the call to image-scroll-up/image-scroll-down.
+ Change `interactive' spec to "P". Goto next/previous page only
+ when `doc-view-continuous-mode' is non-nil or ARG is nil (for the
+ SPC/DEL case). Doc fix.
+ (doc-view-next-line-or-next-page)
+ (doc-view-previous-line-or-previous-page): Rename arg to ARG
+ for consistency.
+ (doc-view-mode): Set buffer-local `mwheel-scroll-up-function' to
+ `doc-view-scroll-up-or-next-page', and buffer-local
+ `mwheel-scroll-down-function' to
+ `doc-view-scroll-down-or-previous-page'.
+
+2009-11-25 Juri Linkov <juri@jurta.org>
+
+ Provide additional default values (directories at other Dired
+ windows) via M-n in the minibuffer of some Dired commands.
+
+ * dired-aux.el (dired-diff, dired-compare-directories)
+ (dired-do-create-files): Use `dired-dwim-target-defaults' to set
+ `minibuffer-default' in `minibuffer-with-setup-hook'.
+ (dired-dwim-target-directory): Find a window that displays Dired
+ buffer instead of failing when the next window is not Dired.
+ Use `get-window-with-predicate' to find for the next Dired window.
+ (dired-dwim-target-defaults): New function.
+
+ * ediff-util.el (ediff-read-file-name):
+ Use `dired-dwim-target-defaults' to set `minibuffer-default'
+ in `minibuffer-with-setup-hook'.
+
+2009-11-25 Juri Linkov <juri@jurta.org>
+
+ Provide additional default values (file name at point or at the
+ current Dired line) via M-n for file reading minibuffers. (Bug#5010)
+
+ * minibuffer.el (read-file-name-defaults): New function.
+ (read-file-name): Reset `minibuffer-default' to nil when
+ it duplicates initial input `insdef'.
+ Bind `minibuffer-default-add-function' to lambda that
+ calls `read-file-name-defaults' in `minibuffer-selected-window'.
+ (minibuffer-insert-file-name-at-point): New command.
+
+ * files.el (file-name-at-point-functions): New defcustom.
+ (find-file-default): Remove defvar.
+ (find-file-read-args): Don't use `find-file-default'.
+ Move `minibuffer-with-setup-hook' that sets `minibuffer-default'
+ to `read-file-name'.
+ (find-file-literally): Use `read-file-name' with
+ `confirm-nonexistent-file-or-buffer'.
+
+ * ffap.el (ffap-guess-file-name-at-point): New autoloaded function.
+
+ * dired.el (dired-read-dir-and-switches):
+ Move `minibuffer-with-setup-hook' that sets `minibuffer-default'
+ to `read-file-name'.
+ (dired-file-name-at-point): New function.
+ (dired-mode): Add hook `dired-file-name-at-point' to
+ `file-name-at-point-functions'.
+
+2009-11-25 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Really make the *Completions* window soft-dedicated (bug#5030).
+ * window.el (window--display-buffer-2): Add `dedicated' argument.
+ (display-buffer): Pass it when needed so the dedicated flag is set
+ after calling set-window-buffer, which would otherwise reset it.
+
+2009-11-25 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/meta-mode.el (meta-complete-symbol):
+ * progmodes/etags.el (complete-tag):
+ * mail/mailabbrev.el (mail-abbrev-complete-alias):
+ Use completion-in-region.
+
+ * dabbrev.el (dabbrev--minibuffer-origin): Use minibuffer-selected-window.
+ (dabbrev-completion): Use completion-in-region.
+ (dabbrev--abbrev-at-point): Simplify regexp.
+
+ * abbrev.el (abbrev--before-point): Use word-motion functions
+ if :regexp is not specified (bug#5031).
+
+ * subr.el (string-prefix-p): New function.
+
+ * man.el (Man-completion-cache): New var.
+ (Man-completion-table): Use it.
+
+ * vc.el (vc-print-log-internal): Make `limit' optional for better
+ compatibility (e.g. with vc-annotate.el).
+
+2009-11-24 Kevin Ryde <user42@zip.com.au>
+
+ * emacs-lisp/checkdoc.el (checkdoc-proper-noun-regexp):
+ Build value with regexp-opt instead of explicit joining loop. (Bug#4927)
+
+ * emacs-lisp/elint.el (elint-add-required-env): Better error message
+ when .el source file not found or other error.
+
+2009-11-24 Markus Triska <markus.triska@gmx.at>
+
+ * linum.el (linum-update-window): Ignore intangible (bug#4996).
+
+2009-11-24 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Handle the [back] button properly (bug#4979).
+ * descr-text.el (describe-text-properties): Add a `buffer' argument.
+ Use help-setup-xref, help-buffer, and with-help-window.
+ (describe-char): Add `buffer' argument.
+ Pass proper command to help-setup-xref. Don't meddle with
+ help-xref-stack-item directly.
+ (describe-text-category): Use with-help-window and help-buffer.
+
+ * emacs-lisp/shadow.el (list-load-path-shadows): Setup a major mode
+ for the displayed buffer (bug#4887).
+
+ * man.el (Man-completion-table): New function.
+ (man): Use it.
+
+2009-11-24 David Reitter <david.reitter@gmail.com>
+
+ * vc-git.el (vc-git-registered): Use checkout directory (where
+ .git is) rather than the file's directory and a relative path spec
+ to work around a bug in git.
+
+2009-11-24 Michael Albinus <michael.albinus@gmx.de>
+
+ Improve handling of processes on remote hosts.
+
+ * eshell/esh-util.el (eshell-path-env): New defvar.
+ (eshell-parse-colon-path): New defun.
+ (eshell-file-attributes): Use `eshell-parse-colon-path'.
+
+ * eshell/esh-ext.el (eshell-search-path):
+ Use `eshell-parse-colon-path'.
+ (eshell-remote-command): Remove argument HANDLER.
+ (eshell-external-command): Check for FTP remote connection.
+
+ * eshell/esh-proc.el (eshell-gather-process-output):
+ Use `file-truename', in order to start also symlinked files.
+ Apply `start-file-process' instead of `start-process'.
+ Shorten `command' to the local file name part.
+
+ * eshell/em-cmpl.el (eshell-complete-commands-list):
+ Use `eshell-parse-colon-path'.
+
+ * eshell/em-unix.el (eshell/du): Check for FTP remote connection.
+
+ * net/tramp.el (tramp-eshell-directory-change): New defun. Add it
+ to `eshell-directory-change-hook'.
+
+2009-11-24 Tassilo Horn <tassilo@member.fsf.org>
+
+ * doc-view.el (doc-view-mode): Switch off view-mode explicitly,
+ because it could be enabled automatically if view-read-only is non-nil.
+
+2009-11-24 Michael Kifer <kifer@cs.stonybrook.edu>
+
+ * ediff-vers.el (ediff-rcs-get-output-buffer): Revert the change
+ made on 2009-11-22.
+
+2009-11-24 Glenn Morris <rgm@gnu.org>
+
+ * bookmark.el (bookmark-bmenu-hide-filenames): Remove assignment to
+ deleted variable bookmark-bmenu-bookmark-column.
+
+2009-11-24 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * bookmark.el (bookmark-bmenu-search): Clear echo area when exiting.
+
+2009-11-23 Ken Brown <kbrown@cornell.edu> (tiny change)
+
+ * net/browse-url.el (browse-url-filename-alist): On Windows, add
+ two slashes to the "file:" prefix.
+ (browse-url-file-url): De-munge Cygwin filenames before passing
+ them to Windows browser.
+ (browse-url-default-windows-browser): Use call-process.
+
+2009-11-23 Juri Linkov <juri@jurta.org>
+
+ Implement DocView Continuous mode. (Bug#4896)
+ * doc-view.el (doc-view-continuous-mode): New defcustom.
+ (doc-view-mode-map): Bind C-n/<down> to
+ `doc-view-next-line-or-next-page', C-p/<up> to
+ `doc-view-previous-line-or-previous-page'.
+ (doc-view-next-line-or-next-page)
+ (doc-view-previous-line-or-previous-page): New commands.
+
+2009-11-23 Juri Linkov <juri@jurta.org>
+
+ Implement Isearch in comint input history. (Bug#3746)
+ * comint.el (comint-mode): Add `comint-history-isearch-setup' to
+ `isearch-mode-hook'.
+ (comint-history-isearch): New defcustom.
+ (comint-history-isearch-backward)
+ (comint-history-isearch-backward-regexp): New commands.
+ (comint-history-isearch-message-overlay): New buffer-local variable.
+ (comint-history-isearch-setup, comint-history-isearch-end)
+ (comint-goto-input, comint-history-isearch-search)
+ (comint-history-isearch-message, comint-history-isearch-wrap)
+ (comint-history-isearch-push-state)
+ (comint-history-isearch-pop-state): New functions.
+
+2009-11-23 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-shell-prompt-pattern): Use \r for carriage
+ return.
+ (tramp-handle-make-symbolic-link)
+ (tramp-handle-dired-compress-file, tramp-handle-expand-file-name):
+ Quote file names.
+ (tramp-send-command-and-check): New argument DONT-SUPPRESS-ERR.
+ (tramp-handle-process-file): Use it.
+
+2009-11-23 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * window.el (move-to-window-line-last-op): Remove.
+ (move-to-window-line-top-bottom): Reuse recenter-last-op instead.
+
+2009-11-23 Deniz Dogan <deniz.a.m.dogan@gmail.com> (tiny change)
+
+ Make M-r mirror the new cycling behavior of C-l.
+ * window.el (move-to-window-line-last-op): New var.
+ (move-to-window-line-top-bottom): New command.
+ (global-map): Bind M-r move-to-window-line-top-bottom.
+
+2009-11-23 Sven Joachim <svenjoac@gmx.de>
+
+ * dired-x.el (dired-guess-shell-alist-default):
+ Support xz format. (Bug#4953)
+
+2009-11-22 Michael Kifer <kifer@cs.stonybrook.edu>
+
+ * emulation/viper-cmd.el: Use viper-last-command-char instead of
+ last-command-char/last-command-event.
+ (viper-prefix-arg-value): Do correct conversion of event-char for
+ XEmacs.
+
+ * emulation/viper-util.el, emulation/viper.el:
+ Use viper-last-command-char instead of
+ last-command-char/last-command-event.
+
+ * ediff-init.el, ediff-mult.el, ediff-util.el:
+ Replace last-command-char and last-command-event
+ with (ediff-last-command-char) everywhere.
+
+ * ediff-vers.el (ediff-rcs-get-output-buffer): Make sure the buffer is
+ created in fundamental mode.
+
+ * ediff.el (ediff-version): Revert the change of interactive-p to
+ called-interactively-p.
+
+2009-11-22 Tassilo Horn <tassilo@member.fsf.org>
+
+ * progmodes/subword.el (subword-mode-map): Fix subword-mode-map
+ generation from word-movement command names.
+
+2009-11-21 Jan Djärv <jan.h.d@swipnet.se>
+
+ * cus-start.el (all): Add native condition for font-use-system-font.
+
+2009-11-21 Nathaniel Flath <flat0103@gmail.com>
+
+ * progmodes/cc-menus.el (cc-imenu-java-generic-expression):
+ Correct the patch from 2009-11-18. (Bug#3910)
+
+2009-11-21 Tassilo Horn <tassilo@member.fsf.org>
+
+ * progmodes/subword.el: Rename from lisp/subword.el.
+
+ * subword.el: Rename to progmodes/subword.el.
+
+ * Makefile.in (ELCFILES): Adapt to subword.el move.
+
+2009-11-21 Thierry Volpiatto <thierry.volpiatto@gmail.com>
+ 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.
+ (bookmark-bmenu-show-filenames): Use push.
+ (bookmark-bmenu-hide-filenames): Use local var instead of
+ bookmark-bmenu-bookmark-column. Use pop. Don't save window-excursion.
+ (bookmark-bmenu-bookmark): Use the new `bookmark-name-prop' text-prop.
+ (bookmark-bmenu-execute-deletions): Don't bother adding/removing the
+ filenames now that the bookmark names are always available.
+
+2009-11-21 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * bookmark.el (bookmark-search-prompt, bookmark-search-timer): Remove.
+ (bookmark-search-pattern): Move and leave unbound.
+ (bookmark-bmenu-mode-map): Change binding.
+ (bookmark-read-search-input): Simplify.
+ Don't use text-char-description. Don't error on non-char events.
+ (bookmark-filtered-alist-by-regexp-only): Remove by folding into the
+ only caller (i.e. bookmark-bmenu-filter-alist-by-regexp).
+ (bookmark-bmenu-search): Don't check we're in a bookmark-list buffer.
+ Use a local var for the timer.
+ (bookmark-bmenu-cancel-search): Remove by folding into the only caller
+ (i.e. bookmark-bmenu-search).
+
+2009-11-21 Glenn Morris <rgm@gnu.org>
+
+ * mail/rmailmm.el (rmail-mime): Decode in fundamental-mode. (Bug#4993)
+
+2009-11-20 Ken Brown <kbrown@cornell.edu> (tiny change)
+
+ * net/browse-url.el (browse-url-default-windows-browser):
+ Use cygstart for cygwin.
+
+2009-11-20 Karl Fogel <karl.fogel@red-bean.com>
+
+ * bookmark.el: Formatting and doc fixes only:
+ (bookmark-search-delay): Shorten doc string to fit in 80 columns.
+ (bookmark-bmenu-search): Wrap to fit within 80 columns.
+ Minor grammar and punctuation fixes in doc string.
+ (bookmark-read-search-input): Adjust to fit within 80 columns.
+
+2009-11-20 Tassilo Horn <tassilo@member.fsf.org>
+
+ * progmodes/cc-cmds.el (c-forward-into-nomenclature)
+ (c-backward-into-nomenclature): Adapt to subword renaming.
+
+ * subword.el (subword-forward, subword-backward, subword-mark)
+ (subword-kill, subword-backward-kill, subword-transpose)
+ (subword-downcase, subword-upcase, subword-capitalize)
+ (subword-forward-internal, subword-backward-internal):
+ Rename from forward-subword, backward-subword, mark-subword,
+ kill-subword, backward-kill-subword, transpose-subwords,
+ downcase-subword, upcase-subword, capitalize-subword,
+ forward-subword-internal, backward-subword-internal.
+
+2009-11-20 Thierry Volpiatto <thierry.volpiatto@gmail.com>
+
+ * bookmark.el (bookmark-search-delay, bookmark-search-prompt):
+ New options.
+ (bookmark-search-pattern, bookmark-search-timer, bookmark-quit-flag):
+ New vars.
+ (bookmark-read-search-input, bookmark-filtered-alist-by-regexp-only)
+ (bookmark-bmenu-filter-alist-by-regexp)
+ (bookmark-bmenu-goto-bookmark, bookmark-bmenu-cancel-search): New funs.
+ (bookmark-bmenu-search): New command.
+ (bookmark-bmenu-mode-map): Bind it.
+
+2009-11-20 Tassilo Horn <tassilo@member.fsf.org>
+
+ * progmodes/cc-cmds.el: declare-functioned forward-subword and
+ backward-subword to quit the byte-compiler.
+
+ * makefile.w32-in: Don't refer cc-subword.elc but subword.elc.
+
+ * Makefile.in: Don't refer cc-subword.elc but subword.elc.
+
+ * progmodes/cc-cmds.el (c-update-modeline)
+ (c-forward-into-nomenclature, c-backward-into-nomenclature):
+ Refer to subword.el functions instead of cc-subword.el.
+
+ * progmodes/cc-mode.el (subword-mode, c-mode-base-map): Refer to
+ subword.el functions instead of cc-subword.el.
+
+ * progmodes/cc-subword.el: Rename to subword.el.
+ * subword.el: Rename from progmodes/cc-subword.el.
+ (subword-mode-map): Rename from c-subword-mode-map.
+ (subword-mode): Rename from c-subword-mode.
+ (global-subword-mode): New global minor mode.
+ (forward-subword): Rename from c-forward-subword.
+ (backward-subword): Rename from c-backward-subword.
+ (mark-subword): Rename from c-mark-subword.
+ (kill-subword): Rename from c-kill-subword.
+ (backward-kill-subword): Rename from c-backward-kill-subword.
+ (transpose-subwords): Rename from c-tranpose-subword.
+ (downcase-subword): Rename from c-downcase-subword.
+ (capitalize-subword): Rename from c-capitalize-subword.
+ (forward-subword-internal): Rename from c-forward-subword-internal.
+ (backward-subword-internal): Rename from c-backward-subword-internal.
+
+2009-11-20 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc.el (vc-deduce-fileset): Allow non-state changing operations
+ from a dired buffer.
+ (vc-dired-deduce-fileset): New function.
+ (vc-root-diff, vc-print-root-log): Use it.
+
+ * vc-annotate.el (vc-annotate-show-log-revision-at-line): Pass a
+ nil LIMIT argument to vc-print-log-internal.
+
+2009-11-20 Glenn Morris <rgm@gnu.org>
+
+ * Makefile.in (ELCFILES): Regenerate.
+
+2009-11-20 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc.el (calc-set-mode-line):
+ Rename `calc-complement-signed-mode' to `calc-twos-complement-mode'.
+ (math-format-number): Rename `math-format-complement-signed' to
+ `math-format-twos-complement'.
+
+ * calc/calc-bin.el (math-format-twos-complement): Rename from
+ math-format-complement-signed.
+ (calc-radix): Rename `calc-complement-signed-mode' to
+ `calc-twos-complement-mode'.
+ (calc-octal-radix, calc-hex-radix): Add an argument for
+ two's complement.
+
+ * calc/calc-embed.el (calc-embedded-mode-vars):
+ Rename `calc-complement-signed-mode' to `calc-twos-complement-mode'.
+
+ * calc/calc-ext.el (calc-init-extensions):
+ Rename `calc-complement-signed-mode' to `calc-twos-complement-mode'.
+ (math-format-number-fancy): Let `calc-twos-complement-mode' be nil.
+
+ * calc/calc-units.el (math-build-units-table-buffer):
+ Let `calc-twos-complement-mode' be nil.
+
+ * calc/calc-menu.el (calc-modes-menu): Clean up two's complement
+ entries.
+
+ * calc/calc-vec.el (calcFunc-vunpack):
+ * calc/calc-aent.el (calc-do-calc-eval):
+ * calc/calc-forms.el (math-format-date):
+ * calc/calc-graph.el (calc-graph-plot):
+ * calc/calc-math.el (math-use-emacs-fn):
+ * calc/calccomp.el (math-compose-expr):
+ Let `calc-twos-complement-mode' be nil.
+
+2009-11-19 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * abbrev.el (abbrev-with-wrapper-hook): (re)move...
+ * simple.el (with-wrapper-hook): ...to here. Add argument `args'.
+ * minibuffer.el (completion-in-region-functions): New hook.
+ (completion-in-region): New function.
+ * emacs-lisp/lisp.el (lisp-complete-symbol):
+ * pcomplete.el (pcomplete-std-complete): Use it.
+
+2009-11-19 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * textmodes/tex-mode.el (latex-complete-bibtex-cache)
+ (latex-complete-alist): New vars.
+ (latex-string-prefix-p, latex-complete-bibtex-keys)
+ (latex-complete-envnames, latex-complete-refkeys)
+ (latex-complete-data): New functions.
+ (latex-complete, latex-indent-or-complete): New commands.
+
+ * window.el (display-buffer-mark-dedicated): New var.
+ (display-buffer): Obey it.
+ * minibuffer.el (minibuffer-completion-help): Use it.
+
+ * progmodes/sym-comp.el (symbol-complete): Use completion-in-region.
+
+ * filecache.el (file-cache-add-file): Use push and cons.
+ (file-cache-delete-file-regexp): Use push.
+ (file-cache-complete): Use completion-in-region.
+
+ * simple.el (with-wrapper-hook): Fix thinko.
+
+ * hfy-cmap.el (hfy-rgb-file): Use locate-file.
+ (htmlfontify-load-rgb-file): Remove unnused var `ff'.
+ Use with-current-buffer and string-to-number.
+ (hfy-fallback-colour-values): Use assoc-string.
+ * htmlfontify.el (hfy-face-to-css): Remove unused var `style'.
+ (hfy-face-at): Remove unused var `found-face'.
+ (hfy-compile-stylesheet): Remove unused var `css'.
+ (hfy-fontify-buffer): Remove unused vars `in-style', `invis-button',
+ and `orig-buffer'.
+ (hfy-buffer, hfy-copy-and-fontify-file, hfy-parse-tags-buffer):
+ Use with-current-buffer.
+ (hfy-text-p): Use expand-file-name and fewer setq.
+
+2009-11-19 Vivek Dasmohapatra <vivek@etla.org>
+
+ * htmlfontify.el, hfy-cmap.el: New files.
+
+2009-11-19 Juri Linkov <juri@jurta.org>
+
+ * minibuffer.el (completions-format): New defcustom.
+ (completion--insert-strings): Implement vertical format.
+
+ * simple.el (switch-to-completions): Move point to the first
+ completion when point was at the beginning of the buffer.
+
+2009-11-19 Juri Linkov <juri@jurta.org>
+
+ * find-dired.el (find-name-arg): Remove autoload. (Bug#4387)
+
+ * progmodes/grep.el (rgrep): Require `find-dired' for `find-name-arg'.
+
+2009-11-19 Chong Yidong <cyd@stupidchicken.com>
+
+ * mail/sendmail.el (mail-yank-prefix): Change default to "> ".
+ (mail-signature): Change default to t.
+ (mail-from-style): Deprecate `system-default' value.
+ (mail-insert-from-field): For default value of mail-from-style,
+ default to `angles' unless `angles' needs quoting and `parens'
+ does not.
+ (mail-citation-prefix-regexp): Use citation regexp from
+ message-mode.
+
+2009-11-19 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-do-copy-or-rename-file-out-of-band):
+ Set variables for computing the prompt for reading password.
+
+2009-11-19 Glenn Morris <rgm@gnu.org>
+
+ * dired-aux.el (dired-compress-file-suffixes): Add ".xz". (Bug#4953)
+
+ * textmodes/flyspell.el (sgml-lexical-context): Declare.
+
+ * net/newst-treeview.el (newsticker-treeview-treewindow-width)
+ (newsticker-treeview-listwindow-height): Fix custom type.
+
+2009-11-19 Kenichi Handa <handa@m17n.org>
+
+ * descr-text.el (describe-char-padded-string): Compose with TAB
+ only if there's a font for CH.
+ (describe-char): Fix the condition for detecting a trivial composition.
+
+2009-11-18 Nathaniel Flath <flat0103@gmail.com>
+
+ * progmodes/cc-menus.el (cc-imenu-java-generic-expression): A new,
+ more accurate version of the regexp. (Bug#3910)
+
+2009-11-18 Bernhard Herzog <bernhard.herzog@intevation.de> (tiny change)
+
+ * vc-hg.el (vc-hg-diff): Fix last patch: do not change directory.
+
+2009-11-18 Juanma Barranquero <lekktu@gmail.com>
+
+ * font-setting.el (font-use-system-font): Declare for byte-compiler.
+ (font-setting-change-default-font): Fix typo in docstring.
+
+2009-11-18 Alan Mackenzie <acm@muc.de>
+
+ * progmodes/cc-defs.el (c-version): Bump to 5.31.8.
+
+2009-11-17 Jan Djärv <jan.h.d@swipnet.se>
+
+ * font-setting.el (font-use-system-font): Move ...
+
+ * cus-start.el (all): ... to here.
+
+2009-11-17 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-advice-file-expand-wildcards): Simplify.
+ Don't set `ad-return-value' if `ad-do-it' doesn't.
+
+ * net/tramp-gvfs.el (tramp-gvfs-handle-write-region): Set file
+ modification time.
+
+2009-11-17 Jan Djärv <jan.h.d@swipnet.se>
+
+ * menu-bar.el: Put "Use system font" in Option-menu.
+ (menu-bar-options-save): Add font-use-system-font.
+
+ * loadup.el: If feature system-font-setting or font-render-setting is
+ there, load font-setting.
+
+ * Makefile.in (ELCFILES): Add font-settings.el.
+ * font-setting.el: New file.
+
+2009-11-17 Glenn Morris <rgm@gnu.org>
+
+ * vc-svn.el (vc-svn-print-log): Fix typo in previous.
+
+ * net/newst-treeview.el (newsticker--treeview-list-update-faces):
+ Preserve point in the list buffer. (Bug#4939)
+ Use point-at-eol.
+ (newsticker--treeview-list-update-highlight)
+ (newsticker--treeview-tree-update-highlight): Use point-at-bol/eol.
+
+2009-11-16 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc-bin.el (math-symclip, calcFunc-symclip, calc-symclip):
+ Remove.
+
+ * calc/calc-ext.el (calc-init-extensions): Remove references to
+ symclip.
+
+ * calc/calc-menu.el (calc-arithmetic-menu): Remove `calc-symclip'.
+
+ * calc/calc-map.el (calc-get-operator, calc-b-oper-keys):
+ * calc/calc-help.el (calc-b-prefix-help): Remove references to
+ `calc-symclip'.
+
+2009-11-16 Kevin Ryde <user42@zip.com.au>
+
+ * textmodes/flyspell.el (sgml-mode-flyspell-verify):
+ Use `sgml-lexical-context' instead of own parse for tag (Bug#4511).
+
+ * emacs-lisp/lisp-mnt.el (lm-keywords): Allow multi-line keywords.
+ (lm-keywords-list): Allow comma-only separator like "foo,bar".
+ Ignore trailing spaces by omit-nulls to split-string (fixing
+ regression from Emacs 21 due to the incompatible split-string
+ change). (Bug #4928.)
+
+2009-11-16 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc.el (vc-log-show-limit): Default to 2000.
+ (vc-print-log-internal): Insert buttons to request more entries
+ when limiting the output.
+
+ * vc-sccs.el (vc-sccs-print-log):
+ * vc-rcs.el (vc-rcs-print-log):
+ * vc-cvs.el (vc-cvs-print-log):
+ * vc-git.el (vc-git-print-log): Return 'limit-unsupported when
+ LIMIT is non-nil.
+
+2009-11-16 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-gvfs.el (tramp-gvfs-dbus-event-error): Raise only an
+ error when `tramp-gvfs-dbus-event-vector' is set.
+ (tramp-gvfs-maybe-open-connection): Loop over `read-event'.
+
+2009-11-16 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * vc-rcs.el (vc-rcs-consult-headers): Add missing save-excursion.
+
+2009-11-16 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/dbus.el (dbus-unregister-service): New defun.
+ (dbus-register-property): Register the handlers of
+ "org.freedesktop.DBus.Properties" for SERVICE.
+ (dbus-property-handler): Fix docstring.
+
+2009-11-16 YAMAMOTO Mitsuharu <mituharu@math.s.chiba-u.ac.jp>
+
+ * emacs-lisp/bytecomp.el (byte-compile-output-file-form):
+ Quote doc string reference in defvaralias as it is not in special form.
+ (byte-compile-output-docform): Doc fix.
+
+2009-11-16 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc.el (math-2-word-size, math-half-2-word-size)
+ (calc-complement-signed-mode): New variables.
+ (calc-set-mode-line): Add indicator for twos-complements.
+ (math-format-number): Format twos-complement notation.
+
+ * calc/calc-bin.el (calc-word-size): Reset the variables
+ `math-2-word-size' and `math-half-2-word-size'.
+ (math-format-complement-signed, math-symclip, calcFunc-symclip)
+ (calc-symclip): New functions.
+
+ * calc/calc-aent.el (math-read-token): Read complement signed numbers.
+
+ * calc/calc-embed.el (calc-embedded-mode-vars):
+ Add `calc-complement-signed-mode' to the list of modes.
+
+ * calc/calc-map.el (calc-get-operator): Add `calc-symclip'.
+ (calc-b-oper-keys): Add `calc-symclip' to list.
+
+ * calc/calc-ext.el (math-read-number-fancy): Read complement
+ signed numbers.
+ (calc-init-extensions): Add binding for `calc-symclip'.
+ Add autoload for `calcFunc-symclip' and `calc-symclip'.
+
+ * calc/calc-menu.el (calc-arithmetic-menu): Add item for
+ `calc-symclip'.
+ (calc-modes-menu): Add item for twos complement mode.
+
+ * calc/calc-help.el (calc-b-prefix-help): Add help for `calc-symclip'.
+
+2009-11-15 Chong Yidong <cyd@stupidchicken.com>
+
+ * register.el (jump-to-register, insert-register): Handle Semantic
+ tags. From commented-out advice in semantic/senator.el.
+
+2009-11-15 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc.el (vc-log-show-limit): New variable.
+ (vc-print-log, vc-print-root-log): Add new argument LIMIT. Set it
+ when using a prefix argument.
+ (vc-print-log-internal): Add new argument LIMIT.
+
+ * vc-svn.el (vc-svn-print-log):
+ * vc-mtn.el (vc-mtn-print-log):
+ * vc-hg.el (vc-hg-print-log):
+ * vc-bzr.el (vc-bzr-print-log): Add new optional argument LIMIT,
+ pass it to the log command when set. Make the BUFFER argument
+ non-optional.
+
+ * vc-sccs.el (vc-sccs-print-log):
+ * vc-rcs.el (vc-rcs-print-log):
+ * vc-git.el (vc-git-print-log):
+ * vc-cvs.el (vc-cvs-print-log): Add new optional argument LIMIT,
+ ignore it. Make the BUFFER argument non-optional.
+
+ * bindings.el (mode-line-buffer-identification): Do not purecopy.
+
+2009-11-15 Chong Yidong <cyd@stupidchicken.com>
+
+ * dired.el (dired-mode-map): Move encryption items to "Operate"
+ menu (Bug#4703).
+
+ * strokes.el (strokes-update-window-configuration): Make strokes
+ buffer current before erasing (Bug#4906).
+
+2009-11-15 Juri Linkov <juri@jurta.org>
+
+ * simple.el (set-mark-default-inactive): Add :type, :group
+ and :version. (Bug#4876)
+
+2009-11-15 Michael Albinus <michael.albinus@gmx.de>
+
+ * arc-mode.el (archive-maybe-copy): Move creation of directory ...
+ (archive-unique-fname): ... here. (Bug#4929)
+
+2009-11-15 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * help-mode.el (help-make-xrefs): Undo the last revert, and replace it
+ with a real fix.
+
+ * novice.el (disabled-command-function): Add useful args.
+ Setup the help buffer so that [back] works.
+ Remove redundant call to help-mode.
+ (disabled-command-function): Use `case'.
+ (en/disable-command): New function extracted from enable-command.
+ (enable-command, disable-command): Use it.
+
+2009-11-14 Glenn Morris <rgm@gnu.org>
+
+ * menu-bar.el (menu-bar-tools-menu): Read and send mail entries are not
+ constants. (Bug#4913)
+
+ * emacs-lisp/elint.el (elint-standard-variables): Doc fix.
+
+2009-11-14 Shigeru Fukaya <shigeru.fukaya@gmail.com>
+
+ * emacs-lisp/elint.el (elint-standard-variables): Add some variables
+ defined in C that have no doc-strings. (Bug#1063)
+
+2009-11-14 Francis Wright <F.J.Wright@qmul.ac.uk>
+
+ * cus-edit.el (data, files):
+ * ps-print.el (postscript): Doc fixes for custom groups. (Bug#3327)
+
+2009-11-14 Chong Yidong <cyd@stupidchicken.com>
+
+ * simple.el (shell-command): Doc fix (Bug#4891).
+
+ * help-mode.el (help-make-xrefs): Revert 2009-11-13 change.
+
+2009-11-14 Glenn Morris <rgm@gnu.org>
+
+ * emulation/viper.el (viper-set-hooks): Remove duplicate advice
+ statements for vc-diff, emerge-quit, and rmail-cease-edit.
+ If they are already loaded, eval-after-load will do the right thing.
+
+ * speedbar.el (top-level): Remove unnecessary load of ange-ftp when
+ compiling.
+
+ * emacs-lisp/bytecomp.el (byte-compile-single-version): Remove, unused.
+
+ * simple.el (x-selection-owner-p): Declare.
+ (read-mail-command): Use custom radio type rather than choice.
+ (completion-no-auto-exit): Doc fix.
+
+ * custom.el (defgroup):
+ * epg-config.el (epg): Doc fixes.
+
+2009-11-14 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * bindings.el (mode-line-buffer-identification): Purecopy only the string.
+ * international/ccl.el (define-ccl-program): Do not purecopy the
+ docstring, defconst does it anyway.
+
+2009-11-13 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * add-log.el (add-change-log-entry): Avoid displaying the changelog
+ a second time.
+
+ * x-dnd.el (x-dnd-maybe-call-test-function):
+ * window.el (split-window-vertically):
+ * whitespace.el (whitespace-help-on):
+ * vc-rcs.el (vc-rcs-consult-headers):
+ * userlock.el (ask-user-about-lock-help)
+ (ask-user-about-supersession-help):
+ * type-break.el (type-break-force-mode-line-update):
+ * time-stamp.el (time-stamp-conv-warn):
+ * terminal.el (te-set-output-log, te-more-break, te-filter)
+ (te-sentinel, terminal-emulator):
+ * term.el (make-term, term-exec, term-sentinel, term-read-input-ring)
+ (term-write-input-ring, term-check-source, term-start-output-log):
+ (term-display-buffer-line, term-dynamic-list-completions):
+ (term-ansi-make-term, serial-term):
+ * subr.el (selective-display):
+ * strokes.el (strokes-xpm-to-compressed-string, strokes-decode-buffer)
+ (strokes-encode-buffer, strokes-xpm-for-compressed-string):
+ * speedbar.el (speedbar-buffers-tail-notes, speedbar-buffers-item-info)
+ (speedbar-reconfigure-keymaps, speedbar-add-localized-speedbar-support)
+ (speedbar-remove-localized-speedbar-support)
+ (speedbar-set-mode-line-format, speedbar-create-tag-hierarchy)
+ (speedbar-update-special-contents, speedbar-buffer-buttons-engine)
+ (speedbar-buffers-line-directory):
+ * simple.el (shell-command-on-region, append-to-buffer)
+ (prepend-to-buffer):
+ * shadowfile.el (shadow-save-todo-file):
+ * scroll-bar.el (scroll-bar-set-window-start, scroll-bar-drag-1)
+ (scroll-bar-maybe-set-window-start):
+ * sb-image.el (speedbar-image-dump):
+ * saveplace.el (save-place-alist-to-file, save-places-to-alist)
+ (load-save-place-alist-from-file):
+ * ps-samp.el (ps-print-message-from-summary):
+ * ps-print.el (ps-flush-output, ps-insert-file, ps-get-boundingbox)
+ (ps-background-image, ps-begin-job, ps-do-despool):
+ * ps-bdf.el (bdf-find-file, bdf-read-font-info):
+ * printing.el (pr-interface, pr-ps-file-print, pr-find-buffer-visiting)
+ (pr-ps-message-from-summary, pr-lpr-message-from-summary):
+ (pr-call-process, pr-file-list, pr-interface-save):
+ * novice.el (disabled-command-function)
+ (enable-command, disable-command):
+ * mouse.el (mouse-buffer-menu-alist):
+ * mouse-copy.el (mouse-kill-preserving-secondary):
+ * macros.el (kbd-macro-query):
+ * ledit.el (ledit-go-to-lisp, ledit-go-to-liszt):
+ * informat.el (batch-info-validate):
+ * ido.el (ido-copy-current-word, ido-initiate-auto-merge):
+ * hippie-exp.el (try-expand-dabbrev-visible):
+ * help-mode.el (help-make-xrefs):
+ * help-fns.el (describe-variable):
+ * generic-x.el (bat-generic-mode-run-as-comint):
+ * finder.el (finder-mouse-select):
+ * find-dired.el (find-dired-sentinel):
+ * filesets.el (filesets-file-close):
+ * files.el (list-directory):
+ * faces.el (list-faces-display, describe-face):
+ * facemenu.el (list-colors-display):
+ * ezimage.el (ezimage-image-association-dump, ezimage-image-dump):
+ * epg.el (epg--process-filter, epg-cancel):
+ * epa.el (epa--marked-keys, epa--select-keys, epa-display-info)
+ (epa--read-signature-type):
+ * emerge.el (emerge-copy-as-kill-A, emerge-copy-as-kill-B)
+ (emerge-file-names):
+ * ehelp.el (electric-helpify):
+ * ediff.el (ediff-regions-wordwise, ediff-regions-linewise):
+ * ediff-vers.el (rcs-ediff-view-revision):
+ * ediff-util.el (ediff-setup):
+ * ediff-mult.el (ediff-append-custom-diff):
+ * ediff-diff.el (ediff-exec-process, ediff-process-sentinel)
+ (ediff-wordify):
+ * echistory.el (Electric-command-history-redo-expression):
+ * dos-w32.el (find-file-not-found-set-buffer-file-coding-system):
+ * disp-table.el (describe-display-table):
+ * dired.el (dired-find-buffer-nocreate):
+ * dired-aux.el (dired-rename-subdir, dired-dwim-target-directory):
+ * dabbrev.el (dabbrev--same-major-mode-p):
+ * chistory.el (list-command-history):
+ * apropos.el (apropos-documentation):
+ * allout.el (allout-obtain-passphrase):
+ (allout-copy-exposed-to-buffer):
+ (allout-verify-passphrase): Use with-current-buffer.
+
+2009-11-13 Glenn Morris <rgm@gnu.org>
+
+ * Makefile.in (ELCFILES): Regenerate.
+
+2009-11-13 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/dbus.el (dbus-registered-objects-table): Rename from
+ `dbus-registered-functions-table', because it contains also properties.
+ (dbus-unregister-object): Unregister also properties.
+ (dbus-get-property, dbus-set-property, dbus-get-all-properties):
+ Use a timeout of 500 msec, in order to not block.
+ (dbus-register-property, dbus-property-handler): New defuns.
+
+2009-11-13 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * simple.el (minibuffer-default-add-completions): Drop deprecated
+ 4th arg.
+
+2009-11-13 Tomas Abrahamsson <tab@lysator.liu.se>
+
+ * textmodes/artist.el (artist-mouse-choose-operation):
+ Call `tmm-prompt' instead of `x-popup-menu' if we cannot popup
+ menus. Bug noticed by Eli Zaretskii <eliz@gnu.org>.
+ (artist-compute-up-event-key): New function.
+ (artist-mouse-choose-operation, artist-down-mouse-1): Call it.
+
+2009-11-13 Kenichi Handa <handa@m17n.org>
+
+ * language/japan-util.el: Make sure that the value of jisx0208
+ property is jisx0208 character.
+
+2009-11-13 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * international/mule.el (auto-coding-regexp-alist): Only purecopy
+ car or each item, not the whole list.
+
+2009-11-12 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * minibuffer.el (minibuffer-completion-help):
+ Use minibuffer-hide-completions.
+
+2009-11-12 Per Starbäck <per@starback.se> (tiny change)
+
+ * dired.el (dired-save-positions, dired-restore-positions): New funs.
+ (dired-revert): Use them (bug#4880).
+
+2009-11-12 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * tooltip.el (tooltip-frame-parameters): Undo previous change.
+
+2009-11-12 Juri Linkov <juri@jurta.org>
+
+ * ffap.el (ffap-alternate-file-other-window, ffap-literally):
+ New functions.
+ (find-file-literally-at-point): Alias of `ffap-literally'.
+
+2009-11-12 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * textmodes/ispell.el (ispell-skip-region-alist):
+ * textmodes/css-mode.el (auto-mode-alist):
+ * progmodes/compile.el (auto-mode-alist):
+ * international/mule.el (ctext-non-standard-encodings-alist)
+ (ctext-non-standard-encodings-regexp):
+ * simple.el (shell-command-switch, text-read-only):
+ * replace.el (occur-mode-map):
+ * paths.el (rmail-file-name):
+ * jka-cmpr-hook.el (jka-compr-build-file-regexp):
+ * find-file.el (ff-special-constructs):
+ * files.el (file-name-handler-alist):
+ * composite.el: Purecopy strings.
+
+ * emacs-lisp/cl-macs.el (define-compiler-macro): Purecopy the file name.
+
+2009-11-11 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * widget.el (define-widget): Purecopy the docstring.
+ * international/mule-cmds.el (charset): Do not purecopy the
+ docstring here, define-widget does it.
+
+ * textmodes/texinfo.el (texinfo-open-quote, texinfo-close-quote):
+ * textmodes/bibtex-style.el (auto-mode-alist):
+ * progmodes/inf-lisp.el (inferior-lisp-prompt):
+ * progmodes/compile.el (compile-command):
+ * language/korea-util.el (default-korean-keyboard):
+ * international/mule-conf.el (file-coding-system-alist):
+ * emacs-lisp/eldoc.el (eldoc-minor-mode-string):
+ * tooltip.el (tooltip-frame-parameters):
+ * newcomment.el (comment-end, comment-padding):
+ * dired.el (dired-trivial-filenames):
+ * comint.el (comint-file-name-prefix): Purecopy initial values.
+
+2009-11-11 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-advice-minibuffer-electric-separator)
+ (tramp-advice-minibuffer-electric-tilde): Unload advices via
+ `tramp-unload'.
+ (tramp-advice-make-auto-save-file-name)
+ (tramp-advice-file-expand-wildcards): Apply also `ad-activate'
+ after removing the advice.
+
+2009-11-11 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * progmodes/grep.el (grep-regexp-alist):
+ * international/mule-cmds.el (iso-2022-control-alist):
+ * emacs-lisp/timer.el (timer-duration-words):
+ * subr.el (version-separator, version-regexp-alist):
+ * minibuffer.el (completion-styles-alist):
+ * faces.el (face-attribute-name-alist, list-faces-sample-text):
+ Change defvars to defconsts.
+
+ * Makefile.in (ELCFILES): Add international/mule-conf.elc.
+ * loadup.el ("international/mule-conf"): Load the byte compiled version.
+ * international/mule-conf.el: Allow to be byte compiled.
+
+ * international/mule.el (define-charset): Purecopy props.
+ (load-with-code-conversion): Purecopy doc string and file name.
+ (put-charset-property): Purecopy strings.
+ (auto-coding-alist, auto-coding-regexp-alist): Purecopy initial value.
+
+ * international/mule-cmds.el (register-input-method): Purecopy arguments.
+ (define-char-code-property): Correctly purecopy the table.
+
+ * international/ccl.el (define-ccl-program): Purecopy the docstring.
+
+ * emacs-lisp/easy-mmode.el (define-minor-mode): Purecopy :lighter.
+
+ * subr.el (add-hook): Purecopy strings.
+ (eval-after-load): Purecopy load-history-regexp and the form.
+
+ * custom.el (custom-declare-group): Purecopy load-file-name.
+
+ * subr.el (menu-bar-separator): New defconst.
+ * net/eudc.el (eudc-tools-menu):
+ * international/mule-cmds.el (set-coding-system-map)
+ (mule-menu-keymap):
+ * emacs-lisp/lisp-mode.el (emacs-lisp-mode-map):
+ * vc-hooks.el (vc-menu-map):
+ * replace.el (occur-mode-map):
+ * menu-bar.el (menu-bar-file-menu, menu-bar-search-menu)
+ (menu-bar-edit-menu, menu-bar-goto-menu)
+ (menu-bar-custom-menu, menu-bar-showhide-menu)
+ (menu-bar-options-menu, menu-bar-tools-menu)
+ (menu-bar-encryption-decryption-menu, menu-bar-describe-menu)
+ (menu-bar-search-documentation-menu, menu-bar-manuals-menu)
+ (menu-bar-help-menu):
+ * ediff-hook.el (menu-bar-ediff-menu, menu-bar-ediff-merge-menu):
+ * buff-menu.el (Buffer-menu-mode-map): Use menu-bar-separator.
+
+ * term/x-win.el (x-gtk-stock-map):
+ * progmodes/vera-mode.el (auto-mode-alist):
+ * progmodes/inf-lisp.el (inferior-lisp-filter-regexp)
+ (inferior-lisp-program, inferior-lisp-load-command):
+ * progmodes/hideshow.el (hs-special-modes-alist):
+ * progmodes/gud.el (same-window-regexps):
+ * progmodes/grep.el (grep-program, find-program, xargs-program):
+ * net/telnet.el (same-window-regexps):
+ * net/rlogin.el (same-window-regexps):
+ * language/ethiopic.el (font-ccl-encoder-alist):
+ * vc-sccs.el (vc-sccs-master-templates):
+ * vc-rcs.el (vc-rcs-master-templates):
+ * subr.el (cl-assertion-failed):
+ * simple.el (next-error-overlay-arrow-position):
+ * lpr.el (lpr-command):
+ * locate.el (locate-ls-subdir-switches):
+ * info.el (same-window-regexps, info)
+ (Info-goto-emacs-command-node, Info-goto-emacs-key-command-node):
+ * image-mode.el (image-mode, auto-mode-alist):
+ * hippie-exp.el (hippie-expand-ignore-buffers):
+ * format.el (format-alist):
+ * find-dired.el (find-ls-subdir-switches, find-grep-options)
+ (find-name-arg):
+ * facemenu.el (facemenu-keybindings):
+ * dired.el (dired-listing-switches, dired-chown-program):
+ * diff.el (diff-switches, diff-command):
+ * cus-edit.el (same-window-regexps):
+ * bindings.el (mode-line-mule-info)
+ (mode-line-buffer-identification): Purecopy strings.
+
+2009-11-11 Juri Linkov <juri@jurta.org>
+
+ * simple.el (dired-get-filename) <declare-function>:
+ Tell the byte-compiler about dired-get-filename.
+ (shell-command): In Dired mode, get filename from the current line
+ as the default value.
+
+2009-11-10 Glenn Morris <rgm@gnu.org>
+
+ * dired.el, hi-lock.el, calendar/cal-menu.el, calendar/calendar.el:
+ * calendar/holidays.el, progmodes/cperl-mode.el:
+ Update x-popup-menu declarations.
+
+ * emacs-lisp/shadow.el (find-emacs-lisp-shadows)
+ (list-load-path-shadows): Use dolist.
+ (list-load-path-shadows): Use with-current-buffer.
+
+2009-11-10 Juri Linkov <juri@jurta.org>
+
+ * minibuffer.el (read-file-name): Support a list of default values
+ in `default-filename'. Use the first file name where only one
+ element is required. Doc fix.
+
+2009-11-09 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/dbus.el (dbus-unregister-object): Release service, if no
+ other method is registered for it.
+
+2009-11-08 Markus Rost <rost@math.uni-bielefeld.de>
+
+ * bookmark.el (bookmark-completing-read): Sort bookmark names if
+ bookmark-sort-flag is non-nil (Bug#4653).
+
+2009-11-08 Chong Yidong <cyd@stupidchicken.com>
+
+ * emulation/cua-base.el: Add CUA property to some CC mode commands
+ (Bug#4100).
+
+2009-11-08 Kevin Ryde <user42@zip.com.au>
+
+ * emacs-lisp/checkdoc.el (checkdoc-proper-noun-regexp): Match noun
+ at end of sentence (Bug#4818).
+
+2009-11-08 Jared Finder <jfinder@crypticstudios.com>
+
+ * progmodes/compile.el (compilation-error-regexp-alist-alist):
+ Handle "see declaration of" MSFT statements (Bug#4100).
+
+2009-11-08 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-advice-make-auto-save-file-name)
+ (tramp-advice-file-expand-wildcards): Unload via
+ `ad-remove-advice'.
+
+ * net/trampver.el: Update release number.
+
+2009-11-08 Kevin Ryde <user42@zip.com.au>
+
+ * net/tramp.el (tramp-advice-file-expand-wildcards): Don't rely on
+ `ad-do-it'.
+
+2009-11-08 Andr <m00naticus@gmail.com> (tiny change)
+
+ * net/tramp.el (tramp-handle-write-region): Copy but rename temp file,
+ in order to keep context in SELinux.
+
+2009-11-08 Chong Yidong <cyd@stupidchicken.com>
+
+ * dired-aux.el (dired-query): Place cursor in echo area and allow
+ C-g.
+
+ * dired.el (dired-mode-map): Disable dired-maybe-insert-subdir
+ menu item if not on a directory (Bug#4701).
+
+2009-11-07 Michael Albinus <michael.albinus@gmx.de>
+
+ Sync with Tramp 2.1.17.
+
+ * net/tramp.el (tramp-handle-copy-directory): Don't use
+ `file-remote-p' (due to compatibility).
+
+ * net/tramp-compat.el (tramp-compat-copy-directory)
+ (tramp-compat-delete-directory): New defuns.
+
+ * net/tramp-fish.el (tramp-fish-handle-delete-directory):
+ * net/tramp-gvfs.el (tramp-gvfs-handle-delete-directory):
+ Use `tramp-compat-delete-directory'.
+
+ * net/tramp-smb.el (tramp-smb-handle-copy-directory)
+ (tramp-smb-handle-delete-directory):
+ Use `tramp-compat-copy-directory' and `tramp-compat-delete-directory'.
+
+ * net/trampver.el: Update release number.
+
+2009-11-07 Chong Yidong <cyd@stupidchicken.com>
+
+ * tar-mode.el (tar-copy): Call write-region on the right buffer
+ (Bug#4857).
+
+ * mail/rmailsum.el (rmail-summary-rmail-update): Call linum-update
+ by hand, if necessary (Bug#4878).
+
+2009-11-06 Chong Yidong <cyd@stupidchicken.com>
+
+ * buff-menu.el (Buffer-menu-buffer+size): Use display property to
+ align size column (Bug#4839).
+
+ * emacs-lisp/autoload.el (autoload-rubric): Always issue a provide
+ statement.
+
+2009-11-05 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * progmodes/ld-script.el (auto-mode-alist):
+ * vc-hooks.el (vc-directory-exclusion-list): Purecopy strings.
+
+ * cus-face.el (custom-declare-face): Purecopy face spec.
+
+2009-11-06 Kenichi Handa <handa@m17n.org>
+
+ * international/uni-bidi.el: Re-generated.
+ * international/uni-category.el: Re-generated.
+ * international/uni-combining.el: Re-generated.
+ * international/uni-mirrored.el: Re-generated.
+
+2009-11-05 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * textmodes/tex-mode.el (tex-alt-dvi-print-command)
+ (tex-dvi-print-command, tex-bibtex-command, tex-start-commands)
+ (tex-start-options, slitex-run-command, latex-run-command)
+ (tex-run-command, tex-directory):
+ * textmodes/ispell.el (ispell-html-skip-alists)
+ (ispell-tex-skip-alists, ispell-tex-skip-alists):
+ * textmodes/fill.el (adaptive-fill-first-line-regexp):
+ (adaptive-fill-regexp):
+ * textmodes/dns-mode.el (auto-mode-alist):
+ * progmodes/python.el (interpreter-mode-alist):
+ * progmodes/etags.el (tags-compression-info-list):
+ * progmodes/etags.el (tags-file-name):
+ * net/browse-url.el (browse-url-galeon-program)
+ (browse-url-firefox-program):
+ * mail/sendmail.el (mail-signature-file)
+ (mail-citation-prefix-regexp):
+ * international/mule-conf.el (eight-bit):
+ * international/latexenc.el (latex-inputenc-coding-alist):
+ * international/fontset.el (x-pixel-size-width-font-regexp):
+ * emacs-lisp/warnings.el (warning-type-format):
+ * emacs-lisp/trace.el (trace-buffer):
+ * emacs-lisp/lisp-mode.el (lisp-interaction-mode-map)
+ (emacs-lisp-mode-map):
+ * calendar/holidays.el (holiday-solar-holidays)
+ (holiday-bahai-holidays, holiday-islamic-holidays)
+ (holiday-christian-holidays, holiday-hebrew-holidays)
+ (hebrew-holidays-4, hebrew-holidays-3, hebrew-holidays-2)
+ (hebrew-holidays-1, holiday-oriental-holidays)
+ (holiday-general-holidays):
+ * x-dnd.el (x-dnd-known-types):
+ * tool-bar.el (tool-bar):
+ * startup.el (site-run-file):
+ * shell.el (shell-dumb-shell-regexp):
+ * rfn-eshadow.el (file-name-shadow-tty-properties)
+ (file-name-shadow-properties):
+ * paths.el (remote-shell-program, news-directory):
+ * mouse.el ([C-down-mouse-3]):
+ * menu-bar.el (menu-bar-tools-menu):
+ * jka-cmpr-hook.el (jka-compr-load-suffixes)
+ (jka-compr-mode-alist-additions, jka-compr-compression-info-list)
+ (jka-compr-compression-info-list):
+ * isearch.el (search-whitespace-regexp):
+ * image-file.el (image-file-name-extensions):
+ * find-dired.el (find-ls-option):
+ * files.el (directory-listing-before-filename-regexp)
+ (directory-free-space-args, insert-directory-program)
+ (list-directory-brief-switches, magic-fallback-mode-alist)
+ (magic-fallback-mode-alist, auto-mode-interpreter-regexp)
+ (automount-dir-prefix):
+ * faces.el (face-x-resources, x-font-regexp, x-font-regexp-head)
+ (x-font-regexp-slant, x-font-regexp-weight, face-x-resources)
+ (face-font-registry-alternatives, face-font-registry-alternatives)
+ (face-font-family-alternatives):
+ * facemenu.el (facemenu-add-new-face, facemenu-background-menu)
+ (facemenu-foreground-menu, facemenu-face-menu):
+ * epa-hook.el (epa-file-name-regexp):
+ * dnd.el (dnd-protocol-alist):
+ * textmodes/rst.el (auto-mode-alist):
+ * button.el (default-button): Purecopy strings.
+
+2009-11-06 Glenn Morris <rgm@gnu.org>
+
+ * Makefile.in (ELCFILES): Update.
+
+2009-11-05 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/lucid.el: Move to obsolete/lucid.el.
+ * emacs-lisp/levents.el: Move to obsolete/levents.el.
+
+ * nxml/xsd-regexp.el (xsdre-gen-categories):
+ * nxml/xmltok.el (xmltok-parse-entity):
+ * nxml/rng-parse.el (rng-parse-validate-file):
+ * nxml/rng-maint.el (rng-format-manual)
+ (rng-manual-output-force-new-line):
+ * nxml/rng-loc.el (rng-save-schema-location-1):
+ * nxml/rng-cmpct.el (rng-c-parse-file):
+ * nxml/nxml-maint.el (nxml-insert-target-repertoire-glyph-set):
+ * nxml/nxml-parse.el (nxml-parse-file): Use with-current-buffer.
+
+2009-11-05 Wilson Snyder <wsnyder@wsnyder.org>
+
+ * progmodes/verilog-mode.el (verilog-getopt-file, verilog-set-define):
+ Remove extra save-excursions and make-variable-buffer-local's.
+ Suggested by Stefan Monnier.
+
+ (verilog-getopt-file, verilog-module-inside-filename-p)
+ (verilog-set-define): Merge GNU 1.35 and repair changes from
+ switching to using with-current-buffer.
+
+ (verilog-read-always-signals-recurse): Fix "a == 2'b00 ? b : c"
+ being treated as a number and confusing AUTORESET.
+ Reported by Dan Dever.
+
+ (verilog-auto-ignore-concat, verilog-read-sub-decls-expr):
+ Add verilog-auto-ignore-concat to fix backward compatibility with
+ older verilog-modes. Reported by Dan Katz.
+
+ (verilog-read-auto-template): Fix AUTO_TEMPLATEs with regexps
+ containing closing anchors "...$".
+
+ (verilog-read-decls): Fix AUTOREG not detecting "assign {a,b}".
+ Reported by Wade Smith.
+
+ (verilog-batch-execute-func): Comment on function usage.
+
+2009-11-05 Michael McNamara <mac@mail.brushroad.com>
+
+ * progmodes/verilog-mode.el (verilog-label-re): Fix regular expression
+ for labels.
+
+ (verilog-label-re, verilog-calc-1): Support proper indent of named
+ asserts.
+
+ (verilog-backward-token, verilog-basic-complete-re)
+ (verilog-beg-of-statement, verilog-indent-re): Support proper
+ indent of the assert statement at the beginning of a block of text.
+
+ (verilog-beg-block-re, verilog-ovm-begin-re): Support the
+ `ovm_object_param_utils_begin and `ovm_component_param_utils_begin
+ tokens as begins.
+
+2009-11-05 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/bytecomp.el (byte-compile-insert-header): Drop test for
+ Emacs 19. (Bug#1531)
+ (byte-compile-fix-header): Update for the above change.
+ Drop test for epoch::version.
+
+ * emacs-lisp/autoload.el (autoload-rubric): Add optional feature arg.
+ * cus-dep.el (custom-make-dependencies):
+ * finder.el (finder-compile-keywords):
+ Use autoload-rubric's feature argument.
+
+ * calendar/diary-lib.el (top-level): Make load behave more like require.
+
+ * vc-git.el (vc-git-stash-map): Move definition before use.
+
+2009-11-04 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * custom.el (custom-declare-group): Purecopy standard-value.
+ (custom-declare-group): Purecopy custom-prefix.
+
+ * international/mule.el (load-with-code-conversion):
+ Call do-after-load-evaluation unconditionally.
+
+ * emacs-lisp/bytecomp.el (byte-compile-output-file-form): Handle defvaralias.
+
+2009-11-04 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * descr-text.el: Require help-mode rather than help-fns (bug#4861).
+
+2009-11-04 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/bytecomp.el (byte-compile-version-cond): Remove macro.
+ (byte-compile-compatibility): Remove option.
+ (byte-compile-close-variables, byte-compile-fix-header)
+ (byte-compile-insert-header, byte-compile-output-docform)
+ (byte-compile-file-form-defmumble, byte-compile-byte-code-maker)
+ (byte-compile-lambda, byte-compile-form, byte-defop-compiler19)
+ (byte-compile-list, byte-compile-concat, byte-compile-function-form)
+ (byte-compile-insert, byte-compile-defun):
+ Remove support for byte-compile-compatibility and Emacs 18. (Bug#4571)
+ (byte-defop-compiler19): Remove.
+ Without byte-compile-compatibility, the 'emacs19-opcode property is not
+ used by anything. Replace all calls with byte-defop-compiler.
+
+2009-11-04 Juri Linkov <juri@jurta.org>
+
+ * menu-bar.el (menu-bar-make-mm-toggle): Quote each element of `props'.
+ (menu-bar-options-menu): Don't quote the `prop' arg of
+ `menu-bar-make-mm-toggle'.
+
+2009-11-04 Juanma Barranquero <lekktu@gmail.com>
+
+ * calendar/calendar.el (cal-loaddefs):
+ * calendar/diary-lib.el (diary-loaddefs):
+ * calendar/holidays.el (hol-loaddefs):
+ * eshell/esh-module.el (esh-groups): Load rather than require.
+
+2009-11-03 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * calendar/todo-mode.el (todo-add-category): Don't hardcode
+ point-min==1.
+ (todo-top-priorities): Only display-buffer when called interactively.
+ (todo-item-start): Don't save excursion point.
+ (todo-item-end): Be slightly more careful. Add `include-sep' arg.
+ (todo-insert-item-here, todo-file-item, todo-remove-item):
+ Adjust uses of todo-item-start and todo-item-end.
+
+ * emacs-lisp/autoload.el (generated-autoload-feature): Remove.
+ (autoload-rubric): Don't use any more.
+
+ * emacs-lisp/byte-run.el (define-obsolete-variable-alias): Use dolist,
+ and only put a prop if it is non-nil.
+
+2009-11-03 Juri Linkov <juri@jurta.org>
+
+ * menu-bar.el (menu-bar-make-mm-toggle, menu-bar-make-toggle)
+ (menu-bar-options-menu): Fix list quoting (Bug#4429).
+
+ * buff-menu.el (Buffer-menu-mode-map): Add hyphen between "Buffer"
+ and "Menu" to make top-level menu item visually one unit (like
+ it's done for "Lisp-Interaction", "Emacs-Lisp" and other
+ multi-word menu items). Fix :help string for quit-window.
+
+2009-11-03 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/bytecomp.el (byte-compile-file-form-defvar)
+ (byte-compile-file-form-define-abbrev-table)
+ (byte-compile-file-form-custom-declare-variable)
+ (byte-compile-variable-ref, byte-compile-defvar):
+ Whether or not a warning is enabled should only affect whether we issue
+ the warning, not whether or not we collect the relevant data.
+ Eg warnings can be turned on and off throughout the course of a file.
+
+ * eshell/esh-mode.el (ansi-color-apply-on-region): Autoload it...
+ (eshell-handle-ansi-color): ... Rather than requiring ansi-color.
+
+2009-11-03 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * term/ns-win.el (ns-scroll-bar-move, ns-face-at-pos):
+ * play/mpuz.el (mpuz-create-buffer):
+ * play/landmark.el (lm-prompt-for-move, lm-print-wts, lm-print-smell)
+ (lm-print-y,s,noise, lm-print-w0, lm-init):
+ * play/gomoku.el (gomoku-prompt-for-move):
+ * play/fortune.el (fortune-in-buffer):
+ * play/dissociate.el (dissociated-press):
+ * play/decipher.el (decipher-adjacency-list, decipher-display-regexp)
+ (decipher-analyze-buffer, decipher-stats-buffer, decipher-stats-buffer):
+ * mail/supercite.el (sc-eref-show):
+ * mail/smtpmail.el (smtpmail-send-it):
+ * mail/rmailsum.el (rmail-summary-next-labeled-message)
+ (rmail-summary-previous-labeled-message, rmail-summary-wipe)
+ (rmail-summary-undelete-many, rmail-summary-rmail-update)
+ (rmail-summary-goto-msg, rmail-summary-expunge)
+ (rmail-summary-get-new-mail, rmail-summary-search-backward)
+ (rmail-summary-add-label, rmail-summary-output-menu)
+ (rmail-summary-output-body):
+ * mail/rfc822.el (rfc822-addresses):
+ * mail/reporter.el (reporter-dump-variable, reporter-dump-state):
+ * mail/mailpost.el (post-mail-send-it):
+ * mail/hashcash.el (hashcash-generate-payment):
+ * mail/feedmail.el (feedmail-run-the-queue)
+ (feedmail-queue-send-edit-prompt-help-first)
+ (feedmail-send-it-immediately, feedmail-give-it-to-buffer-eater)
+ (feedmail-deduce-address-list):
+ * eshell/esh-ext.el (eshell-remote-command):
+ * eshell/em-unix.el (eshell-occur-mode-mouse-goto):
+ * emulation/viper-util.el (viper-glob-unix-files, viper-save-setting)
+ (viper-wildcard-to-regexp, viper-glob-mswindows-files)
+ (viper-save-string-in-file, viper-valid-marker):
+ * emulation/viper-keym.el (viper-toggle-key):
+ * emulation/viper-ex.el (ex-expand-filsyms, viper-get-ex-file)
+ (ex-edit, ex-global, ex-mark, ex-next-related-buffer, ex-quit)
+ (ex-get-inline-cmd-args, ex-tag, ex-command, ex-compile):
+ * emulation/viper-cmd.el (viper-exec-form-in-vi)
+ (viper-exec-form-in-emacs, viper-brac-function):
+ * emulation/viper.el (viper-delocalize-var):
+ * emulation/vip.el (vip-mode, vip-get-ex-token, vip-ex, vip-get-ex-pat)
+ (vip-get-ex-command, vip-get-ex-opt-gc, vip-get-ex-buffer)
+ (vip-get-ex-count, vip-get-ex-file, ex-edit, ex-global, ex-mark)
+ (ex-map, ex-unmap, ex-quit, ex-read, ex-tag, ex-command):
+ * emulation/vi.el (vi-switch-mode, vi-ex-cmd):
+ * emulation/edt.el (edt-electric-helpify):
+ * emulation/cua-rect.el (cua--rectangle-aux-replace):
+ * emulation/cua-gmrk.el (cua--insert-at-global-mark)
+ (cua--delete-at-global-mark, cua--copy-rectangle-to-global-mark)
+ (cua-indent-to-global-mark-column):
+ * calendar/diary-lib.el (calendar-mark-1):
+ * calendar/cal-hebrew.el (calendar-hebrew-mark-date-pattern):
+ Use with-current-buffer.
+ * emulation/viper.el (viper-delocalize-var): Use dolist.
+
+2009-11-03 Chong Yidong <cyd@stupidchicken.com>
+
+ * comint.el (comint-replace-by-expanded-history-before-point):
+ Replace !! with the previous input string literally (Bug#1795).
+
+2009-11-02 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc-forms.el (calc-date-notation): Allow a "blank string"
+ to be made up of whitespace.
+
+2009-11-02 Chong Yidong <cyd@stupidchicken.com>
+
+ * minibuffer.el (read-file-name): Don't use file dialogs for
+ remote directories (Bug#99).
+
+2009-11-01 Chong Yidong <cyd@stupidchicken.com>
+
+ * progmodes/sh-script.el (sh-font-lock-paren): Fix last change.
+
+2009-11-01 Andreas Schwab <schwab@linux-m68k.org>
+
+ * view.el (view-mode-exit): If OLD-BUF is dead bury the buffer
+ instead of deleting the window or frame.
+
+2009-10-31 Chong Yidong <cyd@stupidchicken.com>
+
+ * textmodes/sgml-mode.el (sgml-mode-facemenu-add-face-function):
+ Support face colors.
+
+ * textmodes/tex-mode.el (tex-facemenu-add-face-function):
+ New function. Support face colors (Bug#1168).
+ (tex-common-initialization): Use it.
+
+ * facemenu.el (facemenu-enable-faces-p): Enable facemenu if the
+ mode allows it (Bug#1168).
+
+2009-10-31 Juri Linkov <juri@jurta.org>
+
+ * facemenu.el (list-colors-display): Don't mark buffer as
+ modified (Bug#3948).
+
+2009-10-31 Chong Yidong <cyd@stupidchicken.com>
+
+ * international/mule-diag.el (list-character-sets-1):
+ Minor message fix (Bug#3526).
+
+ * progmodes/etags.el (etags-list-tags, etags-tags-apropos):
+ Fix face property (Bug#4834).
+ (etags-list-tags, etags-tags-apropos-additional)
+ (etags-tags-apropos, tags-select-tags-table): Add follow-link
+ property.
+
+ * menu-bar.el (menu-bar-tools-menu): Add Semantic and EDE menu
+ items.
+
+2009-10-31 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * textmodes/two-column.el (2C-split):
+ * textmodes/texnfo-upd.el (texinfo-multi-file-included-list):
+ * textmodes/tex-mode.el (tex-set-buffer-directory):
+ * textmodes/spell.el (spell-region, spell-string):
+ * textmodes/reftex.el (reftex-erase-buffer):
+ (reftex-get-file-buffer-force, reftex-kill-temporary-buffers):
+ * textmodes/reftex-toc.el (reftex-toc-promote-action):
+ * textmodes/reftex-sel.el (reftex-get-offset, reftex-insert-docstruct)
+ (reftex-select-item):
+ * textmodes/reftex-ref.el (reftex-label-info-update)
+ (reftex-offer-label-menu):
+ * textmodes/reftex-index.el (reftex-index-change-entry)
+ (reftex-index-phrases-info):
+ * textmodes/reftex-global.el (reftex-create-tags-file)
+ (reftex-save-all-document-buffers, reftex-ensure-write-access):
+ * textmodes/reftex-dcr.el (reftex-echo-ref, reftex-echo-cite)
+ (reftex-view-crossref-from-bibtex):
+ * textmodes/reftex-cite.el (reftex-bibtex-selection-callback)
+ (reftex-extract-bib-entries-from-thebibliography)
+ (reftex-all-used-citation-keys, reftex-create-bibtex-file):
+ * textmodes/refbib.el (r2b-capitalize-title):
+ (r2b-convert-buffer, r2b-help):
+ * textmodes/page-ext.el (pages-directory)
+ (pages-directory-goto-with-mouse):
+ * textmodes/bibtex.el (bibtex-validate-globally):
+ * textmodes/bib-mode.el (bib-capitalize-title):
+ * textmodes/artist.el (artist-clear-buffer, artist-system):
+ * progmodes/xscheme.el (global-set-scheme-interaction-buffer):
+ (local-set-scheme-interaction-buffer, xscheme-process-filter)
+ (verify-xscheme-buffer, xscheme-enter-interaction-mode)
+ (xscheme-enter-debugger-mode, xscheme-debugger-mode-p)
+ (xscheme-send-control-g-interrupt, xscheme-start-process)
+ (xscheme-process-sentinel, xscheme-cd):
+ * progmodes/verilog-mode.el (verilog-read-always-signals)
+ (verilog-set-define, verilog-getopt-file)
+ (verilog-module-inside-filename-p):
+ * progmodes/sh-script.el:
+ * progmodes/python.el (python-pdbtrack-get-source-buffer)
+ (python-pdbtrack-grub-for-buffer, python-execute-file):
+ * progmodes/octave-inf.el (inferior-octave):
+ * progmodes/idlwave.el (idlwave-scan-user-lib-files)
+ (idlwave-shell-compile-helper-routines, idlwave-set-local)
+ (idlwave-display-completion-list-xemacs, idlwave-list-abbrevs)
+ (idlwave-display-completion-list-emacs, idlwave-list-load-path-shadows)
+ (idlwave-completion-fontify-classes, idlwave-display-calling-sequence):
+ * progmodes/idlw-shell.el (idlwave-shell-examine-display-clear)
+ (idlwave-shell-filter, idlwave-shell-examine-highlight)
+ (idlwave-shell-sentinel, idlwave-shell-filter-directory)
+ (idlwave-shell-display-line, idlwave-shell-set-bp-in-module)
+ (idlwave-shell-examine-display, idlwave-shell-run-region)
+ (idlwave-shell-filter-bp, idlwave-shell-save-and-action)
+ (idlwave-shell-sources-filter, idlwave-shell-goto-next-error):
+ * progmodes/idlw-help.el (idlwave-help-get-special-help)
+ (idlwave-help-get-help-buffer):
+ * progmodes/gud.el (gud-basic-call, gud-find-class)
+ (gud-tooltip-activate-mouse-motions-if-enabled):
+ * progmodes/gdb-mi.el (gdb-mouse-toggle-breakpoint-fringe):
+ * progmodes/ebrowse.el (ebrowse-member-table, ebrowse-save-tree-as)
+ (ebrowse-view-exit-fn, ebrowse-tags-list-members-in-file)
+ (ebrowse-tags-next-file):
+ * progmodes/ebnf2ps.el (ebnf-generate-eps, ebnf-generate-eps)
+ (ebnf-eps-production-list, ebnf-begin-file, ebnf-log)
+ (ebnf-eps-finish-and-write):
+ * progmodes/cpp.el (cpp-edit-save):
+ * progmodes/cperl-mode.el (cperl-pod-to-manpage):
+ * progmodes/cc-defs.el (c-emacs-features):
+ * progmodes/antlr-mode.el (antlr-invalidate-context-cache)
+ (antlr-directory-dependencies):
+ * progmodes/ada-xref.el (ada-gnat-parse-gpr, ada-get-ali-file-name)
+ (ada-run-application, ada-find-in-src-path, ada-goto-parent)
+ (ada-find-any-references, ada-make-filename-from-adaname)
+ (ada-make-body-gnatstub):
+ * obsolete/rnews.el (news-list-news-groups):
+ * obsolete/resume.el (resume-suspend-hook, resume-write-buffer-to-file):
+ * obsolete/iso-acc.el (iso-acc-minibuf-setup):
+ * net/rcirc.el (rcirc-debug):
+ * net/newst-treeview.el (newsticker--treeview-list-add-item)
+ (newsticker--treeview-list-clear, newsticker-treeview-browse-url)
+ (newsticker--treeview-list-update-faces, newsticker-treeview-save)
+ (newsticker--treeview-item-show-text, newsticker--treeview-item-show)
+ (newsticker--treeview-tree-update-tag, newsticker--treeview-buffer-init)
+ (newsticker-treeview-show-item, newsticker--treeview-unfold-node)
+ (newsticker--treeview-list-clear-highlight)
+ (newsticker--treeview-list-update-highlight)
+ (newsticker--treeview-list-highlight-start)
+ (newsticker--treeview-tree-update-highlight)
+ (newsticker--treeview-get-selected-item)
+ (newsticker-treeview-mark-list-items-old)
+ (newsticker--treeview-set-current-node):
+ * net/newst-plainview.el (newsticker--buffer-set-uptodate):
+ * net/newst-backend.el (newsticker--get-news-by-funcall)
+ (newsticker--get-news-by-wget, newsticker--image-get)
+ (newsticker--image-sentinel):
+ * net/mairix.el (mairix-rmail-fetch-field, mairix-gnus-fetch-field):
+ * net/eudcb-ph.el (eudc-ph-do-request, eudc-ph-open-session):
+ (eudc-ph-close-session):
+ * net/eudc.el (eudc-save-options):
+ * language/thai-word.el (thai-update-word-table):
+ * language/japan-util.el (japanese-string-conversion):
+ * international/titdic-cnv.el (tsang-quick-converter)
+ (ziranma-converter, ctlau-converter):
+ * international/mule-cmds.el (describe-language-environment):
+ * international/ja-dic-cnv.el (skkdic-convert-okuri-ari)
+ (skkdic-convert-postfix, skkdic-convert-prefix):
+ (skkdic-convert-okuri-nasi, skkdic-convert):
+ * emacs-lisp/re-builder.el (reb-update-overlays):
+ * emacs-lisp/pp.el (pp-to-string, pp-display-expression):
+ * emacs-lisp/gulp.el (gulp-send-requests):
+ * emacs-lisp/find-gc.el (trace-call-tree):
+ * emacs-lisp/eieio-opt.el (eieio-browse, eieio-describe-class)
+ (eieio-describe-generic):
+ * emacs-lisp/eieio-base.el (eieio-persistent-read):
+ * emacs-lisp/edebug.el (edebug-outside-excursion):
+ * emacs-lisp/debug.el (debugger-make-xrefs):
+ * emacs-lisp/cust-print.el (custom-prin1-to-string):
+ * emacs-lisp/chart.el (chart-new-buffer):
+ * emacs-lisp/authors.el (authors-scan-el, authors-scan-change-log):
+ Use with-current-buffer.
+ * textmodes/artist.el (artist-system): Don't call
+ copy-sequence on a fresh string.
+ * progmodes/idlw-shell.el (easymenu setup): Use dolist.
+
+2009-10-31 Stephen Berman <stephen.berman@gmx.net>
+
+ * calendar/todo-mode.el (todo-edit-item): Signal an error if there
+ is no item to edit. (Bug#4820)
+ (todo-top-priorities): Restore point and restore narrowing in Todo
+ buffer. (Bug#4820)
+
+2009-10-31 Glenn Morris <rgm@gnu.org>
+
+ * net/ange-ftp.el (top-level): Don't require dired when compiling.
+ (comint-last-output-start, comint-last-input-start)
+ (comint-last-input-end): Don't defvar when compiling.
+ (ange-ftp-process-file): Use bound-and-true-p.
+
+ * pcmpl-rpm.el (top-level): Move provide statement to end.
+ (pcmpl-rpm): Remove unused custom group.
+
+ * pcmpl-gnu.el (tar-parse-info, tar-header-name): Declare for compiler.
+
+ * mail/emacsbug.el (report-emacs-bug): Request `emacs -Q' recipes.
+
+ * emacs-lisp/bytecomp.el (byte-compile-warning-types)
+ (byte-compile-warnings): Add `constants' as an option.
+ (byte-compile-callargs-warn, byte-compile-arglist-warn)
+ (display-call-tree): Update for byte-compile-fdefinition possibly
+ returning `(macro lambda ...)'. (Bug#4778)
+ (byte-compile-variable-ref, byte-compile-setq-default):
+ Respect `constants' member of byte-compile-warnings.
+
+2009-10-30 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * vc-bzr.el (vc-bzr-revision-keywords): New var.
+ (vc-bzr-revision-completion-table): Use it to fix completion of "s:"
+ to "submit:".
+
+2009-10-30 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * textmodes/ispell.el (ispell-skip-region-alist):
+ * international/mule-conf.el (eight-bit):
+ * international/fontset.el (font-encoding-alist):
+ * startup.el (pure-space-overflow-message):
+ * simple.el (overwrite-mode-textual, overwrite-mode-binary):
+ * paths.el (gnus-nntp-service, rmail-spool-directory)
+ (term-file-prefix):
+ * files.el (save-some-buffers-action-alist):
+ * cmuscheme.el (same-window-buffer-names):
+ * ielm.el (same-window-buffer-names):
+ * shell.el (same-window-buffer-names):
+ * mail/sendmail.el (same-window-buffer-names):
+ * progmodes/inf-lisp.el (same-window-buffer-names):
+ * bindings.el (mode-line-client)
+ (mode-line-column-line-number-mode-map):
+ * language/tibetan.el (tibetan-precomposition-rule-regexp)
+ (tibetan-precomposed-regexp): Purecopy string arguments.
+
+2009-10-28 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * calc/calc.el (calc, calc-refresh, calc-trail-buffer, calc-record)
+ (calcDigit-nondigit):
+ * calc/calc-yank.el (calc-copy-to-buffer):
+ * calc/calc-units.el (calc-invalidate-units-table):
+ * calc/calc-trail.el (calc-trail-yank):
+ * calc/calc-store.el (calc-insert-variables):
+ * calc/calc-rewr.el (math-rewrite, math-rewrite-phase):
+ * calc/calc-prog.el (calc-read-parse-table):
+ * calc/calc-keypd.el (calc-do-keypad, calc-keypad-right-click):
+ * calc/calc-help.el (calc-describe-bindings, calc-describe-key):
+ * calc/calc-graph.el (calc-graph-delete, calc-graph-add-curve)
+ (calc-graph-juggle, calc-graph-count-curves, calc-graph-plot)
+ (calc-graph-plot, calc-graph-format-data, calc-graph-set-styles)
+ (calc-graph-name, calc-graph-find-command, calc-graph-view)
+ (calc-graph-view, calc-gnuplot-command, calc-graph-init):
+ * calc/calc-ext.el (calc-realign):
+ * calc/calc-embed.el (calc-do-embedded, calc-do-embedded)
+ (calc-embedded-finish-edit, calc-embedded-make-info)
+ (calc-embedded-finish-command, calc-embedded-stack-change):
+ * calc/calc-aent.el (calcAlg-enter): Use with-current-buffer.
+
+ * pcomplete.el (pcomplete-comint-setup): If there's a choice, replace
+ shell-dynamic-complete-filename in preference to
+ comint-dynamic-complete-filename.
+
+ * bookmark.el (bookmark-insert-location, bookmark-bmenu-list)
+ (bookmark-bmenu-show-filenames, bookmark-bmenu-hide-filenames):
+ Don't consider whether the display supports colors.
+ (bookmark-import-new-list): Use dolist.
+ (bookmark-bmenu-mode-map): Move initialization into declaration.
+ (bookmark-bmenu-list): Use dolist, simplify.
+ (bookmark-show-all-annotations): Use save-selected-window and dolist.
+ (menu-bar-final-items): Use push.
+
+2009-10-28 Bernhard Herzog <bernhard.herzog@intevation.de> (tiny change)
+
+ * vc-hg.el (vc-hg-state, vc-hg-working-revision): Use process-file so
+ it works on remote files.
+ (vc-hg-diff): Don't pass any `--cwd' argument.
+
+2009-10-27 Kevin Ryde <user42@zip.com.au>
+
+ * emacs-lisp/checkdoc.el (checkdoc-proper-noun-region-engine):
+ Use help-xref-info-regexp and help-xref-url-regexp to identify links.
+ (Further to Bug#3921).
+
+2009-10-27 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-imap.el (top): Add `X-Size' to `imap-hash-headers'.
+ (tramp-imap-do-copy-or-rename-file): Don't use the inode, when
+ calling `tramp-imap-put-file'. Add file size to the call.
+ (tramp-imap-get-file-entries): Compute also user name, file size,
+ and date.
+ (tramp-imap-handle-insert-directory): Insert uid and gid.
+ (tramp-imap-handle-file-attributes): Transform uid and gid
+ according to `id-format'.
+ (tramp-imap-put-file): New optional parameter SIZE. Encode file
+ size in header X-Size.
+
+2009-10-26 Juanma Barranquero <lekktu@gmail.com>
+
+ * simple.el (transpose-subr): Give clearer error when the mark
+ is not set. (Bug#4807)
+
+2009-10-26 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-perl-file-truename): New defconst.
+ Perl code contributed by yary <not.com@gmail.com> (tiny change).
+ (tramp-handle-file-truename, tramp-get-remote-perl): Use it.
+ Check also for "perl-file-spec" and "perl-cwd-realpath" properties.
+ (tramp-handle-write-region): In case of APPEND, reuse the tmpfile name.
+
+ * net/tramp-imap.el (tramp-imap-file-name-handler-alist):
+ Ignore `dired-call-process'.
+ (tramp-imap-make-iht): Use `user' and `ssl' with `imap-hash-make'.
+
+2009-10-26 Julian Scheid <julians37@gmail.com>
+
+ * net/tramp.el (tramp-perl-file-name-all-completions): New defconst.
+ (tramp-get-remote-readlink): New defun.
+ (tramp-handle-file-truename): Use it.
+ (tramp-handle-file-exists-p): Check file-attributes cache, assume
+ file exists if cache value present.
+ (tramp-check-cached-permissions): New defun.
+ (tramp-handle-file-readable-p): Use it.
+ (tramp-handle-file-writable-p): Likewise.
+ (tramp-handle-file-executable-p): Likewise.
+ (tramp-handle-file-name-all-completions): Try using Perl to get
+ partial completions. When perl not available, combine `cd' and
+ `ls' into single remote operation and use shell expansion to get
+ partial remote directory contents. Set `file-exists-p' cache for
+ directory and any files returned by ls. Change cache handling to
+ support partial directory contents. Use error message emitted by
+ remote `cd' or Perl code for local tramp-error.
+ (tramp-do-copy-or-rename-file-directly): Avoid separate
+ tramp-send-command-and-check call.
+ (tramp-handle-process-file): Merge three remote ops into one.
+ Do not flush all caches when `process-file-side-effects' is set.
+ (tramp-handle-write-region): Avoid tramp-set-file-uid-gid if
+ file-attributes shows uid/gid to be set already.
+
+2009-10-26 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * textmodes/tex-mode.el (tex-dvi-view-command)
+ (tex-show-queue-command, tex-open-quote):
+ * progmodes/ruby-mode.el (auto-mode-alist)
+ (interpreter-mode-alist): Purecopy strings.
+
+ * emacs-lisp/lisp-mode.el (emacs-lisp-mode-map): Purecopy item names.
+
+ * emacs-lisp/derived.el (define-derived-mode): Purecopy the doc
+ string for the hook, keymap and abbrev table.
+
+ * emacs-lisp/byte-run.el (make-obsolete): Purecopy the current name.
+
+ * x-dnd.el (x-dnd-xdnd-to-action):
+ * startup.el (fancy-startup-text, fancy-about-text): Change to
+ defconst from defvar.
+
+ * ps-print.el (ps-page-dimensions-database): Purecopy initial value.
+
+ * mouse.el (mouse-buffer-menu-mode-groups, x-fixed-font-alist):
+ Purecopy initialization strings.
+
+ * mail/sendmail.el (mail-header-separator)
+ (mail-personal-alias-file):
+ * mail/rmail.el (rmail-default-dont-reply-to-names)
+ (rmail-ignored-headers, rmail-retry-ignored-headers)
+ (rmail-highlighted-headers, rmail-secondary-file-directory)
+ (rmail-secondary-file-regexp):
+ * files.el (null-device, file-name-invalid-regexp)
+ (locate-dominating-stop-dir-regexp)
+ (inhibit-first-line-modes-regexps): Purecopy initialization strings.
+ (interpreter-mode-alist): Use mapcar instead of mapc.
+
+ * buff-menu.el (Buffer-menu-mode-map): Purecopy name.
+
+ * bindings.el (mode-line-major-mode-keymap): Purecopy name.
+ (completion-ignored-extensions):
+ (debug-ignored-errors): Purecopy strings.
+
+2009-10-26 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * pcomplete.el (pcomplete-std-complete): Obey pcomplete-use-paring.
+ (pcomplete, pcomplete-parse-buffer-arguments, pcomplete-opt)
+ (pcomplete--here): Use push.
+
+ * subr.el (all-completions): Declare the 4th arg obsolete.
+
+2009-10-25 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * pcomplete.el (pcomplete-unquote-argument-function): New var.
+ (pcomplete-unquote-argument): New function.
+ (pcomplete--common-suffix): Always pay attention to case.
+ (pcomplete--table-subvert): Quote and unquote the text.
+ (pcomplete--common-quoted-suffix): New function.
+ (pcomplete-std-complete): Use it and pcomplete-begin.
+
+ * bookmark.el (bookmark-bmenu-list): Don't use switch-to-buffer if
+ we're inside a dedicated or minibuffer window.
+
+2009-10-24 Karl Fogel <kfogel@red-bean.com>
+
+ * bookmark.el: Update documentation, especially documentation
+ of `bookmark-alist' and of the bookmark file format.
+ Patch by Drew Adams, with minor tweaks from me. (Bug#4195)
+
+2009-10-24 Chong Yidong <cyd@stupidchicken.com>
+
+ * mail/emacsbug.el (report-emacs-bug): Clarify that the
+ keybindings apply to the mail buffer (Bug#4003). Shrink help
+ window to buffer.
+
+ * whitespace.el (whitespace-mode, whitespace-newline-mode)
+ (global-whitespace-mode, global-whitespace-newline-mode)
+ (whitespace-toggle-options, global-whitespace-toggle-options):
+ Doc fix (Bug#3660).
+
+ * nxml/nxml-mode.el (nxml-balanced-close-start-tag): Use the value
+ of xmltok-start before the end tag was inserted (Bug#2840).
+
+ * progmodes/sh-script.el (sh-font-lock-paren): Handle case
+ patterns that are preceded by an open-paren (Bug#1320).
+
+2009-10-24 Sven Joachim <svenjoac@gmx.de>
+
+ * files.el (delete-directory): Delete symlinks to directories with
+ delete-file (Bug#4739).
+
+2009-10-24 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc.el (vc-backend-for-registration): Rename from
+ vc-get-backend-for-registration. Update callers.
+
+ * international/mule-cmds.el (set-language-info-alist):
+ Purecopy lang-env.
+ (leim-list-header, leim-list-entry-regexp): Change defvars to defconst.
+ (charset): Purecopy the name.
+ (define-char-code-property): Purecopy string arguments.
+
+ * emacs-lisp/byte-run.el (make-obsolete, make-obsolete-variable):
+ Purecopy string arguments.
+
+ * emacs-lisp/lisp-mode.el (emacs-lisp-mode-map):
+ * ediff-hook.el (menu-bar-ediff-menu):
+ * buff-menu.el (Buffer-menu-mode-map): Purecopy names and tooltips.
+ * bookmark.el (menu-bar-bookmark-map): Add :help and purecopy the name.
+
+2009-10-24 Glenn Morris <rgm@gnu.org>
+
+ * comint.el (comint-dynamic-list-completions):
+ * term.el (term-dynamic-list-completions): Use choose-completion rather
+ than obsolete alias mouse-choose-completion.
+
+ * filecache.el (file-cache-completions-keymap): Bind mouse-2 to
+ file-cache-choose-completion.
+ (file-cache-choose-completion): Handle an optional event argument.
+ (file-cache-mouse-choose-completion): Make it an obsolete alias.
+
+ * progmodes/octave-mod.el (octave-complete-symbol):
+ Use choose-completion if mouse-choose-completion is ever removed.
+
+ * textmodes/sgml-mode.el (sgml-looking-back-at): Move definition before
+ use.
+
+ * emacs-lisp/checkdoc.el (generate-autoload-cookie): Define for
+ compiler.
+
+ * vc-hooks.el (vc-responsible-backend): Fix declaration.
+
+2009-10-24 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * minibuffer.el (completion--embedded-envvar-table): Fix last change.
+ Ignore `pred' now that we receive one.
+ Handle test-completion specially.
+
+2009-10-23 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc.el (vc-responsible-backend): Throw an error if not backend is
+ found. Remove the REGISTER argument. Move the code dealing with
+ REGISTER ...
+ (vc-get-backend-for-registration): ... here. New function.
+ (vc-deduce-fileset): Call vc-get-backend-for-registration instead
+ of vc-responsible-backend, pass the file name instead of the
+ directory name.
+
+2009-10-23 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * pcomplete.el (pcomplete-common-suffix, pcomplete-table-subvert):
+ New funs.
+ (pcomplete-std-complete): Use them. Obey pcomplete-termination-string.
+ (pcomplete-comint-setup): Don't modify a global var via
+ accidental side-effects.
+ (pcomplete-shell-setup): Adjust call accordingly.
+ (pcomplete-parse-comint-arguments): Use push.
+
+2009-10-23 Chong Yidong <cyd@stupidchicken.com>
+
+ * emacs-lisp/checkdoc.el (checkdoc-proper-noun-region-engine):
+ Allow uncapitalized info node names (Bug#3921).
+
+ * mail/emacsbug.el (report-emacs-bug): Tweak the sentence pointing
+ to the DEBUG file (Bug#3781).
+
+2009-10-23 Jari Aalto <jari.aalto@cante.net>
+
+ * textmodes/ispell.el (ispell-dictionary-base-alist): Add finnish
+ dictionary entry (Bug#4579).
+
+2009-10-23 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (top): Remove `tramp-rfn-eshadow-update-overlay'
+ from `rfn-eshadow-update-overlay-hook' when unloading.
+ (tramp-methods): Add `tramp-copy-keep-tmpfile' for "rsync" and
+ "rsyncc". Adjust doc string.
+ (tramp-temp-buffer-file-name): New buffer-local defvar.
+ (tramp-handle-insert-file-contents, tramp-handle-write-region):
+ Keep temporary file when indicated by method ("rsync" and
+ "rsyncc").
+ (tramp-handle-write-region): Handle APPEND.
+ (tramp-delete-temp-file-function): New defun. Added to
+ `kill-buffer-hook'.
+
+2009-10-23 Juanma Barranquero <lekktu@gmail.com>
+
+ * menu-bar.el (cua-enable-cua-keys): Declare for the byte-compiler.
+
+2009-10-23 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * term/tty-colors.el (msdos-color-values): Remove declaration, unused.
+ (color-name-rgb-alist, tty-standard-colors)
+ (tty-color-mode-alist): Change to defconst.
+
+ * simple.el (mark-inactive): Purecopy message.
+
+ * menu-bar.el (menu-bar-make-mm-toggle, menu-bar-make-toggle): Fix macro.
+ (global-map, yank-menu):
+ * textmodes/ispell.el (ispell-menu-map):
+ * net/eudc.el (eudc-tools-menu):
+ * international/mule-cmds.el (describe-language-environment-map)
+ (setup-language-environment-map, set-coding-system-map)
+ (mule-menu-keymap):
+ * vc-hooks.el (vc-menu-entry, vc-menu-map):
+ * replace.el (occur-mode-map):
+ * pcvs-defs.el (cvs-global-menu): Purecopy names and tooltips.
+
+2009-10-23 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc.el (math-read-number, math-read-number-simple):
+ Use `save-match-data'.
+
+2009-10-22 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * simple.el (normal-erase-is-backspace-mode): Use input-decode-map
+ rather than fiddling with global-map bindings, since it should only
+ affect per-terminal settings.
+ See http://bugs.gentoo.org/show_bug.cgi?id=289709.
+
+ * minibuffer.el (completion-table-with-terminator): Allow to specify
+ the terminator-regexp.
+
+ * simple.el (switch-to-completions): Look for *Completions* in other
+ frames as well.
+
+ * pcomplete.el: Allow the use of completion-tables.
+ (pcomplete-std-complete): New command.
+ (pcomplete-dirs-or-entries): Use a single call to pcomplete-entries.
+ (pcomplete--here): Use a function for `form' rather than an expression,
+ so it can be byte-compiled.
+ (pcomplete-here, pcomplete-here*): Adjust accordingly.
+ Add edebug declaration.
+ (pcomplete-show-completions): Remove unused var `curbuf'.
+ (pcomplete-do-complete, pcomplete-stub):
+ Don't assume `completions' is a list of strings any more.
+
+2009-10-22 Juanma Barranquero <lekktu@gmail.com>
+
+ * find-dired.el (find-name-arg): Fix typo in docstring.
+
+2009-10-22 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * pcmpl-linux.el (pcomplete/kill): Don't abuse pcomplete-entries.
+ (pcmpl-linux-fs-types): Same, and update to new modules layout.
+
+ * pcmpl-gnu.el (pcmpl-gnu-makefile-names): Use a single call to
+ pcomplete-entries.
+
+ * comint.el (comint-read-input-ring, comint-write-input-ring)
+ (comint-substitute-in-file-name)
+ (comint-dynamic-complete-as-filename)
+ (comint-dynamic-simple-complete)
+ (comint-dynamic-list-filename-completions)
+ (comint-dynamic-list-completions)
+ (comint-redirect-results-list-from-process): Minor simplifications.
+
+2009-10-21 Kevin Ryde <user42@zip.com.au>
+
+ * emacs-lisp/checkdoc.el (checkdoc-file-comments-engine):
+ When inserting ";;; Code" put it before any ";;;###autoload" cookie on
+ the first form. And insert a blank line after ";;; Code" since
+ that's usual style. (Bug#4612)
+
+ * net/dns.el: Add "Keywords: comm", as per net/net-utils.el.
+
+2009-10-21 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * minibuffer.el (completion-table-with-terminator): Properly implement
+ boundaries, in case `terminator' appears in the suffix.
+ (completion--embedded-envvar-table): Don't return boundaries if
+ there's no valid completion. Simplify.
+ (completion-file-name-table): New completion table extracted from
+ completion--file-name-table.
+ (completion--file-name-table): Use it.
+ (read-file-name-predicate): Declare obsolete.
+ (read-file-name): Use the pred arg i.s.o read-file-name-predicate.
+ * vc-bzr.el (vc-bzr-revision-completion-table): Use the new
+ completion-file-name-table, and use the `pred' argument.
+ * files.el (locate-file-completion-table): Use the `pred' arg rather
+ than read-file-name-predicate.
+ (abbreviate-file-name): Use \` rather than ^ for BOS.
+
+2009-10-21 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc.el (vc-deduce-fileset): Undo previous change, do not tell
+ vc-responsible-backend to register, it causes problems.
+
+2009-10-21 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * help-fns.el: Don't require help-mode (to avoid bootstrap issues).
+
+2009-10-21 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-smb.el (tramp-smb-get-stat-capability): New defun.
+ (tramp-smb-handle-file-attributes): Use it.
+ (tramp-smb-do-file-attributes-with-stat): Don't raise an error.
+ (tramp-smb-handle-insert-directory): Use `mapc' rather than
+ `mapcar'. Use `tramp-smb-get-stat-capability'.
+ Add `dired-filename' text properties.
+ (tramp-smb-get-cifs-capabilities): Apply `save-match-data'.
+ (tramp-smb-maybe-open-connection): Simplify check for smbclient
+ version.
+
+2009-10-20 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * subr.el (read-key-delay): Reduce to 0.01.
+ (read-key): Use read-key-sequence-vector to avoid turning M-t into 244
+ (bug#4751).
+
+2009-10-19 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * bindings.el (function-key-map): Map C-@ to C-SPC if C-@ is unbound.
+
+ * info.el (Info-complete-menu-item): Handle `boundaries' explicitly.
+ (Info-menu): Remove unused vars `last' and `completions'.
+ (Info-index-nodes): Remove unused var `node'.
+
+ * info.el (Info-complete-menu-item): Use complete-with-action.
+
+2009-10-19 Dan Nicolaescu <dann@ics.uci.edu>
+
+ Make vc-annotate work through copies and renames.
+ * vc-annotate.el (vc-annotate-extract-revision-at-line):
+ Return the file name too.
+ (vc-annotate-revision-at-line)
+ (vc-annotate-find-revision-at-line)
+ (vc-annotate-revision-previous-to-line)
+ (vc-annotate-show-log-revision-at-line): Update to get the file
+ name from vc-annotate-extract-revision-at-line.
+ (vc-annotate-show-diff-revision-at-line-internal): Change the
+ argument to mean whether to show a file diff or not. Get the file
+ name from vc-annotate-extract-revision-at-line.
+ (vc-annotate-show-diff-revision-at-line):
+ Update vc-annotate-show-diff-revision-at-line call.
+ (vc-annotate-warp-revision): Add an optional file argument.
+
+ * vc-git.el (vc-git-annotate-command): Pass -C -C to the blame command.
+ (vc-git-annotate-extract-revision-at-line): Also return the file
+ name if found.
+
+ * vc-hg.el (vc-hg-annotate-command): Pass --follow to the annotate
+ command. Remove unused code.
+ (vc-hg-annotate-re): Update to match --follow output.
+ (vc-hg-annotate-extract-revision-at-line): Also return the file
+ name if found.
+
+ * vc.el: Update annotate-extract-revision-at-line documentation.
+
+2009-10-18 Kevin Ryde <user42@zip.com.au>
+
+ * ibuffer.el (ibuffer-confirm-operation-on): Correction to error
+ re-throw, `err' is a pair not a list so can't use apply (Bug#4740).
+
+ * net/browse-url.el (browse-url): Identify alist with "consp and
+ not functionp" and let all other things go down the `apply' leg,
+ as suggested by Stefan. (Further to bug#4531.)
+
+2009-10-18 Chong Yidong <cyd@stupidchicken.com>
+
+ * minibuffer.el (read-file-name): Check for repeat before putting
+ a default argument in file-name-history (Bug#4657).
+
+ * emacs-lisp/lisp-mode.el (preceding-sexp): Recognize hash table
+ read syntax (Bug#4737).
+
+ * textmodes/sgml-mode.el (sgml-delete-tag): Use sgml-looking-back-at.
+
+2009-10-18 Aaron S. Hawley <aaron.s.hawley@gmail.com>
+
+ * textmodes/sgml-mode.el (sgml-tag-help): Prompt user for tag.
+ (html-tag-alist, html-tag-help): Add descriptions for undocumented
+ entries and make note of obsolete tags.
+
+2009-10-18 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * net/ange-ftp.el (ange-ftp-file-size): Use unwind-protect.
+
+2009-10-18 Glenn Morris <rgm@gnu.org>
+
+ * Makefile.in (compile-last): Ensure GREP_OPTIONS is null before calling
+ grep, so that binary files (eg international/uni-bidi.el) can match.
+ Remove test for "UnicodeData" files, since it is hopefully unnecessary
+ now, and in any case the file header format has changed.
+
+2009-10-17 Glenn Morris <rgm@gnu.org>
+
+ * textmodes/flyspell.el (flyspell-large-region, flyspell-word)
+ (flyspell-get-word, flyspell-large-region)
+ (flyspell-auto-correct-previous-word): Doc/error message fixes.
+
+2009-10-17 Chong Yidong <cyd@stupidchicken.com>
+
+ * Makefile.in (ELCFILES): Add ede/shell.
+
+2009-10-17 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * term/common-win.el (x-colors): Purecopy it.
+
+2009-10-17 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * tar-mode.el (tar-data-swapped-p): Make the assertion a bit more
+ permissive for when the buffer is empty.
+ (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
+ has a coding cookie, use it regardless of any other setting (bug#4712).
+
+2009-10-17 Glenn Morris <rgm@gnu.org>
+
+ * foldout.el (foldout-mouse-swallow-events):
+ * gs.el (gs-load-image): Replace obsolete forms of sit-for, sleep-for.
+
+ * dired.el (dired-ls-F-marks-symlinks, dired-keep-marker-rename)
+ (dired-keep-marker-copy, dired-keep-marker-hardlink)
+ (dired-keep-marker-symlink, dired-dwim-target)
+ (dired-copy-preserve-time): Do not autoload these defcustoms.
+
+ * mail/rmail.el (rmail-write-region-annotate): Prevent viewing different
+ messages from messing up the file coding. (Bug#4623)
+
+2009-10-17 Jari Aalto <jari.aalto@cante.net>
+
+ * textmodes/ispell.el (ispell-get-decoded-string): Give an error
+ if no match is found for the current dictionary. (Bug#4578)
+
+ * textmodes/flyspell.el (flyspell-get-word): Make `following' argument
+ optional, since that is how it is documented, and this is often called
+ with a nil argument. (Bug#4577)
+ (flyspell-external-point-words, flyspell-auto-correct-word)
+ (flyspell-correct-word-before-point, flyspell-word-search-forward)
+ (flyspell-word-search-backward): Remove nil argument in calls to
+ flyspell-get-word, since it is not needed now.
+
+2009-10-17 Ulrich Mueller <ulm@gentoo.org>
+
+ * play/doctor.el (doctor-adverbp): Exclude some nouns. (Bug#4565)
+
+2009-10-16 Glenn Morris <rgm@gnu.org>
+
+ * net/rcirc.el (rcirc-authenticate): Simplify previous change.
+
+2009-10-16 Toru TSUNEYOSHI <t_tuneyosi@hotmail.com>
+
+ * net/ange-ftp.el (ange-ftp-send-cmd): Handle `size' like `mdtm'.
+ (ange-ftp-file-size): New function.
+ (ange-ftp-file-attributes): Use it.
+
+2009-10-16 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-smb.el (tramp-smb-version): New defvar.
+ (tramp-smb-maybe-open-connection): Use it, in order to avoid
+ repeated checks.
+
+2009-10-16 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/byte-run.el (define-obsolete-variable-alias): Doc fix.
+ Maybe copy some custom properties from old to new name. (Bug#4706)
+
+2009-10-16 Juanma Barranquero <lekktu@gmail.com>
+
+ * subr.el (error, sit-for, start-process-shell-command)
+ (start-file-process-shell-command): Set the calling convention
+ after the function definition.
+
+2009-10-16 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * subr.el (error, sit-for, start-process-shell-command)
+ (start-file-process-shell-command): Use the new
+ set-advertised-calling-convention feature.
+
+2009-10-16 Taichi Kawabata <kawabata.taichi@gmail.com>
+
+ * international/ucs-normalize.el (ucs-normalize-version):
+ Change to 1.2.
+ (check-range): Adjust for Unicode 5.2.
+
+2009-10-15 Juri Linkov <juri@jurta.org>
+
+ * menu-bar.el (menu-bar-file-menu): Convert `separator-exit'
+ to the `menu-item' format.
+
+2009-10-15 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-replace-environment-variables): Do not fail
+ if the environment variable does not exist.
+
+ * net/tramp-smb.el (tramp-smb-errors): Add error messages.
+ (tramp-smb-get-share, tramp-smb-get-localname): Use only VEC as
+ parameter.
+ (tramp-smb-handle-add-name-to-file)
+ (tramp-smb-handle-copy-directory, tramp-smb-handle-copy-file)
+ (tramp-smb-handle-delete-directory, tramp-smb-handle-delete-file)
+ (tramp-smb-handle-file-attributes)
+ (tramp-smb-do-file-attributes-with-stat)
+ (tramp-smb-handle-file-local-copy)
+ (tramp-smb-handle-insert-directory)
+ (tramp-smb-handle-make-directory)
+ (tramp-smb-handle-make-directory-internal)
+ (tramp-smb-handle-make-symbolic-link)
+ (tramp-smb-handle-rename-file, tramp-smb-handle-set-file-modes)
+ (tramp-smb-handle-write-region, tramp-smb-get-file-entries)
+ (tramp-smb-maybe-open-connection): Apply the changed parameters.
+ (tramp-smb-read-file-entry): Read Disk names in compressed format.
+ Handle long file names.
+ (tramp-smb-get-cifs-capabilities): Check, whether the connection
+ process is running.
+ (tramp-smb-maybe-open-connection): Trace "smbclient -V" command.
+ Read share names with "-g" option.
+
+2009-10-15 Ryan Yeske <rcyeske@gmail.com>
+
+ * net/rcirc.el (rcirc-view-log-file): New command.
+ (rcirc-track-minor-mode-map): Remove C-c ` binding.
+ (rcirc-authenticate, rcirc-authinfo): Allow nickserv-nick to be
+ specified.
+
+2009-10-15 Glenn Morris <rgm@gnu.org>
+
+ * w32-fns.el (w32-batch-update-autoloads): Take autoload-make-program
+ from the second command-line argument.
+ * makefile.w32-in (autoloads, $(lisp)/calendar/cal-loaddefs.el)
+ ($(lisp)/calendar/diary-loaddefs.el, $(lisp)/calendar/hol-loaddefs.el)
+ ($(lisp)/mh-e/mh-loaddefs.el): Pass $(MAKE) as second argument to
+ w32-batch-update-autoloads.
+ * emacs-lisp/autoload.el (autoload-make-program): New variable.
+ (batch-update-autoloads): Handle autoload-excludes on windows-nt.
+
+ * mail/rmailedit.el (rmail-cease-edit): Give an error if the end of
+ the headers cannot be located. Simplify, subtracting superflous
+ save-excursions.
+
+2009-10-15 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Replace completion-base-size by completion-base-position to fix bugs
+ such as (bug#4699).
+ * simple.el (completion-base-position): New var.
+ (completion-base-size): Mark as obsolete.
+ (choose-completion): Make it work for mouse events as well.
+ Pass the new base-position to choose-completion-string.
+ (choose-completion-guess-base-position): New function, extracted from
+ choose-completion-delete-max-match.
+ (choose-completion-delete-max-match): Use it. Make obsolete.
+ (choose-completion-string): Use the new base-position info.
+ (completion-root-regexp): Delete.
+ (completion-setup-function): Preserve completion-base-position.
+ Eliminate obsolete base-size manipulation.
+ * minibuffer.el (display-completion-list): Don't mess with base-size.
+ (minibuffer-completion-help): Set completion-base-position instead.
+ * mouse.el (mouse-choose-completion): Redefine as a mere alias to
+ choose-completion.
+ * textmodes/bibtex.el (bibtex-complete):
+ * emacs-lisp/crm.el (crm--choose-completion-string):
+ Adjust to new calling convention.
+ * complete.el (partial-completion-mode): Use minibufferp to avoid
+ bumping into incompatible change to choose-completion-string-functions.
+ * ido.el (ido-choose-completion-string): Make its calling convention
+ more permissive.
+ * comint.el (comint-dynamic-list-input-ring-select): Remove obsolete
+ base-size manipulation.
+ (comint-dynamic-list-input-ring): Use dotimes and push.
+ * iswitchb.el (iswitchb-completion-help): Remove dead-code call to
+ fundamental-mode. Use `or'.
+
+2009-10-14 Juri Linkov <juri@jurta.org>
+
+ * misearch.el (multi-isearch-next-buffer-from-list)
+ (multi-isearch-next-file-buffer-from-list): Doc fix. (Bug#4723)
+
+2009-10-14 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * Makefile.in (compile-onefile): Load `bytecomp' rather than
+ `bytecomp.el'.
+
+ * minibuffer.el (completion-pcm--merge-completions): Make sure the
+ string we return is all made up of text from the completions rather
+ than part from the completions and part from the input (bug#4219).
+
+ * ido.el (ido-everywhere): Use define-minor-mode.
+
+ * buff-menu.el (list-buffers, ctl-x-map):
+ Mark the entry points with ;;;###autoload cookies.
+
+2009-10-14 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-git.el (vc-git-dir-extra-headers): Set the branch name
+ correctly in the detached head case.
+ (vc-git-print-log): Remove unused binding.
+
+ * vc.el (vc-responsible-backend): When a directory is passed for
+ for registration create a VC repository if no backend is
+ responsible for the directory argument.
+ (vc-deduce-fileset): Tell vc-responsible-backend to register.
+
+ * vc.el: Move comments about RCS and SCCS ...
+ * vc-rcs.el:
+ * vc-sccs.el: ... here, respectively.
+
+2009-10-14 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * minibuffer.el (completion--file-name-table): Return nil if there's
+ no file completion, even if substitute-in-file-name changed
+ the string (bug#4708).
+
+2009-10-13 Juri Linkov <juri@jurta.org>
+
+ * files-x.el (read-file-local-variable-value): Don't filter out
+ minor modes from mode name completion (bug#4664).
+
+2009-10-13 Juanma Barranquero <lekktu@gmail.com>
+
+ * international/mule-cmds.el (ucs-names): Remove exclusion of
+ "Enclosed Ideographic Supplement" range (U+1F200..U+1F2FF).
+
+2009-10-13 Kenichi Handa <handa@m17n.org>
+
+ * international/uni-name.el: Regenerated.
+
+2009-10-13 Juanma Barranquero <lekktu@gmail.com>
+
+ * bs.el (bs-mode): Fix last change. (`revert-buffer-function'
+ should be automatically buffer-local, but isn't.)
+
+2009-10-12 Sam Steingold <sds@gnu.org>
+
+ * progmodes/compile.el (compilation-next-error-function): Fix the
+ timestamps if the buffer has been visited before.
+ (compilation-mode-font-lock-keywords): Do not prepend "^ *" to
+ non-anchored patterns, like the perl one (bug#3928).
+
+2009-10-12 Glenn Morris <rgm@gnu.org>
+
+ * net/tramp-smb.el (tramp-smb-do-file-attributes-with-stat):
+ Let-bind `size'.
+
+2009-10-12 Juanma Barranquero <lekktu@gmail.com>
+
+ * proced.el (proced-unload-function): New function.
+
+ * bs.el (bs-mode): Set `revert-buffer-function' to `bs-refresh'.
+ (bs-refresh): Add IGNORED arg for `revert-buffer' compatibility.
+ Doc fix.
+
+ * menu-bar.el (menu-bar-file-menu): Fix format of `separator-exit' item.
+
+2009-10-11 Juri Linkov <juri@jurta.org>
+
+ * files-x.el (read-file-local-variable-value):
+ Provide default value only for bound variables (bug#4664).
+
+2009-10-11 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-local-host-p): Function shall return nil for
+ connection methods like smb.
+
+ * net/tramp-cache.el (tramp-flush-connection-property): The hash
+ can be empty.
+
+ * net/tramp-smb.el (tramp-smb-errors): Add error messages.
+ (tramp-smb-file-name-handler-alist): Add handlers for
+ `add-name-to-file', `make-symbolic-link'.
+ (tramp-smb-handle-add-name-to-file)
+ (tramp-smb-do-file-attributes-with-stat)
+ (tramp-smb-handle-make-symbolic-link)
+ (tramp-smb-get-cifs-capabilities): New defuns.
+ (tramp-smb-handle-copy-directory, tramp-smb-handle-copy-file)
+ (tramp-smb-handle-delete-directory, tramp-smb-handle-delete-file)
+ (tramp-smb-handle-file-local-copy)
+ (tramp-smb-handle-make-directory-internal)
+ (tramp-smb-handle-rename-file, tramp-smb-handle-write-region):
+ The file name syntax depends on cifs capabilities.
+ (tramp-smb-handle-file-attributes):
+ Call `tramp-smb-do-file-attributes-with-stat' if possible.
+ (tramp-smb-handle-insert-directory): Use posix attributes if possible.
+ (tramp-smb-handle-set-file-modes): It is applicable for posix only.
+
+2009-10-11 Chong Yidong <cyd@stupidchicken.com>
+
+ * emacs-lisp/eieio.el: Avoid requiring cl at runtime.
+ (eieio-defclass): Apply deftype handler and setf-method properties
+ directly.
+ (eieio-add-new-slot): Avoid union function from cl library.
+ (eieio--typep): New function.
+ (eieio-perform-slot-validation): Use it.
+
+2009-10-10 Karl Fogel <kfogel@red-bean.com>
+
+ * bookmark.el (bookmark-yank-word, bookmark-insert-current-bookmark):
+ Update documentation to refer to the variables documented in r1.135.
+ (Bug#4188)
+
+2009-10-10 Karl Fogel <kfogel@red-bean.com>
+
+ * bookmark.el (Info-suffix-list): Remove this unused variable.
+ (bookmark-current-point): Remove this obsolete variable.
+ (bookmark-set, bookmark-rename, bookmark-send-edited-annotation):
+ Adjust for removal of bookmark-current-point.
+
+ (bookmarks-already-loaded, bookmark-current-buffer)
+ (bookmark-yank-point): Document. (Bug#4188)
+
+2009-10-10 Glenn Morris <rgm@gnu.org>
+
+ * frame.el (frame-height): Doc fix.
+
+ * calendar/calendar.el (calendar-split-width-threshold): New option.
+ (calendar-basic-setup): Use calendar-split-width-threshold.
+
+2009-10-09 Juanma Barranquero <lekktu@gmail.com>
+
+ * international/mule-cmds.el (ucs-names): Exclude new "Enclosed
+ Ideographic Supplement" range (U+1F200..U+1F2FF).
+
+2009-10-09 Karl Fogel <kfogel@red-bean.com>
+
+ * bookmark.el (bookmark-bmenu-rename): Don't call bookmark-bmenu-list,
+ since the list will have been rebuilt anyway. (Bug#4349)
+
+2009-10-09 Karl Fogel <kfogel@red-bean.com>
+
+ * bookmark.el (bookmark-delete): Don't let batch arg prevent saving.
+ (bookmark-bmenu-execute-deletions): Don't save here, as
+ bookmark-delete will now do so if necessary.
+ Suggested by Thierry Volpiatto <thierry.volpiatto {_AT_} gmail.com>.
+ (Bug#4348)
+
+2009-10-09 Glenn Morris <rgm@gnu.org>
+
+ * mail/emacsbug.el (report-emacs-bug): Also print `features'.
+
+2009-10-09 Karl Fogel <kfogel@red-bean.com>
+
+ * bookmark.el (bookmark-jump): Add new `display-func' parameter.
+ (bookmark-jump-other-window): Just invoke bookmark-jump with new
+ argument now, so the two function's behaviors will match. (Bug#3645)
+
+2009-10-08 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-file-name-real-user, tramp-file-name-domain)
+ (tramp-file-name-real-host, tramp-file-name-port):
+ Apply `save-match-data'.
+
+ * net/tramp-smb.el (tramp-smb-handle-copy-directory): Handle the
+ case both directories are remote.
+ (tramp-smb-handle-expand-file-name): Implement "~" expansion.
+ (tramp-smb-maybe-open-connection): Flush the cache only if necessary.
+
+2009-10-07 Juanma Barranquero <lekktu@gmail.com>
+
+ * makefile.w32-in (WINS_UPDATES): Fix typo in previous change.
+
+2009-10-07 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/autoload.el (batch-update-autoloads): Remove useless use
+ of concat.
+
+2009-10-07 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * files-x.el (read-file-local-variable): Include some
+ non-user-variables in the completion table (bug#4664).
+
+2009-10-07 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-cache.el (tramp-flush-connection-property): Add trace
+ message.
+
+ * net/tramp-smb.el (tramp-smb-errors): Add error messages.
+ (tramp-smb-file-name-handler-alist): Add handler for
+ `copy-directory', `expand-file-name', `set-file-modes'.
+ (tramp-smb-handle-copy-directory)
+ (tramp-smb-handle-expand-file-name)
+ (tramp-smb-handle-set-file-modes): New defuns.
+ (tramp-smb-handle-copy-file): Handle KEEP-DATE.
+ (tramp-smb-handle-file-attributes): Simplify check for retrieving
+ entry.
+ (tramp-smb-handle-insert-directory): Don't flush the cache.
+ (tramp-smb-maybe-open-connection): Check for samba client and
+ server versions.
+
+2009-10-07 Eli Zaretskii <eliz@gnu.org>
+
+ * emacs-lisp/autoload.el (batch-update-autoloads): Fix last change
+ to not error out of search for "^lisp=" fails.
+
+2009-10-07 Juanma Barranquero <lekktu@gmail.com>
+
+ * makefile.w32-in (WINS_UPDATES): New macro.
+ (custom-deps, finder-data, autoloads): Use it.
+
+2009-10-07 Glenn Morris <rgm@gnu.org>
+
+ * Makefile.in (autoloads): Revert previous change.
+ * emacs-lisp/autoload.el (batch-update-autoloads): Rather than having
+ the list of preloaded files passed on the command-line, get
+ it from src/Makefile.
+
+ * calendar/calendar.el (calendar-basic-setup): In the wide frame case,
+ show the original buffer rather than a random one.
+
+2009-10-07 Markus Rost <rost@math.uni-bielefeld.de>
+
+ * help.el (describe-no-warranty): Place point in a slightly better
+ position in the GPLv3 text.
+
+2009-10-06 Sam Steingold <sds@gnu.org>
+
+ * net/tramp-compat.el (tramp-compat-process-running-p): Check that
+ the comm attribute is present before calling regexp-quote.
+
+2009-10-06 Juanma Barranquero <lekktu@gmail.com>
+
+ * play/animate.el (animate-string): For good effect, make sure
+ `indent-tabs-mode' and `show-trailing-whitespace' are nil.
+
+ * play/animate.el (animate-sequence, animate-birthday-present):
+ * misc.el (butterfly): Don't set `indent-tabs-mode'.
+
+2009-10-06 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/byte-run.el (define-obsolete-face-alias): Doc fix.
+
+ * emacs-lisp/autoload.el (autoload-excludes): New variable.
+ (autoload-generate-file-autoloads): Skip files in autoload-excludes.
+ (batch-update-autoloads): Process a string value of autoload-excludes,
+ set during the build process.
+ * Makefile.in (autoloads): Skip preloaded files. (Bug#4446)
+
+ * net/tramp.el (tramp-handle-start-file-process): Move tramp-error call
+ inside with-parsed... macro so that `v' is defined.
+
+ * progmodes/f90.el (f90-end-of-block, f90-beginning-of-block):
+ * progmodes/fortran.el (fortran-end-of-block)
+ (fortran-beginning-of-block):
+ Also push mark in the macro case.
+
+ * emerge.el (emerge-show-file-name):
+ * calc/calc.el (calc-quit):
+ * calc/calc-misc.el (calc-big-or-small):
+ * calc/calc-graph.el (calc-graph-view):
+ * calc/calc-ext.el (calc-reset):
+ * calendar/calendar.el (calendar-basic-setup):
+ Use window-full-height-p.
+
+ * mail/rmailedit.el (rmail-cease-edit): If there is a Content-Type
+ header we don't understand, don't insert another. (Bug#4624)
+ If changing mime charset, insert the new one in the right place.
+
+2009-10-06 Matthew Junker <matthew.junker@sbcglobal.net> (tiny change)
+
+ * calendar/cal-tex.el (cal-tex-cursor-month-landscape)
+ (cal-tex-cursor-month): Correctly increment the end date for diary and
+ holiday listing. (Bug#4626)
+
+2009-10-05 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * help-fns.el (describe-function-1): Don't burp if the function is not
+ a symbol.
+
+2009-10-05 Juanma Barranquero <lekktu@gmail.com>
+
+ * emacs-lisp/chart.el (chart-face-pixmap-list, chart-new-buffer, chart)
+ (chart-axis-range, chart-axis-names, chart-sequece, chart-bar)
+ (chart-draw, chart-axis-draw, chart-sort, chart-sort-matchlist)
+ (chart-draw-line, chart-bar-quickie): Fix typos in docstrings.
+
+ * emacs-lisp/eieio.el (generic-p, eieiomt-next, eieio-generic-form)
+ (eieio-default-superclass): Reflow docstrings.
+ (this, class-option-assoc, defclass, eieio-class-un-autoload)
+ (eieio-unbind-method-implementations, defmethod)
+ (eieio-validate-slot-value, eieio-validate-class-slot-value)
+ (oref-default, eieio-oref-default, eieio-oset, eieio-oset-default)
+ (with-slots, eieio-add-new-slot, object-assoc, object-remove-from-list)
+ (eieio-slot-originating-class-p, eieio-slot-name-index)
+ (eieio-pre-method-execution-hooks, eieio-initarg-to-attribute)
+ (constructor, initialize-instance, no-next-method, object-print)
+ (object-write, eieio-override-prin1, eieio-edebug-prin1-to-string):
+ Fix typos in docstrings.
+ (eieio-defclass, eieio-perform-slot-validation-for-default, defgeneric)
+ (child-of-class-p, object-slots, slot-boundp, slot-exists-p)
+ (next-method-p): Doc fixes.
+ (eieio-add-new-slot, call-next-method, eieiomt-add, change-class):
+ Fix typos in error messages.
+ (eieio-defmethod): Fix typo in description of generic method.
+
+ * emacs-lisp/eieio-base.el (eieio-instance-inheritor, slot-unbound)
+ (eieio-persistent-save-interactive, slot-missing):
+ Fix typos in docstrings.
+ (eieio-instance-inheritor-slot-boundp): Doc fix.
+
+ * emacs-lisp/eieio-comp.el (byte-compile-file-form-defmethod)
+ (byte-compile-defmethod-param-convert): Fix typos in docstrings.
+
+ * emacs-lisp/eieio-custom.el (eieio-done-customizing)
+ (eieio-custom-object-apply-reset):
+ Fix typos in docstrings and error messages.
+
+ * emacs-lisp/eieio-datadebug.el (data-debug-show):
+ Fix typo in docstring.
+
+ * emacs-lisp/eieio-opt.el (top): Fix typo in error message.
+ (eieio-browse-tree): Doc fix.
+ (eieio-all-generic-functions, eieio-class-speedbar): Reflow docstrings.
+ (eieio-help-mode-augmentation-maybee, eieio-class-speedbar-make-map):
+ Fix typos in docstrings.
+
+ * emacs-lisp/eieio-speedbar.el (eieio-speedbar-file-button): Doc fix.
+ (eieio-speedbar-key-map, eieio-speedbar-create-engine)
+ (eieio-speedbar-buttons, eieio-speedbar, eieio-speedbar-object-children)
+ (eieio-speedbar-make-tag-line, eieio-speedbar-object-expand):
+ Reflow docstrings.
+
+2009-10-05 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-hg.el (log-view-vc-backend): Declare for compiler.
+ (vc-hg-outgoing-mode, vc-hg-incoming-mode):
+ Set log-view-vc-backend so that diff can work.
+
+ * log-view.el (log-view-diff): Use vc-diff-internal instead of
+ vc-version-diff.
+ (vc-diff-internal): Autoload this instead of vc-version-diff.
+
+2009-10-05 Eli Zaretskii <eliz@gnu.org>
+
+ * simple.el (eval-expression): Doc fix.
+
+ * progmodes/cwarn.el (cwarn-mode): Doc fix.
+
+2009-10-05 Michael Albinus <michael.albinus@gmx.de>
+
+ * files.el (directory-files-no-dot-files-regexp): New defconst.
+ (delete-directory): Use it.
+ (copy-directory): Use it. Remove parameter PRESERVE-UID-GID.
+
+ * net/tramp.el (tramp-verbose): Fix docstring.
+ (tramp-methods): Add recursive option to `tramp-copy-args'.
+ Add `tramp-copy-recursive'. Valid for "rcp", "scp", "scp1", "scp2",
+ "scp1_old", "scp2_old", "rsync", "rsyncc".
+ (tramp-default-method): Check also for `auth-source-user-or-password'.
+ (tramp-file-name-handler-alist, tramp-file-name-for-operation):
+ Add handler for `copy-directory'.
+ (tramp-handle-copy-directory): New defun.
+ (tramp-do-copy-or-rename-file-out-of-band): Handle directory case.
+ (tramp-handle-start-file-process): Raise an error when PROGRAM is nil.
+ Optimize sent command.
+
+2009-10-05 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * calendar/diary-lib.el (diary-show-all-entries): Re-fit the calendar
+ window if necessary.
+
+ * calendar/calendar.el (calendar-basic-setup): Don't call
+ switch-to-buffer in a dedicated window.
+
+2009-10-05 Karl Fogel <kfogel@red-bean.com>
+
+ * bookmark.el (bookmark-handle-bookmark): If bookmark has no file,
+ don't do anything related to relocating, just return nil.
+ (bookmark-error-no-filename): New error.
+ (bookmark-default-handler): Signal `bookmark-error-no-filename' if
+ bookmark has no file. Don't even attempt to handle things that
+ are not files; the whole point of custom handlers is to keep that
+ knowledge elsewhere anyway. Tighten some comments.
+ (bookmark-file-or-variation-thereof): Remove now-unused function.
+ (bookmark-location): Doc string fix.
+ (Bug#4250)
+
+2009-10-04 Karl Fogel <kfogel@red-bean.com>
+
+ * bookmark.el (bookmark-handle-bookmark): When relocating a bookmark,
+ don't use a file dialog, because they usually don't know how to read
+ a directory target from the user. (Bug#4230)
+ Also, make sure the prompt can display directories as well as files.
+
+2009-10-04 Karl Fogel <kfogel@red-bean.com>
+
+ * bookmark.el (bookmark-set, bookmark-buffer-name):
+ Improve doc strings. (Bug#1193)
+
+2009-10-04 Karl Fogel <kfogel@red-bean.com>
+
+ * bookmark.el (bookmark-get-bookmark, bookmark-get-bookmark-record)
+ (bookmark-set-name, bookmark-prop-get, bookmark-prop-set)
+ (bookmark-get-annotation, bookmark-set-annotation)
+ (bookmark-get-filename, bookmark-set-filename, bookmark-get-position)
+ (bookmark-set-position, bookmark-get-front-context-string)
+ (bookmark-set-front-context-string, bookmark-get-rear-context-string)
+ (bookmark-set-rear-context-string, bookmark-location, bookmark-jump)
+ (bookmark-jump-other-window, bookmark-handle-bookmark)
+ (bookmark-relocate, bookmark-insert-location, bookmark-rename)
+ (bookmark-insert, bookmark-delete, bookmark-time-to-save-p)
+ (bookmark-edit-annotation-mode, bookmark-edit-annotation):
+ Improve doc strings to say whether bookmark can be a string or
+ a record or both, and make other consistency and clarity fixes.
+ (bookmark-get-handler, bookmark--jump-via, bookmark-write-file)
+ (bookmark-default-annotation-text, bookmark-yank-word)
+ (bookmark-maybe-load-default-file, bookmark-maybe-sort-alist)
+ (bookmark-import-new-list, bookmark-maybe-rename)
+ (bookmark-bmenu-show-filenames, bookmark-bmenu-hide-filenames)
+ (bookmark-bmenu-bookmark): Give these doc strings.
+ (bookmark-bmenu-check-position): Give this a doc string, but also
+ add a FIXME comment about how the function may be pointless.
+ (bookmark-default-handler): Rework doc string and change a
+ parameter name, to clarify that this takes a bookmark record
+ not a bookmark name.
+ (bookmark-set): Change a parameter name to indicate its meaning,
+ and improve the doc string a bit.
+ (Bug#4188)
+
+2009-10-04 Karl Fogel <kfogel@red-bean.com>
+
+ * bookmark.el (bookmark-alist): Document the new `handler' element
+ in the param alist.
+ (bookmark-make-record-function): Adjust documentation for above.
+ (Bug#4193)
+
+2009-10-04 Karl Fogel <kfogel@red-bean.com>
+
+ * info.el (Info-bookmark-make-record): Document this function.
+ (Info-bookmark-jump): Document with a doc string, not just a comment.
+ (Bug#4203)
+
+2009-10-04 Michael Albinus <michael.albinus@gmx.de>
+
+ * files.el (copy-directory): New defun.
+
+ * dired-aux.el (dired-copy-file-recursive): Use it.
+
+2009-10-04 Juanma Barranquero <lekktu@gmail.com>
+
+ * files-x.el (modify-dir-local-variable)
+ (copy-dir-locals-to-file-locals-prop-line): Fix typos in
+ docstrings.
+
+ * recentf.el (recentf-unload-function): New function.
+
+2009-10-04 Glenn Morris <rgm@gnu.org>
+
+ * window.el (window-full-height-p): Add doc string.
+
+2009-10-04 Martin Rudalics <rudalics@gmx.at>
+
+ * window.el (window-full-height-p): New function. (Bug#4543)
+
+2009-10-03 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc.el: Remove commented out code.
+ (vc-derived-from-dir-mode): Remove, unused.
+ (vc-version-diff, vc-diff): Consistently pass t to vc-deduce-fileset.
+
+2009-10-03 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-ftp.el (tramp-ftp-file-name-handler):
+ Disable `file-name-handler-alist' when loading 'ange-ftp. Otherwise,
+ there could be recursive loading when `default-directory' is a
+ remote file name. (Bug#4614)
+
+2009-10-03 Glenn Morris <rgm@gnu.org>
+
+ * calendar/calendar.el (calendar-basic-setup): Handle the case where
+ the frame is wide.
+ (calendar-generate-window): Test for shrinkability rather than width.
+
+ * mail/rmail.el (rmail-generate-viewer-buffer): Be more careful about
+ reusing existing buffers, in case we happen to visit two files with the
+ same basename. (Bug#4593)
+
+2009-10-02 Eli Zaretskii <eliz@gnu.org>
+
+ * makefile.w32-in (update-subdirs-CMD): Add cedet to $(WINS_SUBDIR).
+ (WINS_CEDET_SUBDIRS): List of subdirectories of cedet.
+ (bootstrap-clean-CMD, bootstrap-clean-SH): Remove *.elc files in
+ subdirs of cedet as well.
+ (AUTOGENEL): Add loaddefs.el files in cedet subdirectories.
+
+2009-10-02 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/eldoc.el (eldoc-get-fnsym-args-string):
+ Obey advertised-signature-table.
+
+ * help-fns.el (help-function-arglist): Don't check
+ advertised-signature-table.
+ (describe-function-1): Do it here instead so it also applies to subrs.
+
+2009-10-02 Michael Albinus <michael.albinus@gmx.de>
+
+ * simple.el (start-file-process): Say in the doc-string, that file
+ handlers might not support pty association, if PROGRAM is nil.
+
+ * net/ange-ftp.el (ange-ftp-generate-passwd-key): Check, whether
+ HOST and USER are strings. They are nil, when there are
+ incomplete entries in ~/.netrc, for example.
+ (ange-ftp-delete-directory): Implement RECURSIVE case. Change to
+ root directory ("device busy" error otherwise).
+
+ * net/tramp-smb.el (tramp-smb-handle-make-directory-internal):
+ Flush file properties of created directory.
+
+2009-10-02 Eli Zaretskii <eliz@gnu.org>
+
+ * makefile.w32-in (WINS_BASIC): Remove cedet.
+ (WINS_CEDET): Add cedet.
+ (update-subdirs-SH): Use $(WINS_SUBDIR), not $(WINS).
+
+2009-10-02 Kevin Ryde <user42@zip.com.au>
+
+ * net/browse-url.el (browse-url): Pass any symbol in
+ browse-url-browser-function to `apply', since if you've mistakenly put
+ an unbound symbol then the error is clearer. (Bug#4531)
+
+2009-10-02 Juanma Barranquero <lekktu@gmail.com>
+
+ * allout.el (allout-init, allout-back-to-current-heading)
+ (allout-beginning-of-current-entry, allout-ascend-to-depth)
+ (allout-ascend, allout-up-current-level, allout-end-of-level)
+ (allout-previous-visible-heading, allout-forward-current-level)
+ (allout-backward-current-level, allout-show-children):
+ * apropos.el (apropos-describe-plist):
+ * bookmark.el (bookmark-maybe-historicize-string, bookmark-bmenu-list):
+ * comint.el (comint-strip-ctrl-m, comint-goto-process-mark):
+ * completion.el (add-completion, add-permanent-completion):
+ * descr-text.el (describe-text-category, describe-char):
+ * desktop.el (desktop-lazy-abort):
+ * dired-x.el (dired-omit-expunge, dired-x-bind-find-file):
+ * dired.el (dired-build-subdir-alist):
+ * ediff.el (ediff-version):
+ * elide-head.el (elide-head, elide-head-show):
+ * emerge.el (emerge-version):
+ * env.el (getenv):
+ * face-remap.el (variable-pitch-mode):
+ * faces.el (describe-face):
+ * ffap.el (ffap-next-url, find-file-at-point, ffap-at-mouse)
+ (dired-at-point):
+ * files.el (find-file-existing, auto-save-mode):
+ * font-lock.el (font-lock-fontify-buffer):
+ * help-fns.el (describe-function, describe-variable)
+ (describe-syntax, describe-categories):
+ * help.el (view-lossage, describe-bindings, describe-key)
+ (describe-mode):
+ * hexl.el (hexl-current-address):
+ * hi-lock.el (hi-lock-mode, hi-lock-find-patterns):
+ * info.el (Info-goto-emacs-key-command-node):
+ * log-edit.el (log-edit-insert-cvs-template)
+ (log-edit-insert-cvs-rcstemplate):
+ * menu-bar.el (menu-bar-mode):
+ * mouse.el (mouse-appearance-menu):
+ * newcomment.el (comment-indent-new-line):
+ * pgg.el (pgg-save-coding-system, pgg-encrypt-region)
+ (pgg-encrypt-symmetric-region, pgg-encrypt-symmetric)
+ (pgg-encrypt, pgg-decrypt-region, pgg-decrypt)
+ (pgg-sign-region, pgg-sign, pgg-verify-region, pgg-verify):
+ * recentf.el (recentf-mode):
+ * savehist.el (savehist-mode, savehist-save):
+ * shadowfile.el (shadow-copy-files):
+ * simple.el (kill-ring-save, next-line, previous-line)
+ (normal-erase-is-backspace-mode):
+ * strokes.el (strokes-update-window-configuration)
+ (strokes-load-user-strokes, strokes-prompt-user-save-strokes)
+ (strokes-xpm-for-stroke):
+ * time.el (emacs-uptime, emacs-init-time):
+ * tutorial.el (tutorial--describe-nonstandard-key)
+ (tutorial--detailed-help):
+ * type-break.el (type-break-mode)
+ (type-break-mode-line-message-mode, type-break-query-mode)
+ (type-break-guesstimate-keystroke-threshold):
+ * vc.el (vc-version-diff, vc-diff, vc-root-diff):
+ * version.el (emacs-version):
+ * vt-control.el (vt-keypad-on, vt-keypad-off, vt-numlock):
+ * winner.el (winner-mode):
+ * calendar/timeclock.el (timeclock-in, timeclock-out)
+ (timeclock-status-string, timeclock-change)
+ (timeclock-workday-remaining-string)
+ (timeclock-workday-elapsed-string)
+ (timeclock-when-to-leave-string):
+ * calendar/todo-mode.el (todo-add-category):
+ * emacs-lisp/advice.el (ad-enable-regexp, ad-disable-regexp):
+ * emacs-lisp/autoload.el (update-file-autoloads):
+ * emacs-lisp/checkdoc.el (checkdoc-current-buffer)
+ (checkdoc-start, checkdoc-continue, checkdoc-rogue-spaces)
+ (checkdoc-message-text, checkdoc-defun):
+ * emacs-lisp/debug.el (debugger-list-functions):
+ * emacs-lisp/easy-mmode.el (easy-mmode-define-navigation):
+ * emacs-lisp/eieio-opt.el (eieio-describe-class)
+ (eieio-describe-generic):
+ * emacs-lisp/lisp-mnt.el (lm-synopsis):
+ * emacs-lisp/shadow.el (list-load-path-shadows):
+ * emulation/cua-base.el (cua-mode):
+ * emulation/edt.el (edt-set-scroll-margins):
+ * emulation/tpu-edt.el (tpu-toggle-newline-and-indent)
+ (tpu-toggle-regexp, tpu-toggle-search-direction)
+ (tpu-toggle-rectangle, tpu-toggle-control-keys):
+ * emulation/tpu-extras.el (tpu-set-scroll-margins):
+ * emulation/viper-cmd.el (viper-set-searchstyle-toggling-macros)
+ (viper-set-parsing-style-toggling-macro)
+ (viper-set-emacs-state-searchstyle-macros):
+ * emulation/viper.el (viper-set-hooks):
+ * eshell/esh-mode.el (eshell-truncate-buffer):
+ * international/mule-cmds.el (prefer-coding-system)
+ (describe-input-method, describe-language-environment):
+ * international/mule-diag.el (list-character-sets)
+ (describe-character-set, describe-coding-system)
+ (describe-fontset, list-fontsets, list-input-methods):
+ * mail/sendmail.el (mail-signature):
+ * net/ange-ftp.el (ange-ftp-copy-file):
+ * net/browse-url.el (browse-url):
+ * net/eudc.el (eudc-set-server, eudc-get-attribute-list):
+ * net/quickurl.el (quickurl-add-url):
+ * net/rcirc.el (names, topic):
+ * net/xesam.el (xesam-mode):
+ * play/5x5.el (5x5-new-game):
+ * play/yow.el (apropos-zippy):
+ * progmodes/ada-mode.el (ada-mode-version):
+ * progmodes/f90.el (f90-beginning-of-subprogram, f90-end-of-subprogram)
+ (f90-end-of-block)
+ (f90-beginning-of-block):
+ * progmodes/fortran.el (fortran-end-of-block)
+ (fortran-beginning-of-block):
+ * progmodes/js.el (js-syntactic-context, js-gc, js-eval):
+ * progmodes/python.el (python-describe-symbol, python-shell):
+ * term/ns-win.el (ns-print-buffer):
+ * textmodes/bibtex.el (bibtex-end-of-entry, bibtex-url):
+ * textmodes/flyspell.el (flyspell-mode-on):
+ * textmodes/page-ext.el (set-page-delimiter, pages-directory)
+ (pages-directory-for-addresses):
+ * textmodes/table.el (table-recognize-cell)
+ (table-query-dimension, table-generate-source)
+ (table-insert-sequence, table--warn-incompatibility):
+ * textmodes/tex-mode.el (tex-validate-buffer):
+ * textmodes/texinfmt.el (texinfmt-version)
+ (texinfo-format-buffer):
+ Use `called-interactively-p' instead of `interactive-p'.
+
+2009-10-02 Juanma Barranquero <lekktu@gmail.com>
+
+ * image-mode.el (image-toggle-display):
+ * emacs-lisp/elp.el (elp-instrument-function):
+ * emacs-lisp/advice.el (ad-make-advised-definition):
+ * emacs-lisp/easy-mmode.el (define-minor-mode):
+ * net/browse-url.el (browse-url-maybe-new-window):
+ * progmodes/sh-script.el (sh-learn-buffer-indent):
+ Pass new argument 'any to `called-interactively-p'.
+
+2009-10-01 Juanma Barranquero <lekktu@gmail.com>
+
+ * 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 from Unicode 5.2.0 data.
+
+2009-10-01 Glenn Morris <rgm@gnu.org>
+
+ * Makefile.in (ELCFILES): Regenerate.
+
+2009-10-01 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * subr.el (interactive-p): Mark obsolete.
+ (called-interactively-p): Make the optional-ness of `kind' obsolete.
+ * emacs-lisp/bytecomp.el (byte-compile-fdefinition): Make it obey
+ advertised-signature-table for subroutines as well.
+
+ * emacs-lisp/byte-run.el (advertised-signature-table): New var.
+ (set-advertised-calling-convention): New function.
+ (make-obsolete, define-obsolete-function-alias)
+ (make-obsolete-variable, define-obsolete-variable-alias):
+ Make the optional-ness of `when' obsolete.
+ (define-obsolete-face-alias): Make `when' non-optional.
+ * help-fns.el (help-function-arglist):
+ * emacs-lisp/bytecomp.el (byte-compile-fdefinition):
+ Use advertised-signature-table.
+
+2009-10-01 Michael Albinus <michael.albinus@gmx.de>
+
+ * files.el (delete-directory): New defun. The original function
+ in fileio.c has been renamed to `delete-directory-internal'.
+
+ * dired.el (dired-delete-file): Call `delete-directory' with
+ RECURSIVE parameter.
+
+ * net/ange-ftp.el (ange-ftp-delete-directory): Add optional
+ parameter RECURSIVE. Implementation is missing.
+
+ * net/tramp.el (tramp-handle-make-directory): Flush upper
+ directory's file properties.
+ (tramp-handle-delete-directory): Handle optional parameter RECURSIVE.
+ (tramp-handle-dired-recursive-delete-directory): Flush directory
+ properties after the remove command only.
+
+ * net/tramp-fish.el (tramp-fish-handle-delete-directory):
+ Handle optional parameter RECURSIVE.
+
+ * net/tramp-gvfs.el (tramp-gvfs-handle-delete-directory):
+ Handle optional parameter RECURSIVE.
+
+ * net/tramp-smb.el (tramp-smb-errors): Add error message for
+ connection timeout.
+ (tramp-smb-handle-delete-directory): Handle optional parameter
+ RECURSIVE.
+
+2009-10-01 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/bytecomp.el (byte-compile-defmacro-declaration): New fun.
+ (byte-compile-file-form-defmumble, byte-compile-defmacro): Use it.
+ (byte-compile-defmacro): Use backquotes.
+
+ * files.el (cd-absolute): Don't abbreviate-file-name (bug#4599).
+
+ * vc-dispatcher.el (vc-resynch-window): Don't revert a buffer which
+ has no associated file.
+ (vc-resynch-buffer): Use vc-dir-buffers.
+
+2009-10-01 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/chart.el (chart-zap-chars, chart-bar-quickie)
+ (chart-file-count):
+ * emacs-lisp/eieio-comp.el (byte-compile-defmethod-param-convert):
+ * emacs-lisp/eieio-datadebug.el (data-debug-insert-object-button):
+ * emacs-lisp/eieio-opt.el (eieio-describe-class):
+ * emacs-lisp/eieio-speedbar.el (eieio-speedbar-create):
+ * emacs-lisp/eieio.el (defclass, eieio-defclass-autoload)
+ (eieio-copy-parents-into-subclass, make-instance, class-children)
+ (eieio-generic-form):
+
+ * vc-cvs.el (vc-cvs-parse-entry): Be more careful with the
+ match-data. (Bug#4555).
+
+ * emacs-lisp/check-declare.el (check-declare-scan): Read the declaration
+ rather than parsing it as a regexp. This relaxes the layout
+ requirements and makes errors easier to detect.
+ (check-declare-verify): Check file is regular.
+ (check-declare-directory): Doc fix.
+ * subr.el (declare-function): Doc fix.
+
+ * ibuffer.el (ibuffer-format-qualifier):
+ * isearch.el (hi-lock-regexp-okay):
+ * calc/calc.el (math-zerop):
+ * mail/uce.el (rmail-msgbeg, rmail-msgend):
+ * 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".
+
+ * emacs-lisp/elint.el (elint-init-form): Report declarations where the
+ filename is not a string.
+
+2009-09-29 Chong Yidong <cyd@stupidchicken.com>
+
+ * files.el (safe-local-eval-forms): Fix typo.
+
+2009-09-29 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * vc-hooks.el (vc-dir-buffers): New var.
+ (vc-state-refresh): New function.
+ (vc-state): Use it.
+ (vc-after-save): Always ask the backend to recompute the new state.
+ Always call vc-dir if necessary, using vc-dir-buffers.
+ * vc-dir.el (vc-dir-prepare-status-buffer, vc-dir-resynch-file):
+ Use vc-dir-buffers.
+ (vc-dir-mode): Use vc-dir-buffers rather than after-save-hook.
+ (vc-dir-prepare-status-buffer, vc-dir-update)
+ (vc-dir-resync-directory-files, vc-dir-resynch-file, vc-dir-mode):
+ Don't call expand-file-name on default-directory.
+
+2009-09-29 Juanma Barranquero <lekktu@gmail.com>
+
+ * speedbar.el (speedbar-item-delete):
+ * calc/calc-prog.el (calc-kbd-if):
+ * language/hanja-util.el (hanja-init-load): Fix typos in messages.
+
+ * epa.el (epa-key-list-mode-map):
+ * hi-lock.el (hi-lock-menu): Fix typos in menus.
+
+ * progmodes/hideshow.el (hs-allow-nesting): Reflow docstring.
+ (hs-show-hook): Fix typo in docstring.
+
+2009-09-29 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/check-declare.el (check-declare-locate): Remove pointless
+ file-name-nondirectory call preventing location of cedet files.
+ (check-declare-verify): Use literal search rather than re-search.
+ Add basic defmethod and defclass, and define-overloadable-function.
+
+ * net/tramp-smb.el (tramp-smb-handle-directory-files-and-attributes):
+ Use tramp-compat-file-attributes rather than nonexistent
+ tramp-compat-handle-file-attributes.
+
+ * Makefile.in (lisptagsfiles4): New.
+ (AUTOGENEL): Add cedet loaddefs files.
+ (TAGS, TAGS-LISP): Use $lisptagsfiles4.
+ (update-elclist, compile-always, backup-compiled-files)
+ (bootstrap-clean): Add yet another directory level.
+ (update-elclist): Use LC_COLLATE rather than COLLATE.
+ (ELCFILES): Update, via `make update-elclist'.
+
+2009-09-29 Juanma Barranquero <lekktu@gmail.com>
+
+ * makefile.w32-in (WINS_CEDET, WINS_BASIC, WINS_SUBDIR): New macros.
+ (WINS_ALMOST): Set from WINS_BASIC and WINS_CEDET.
+ (update-subdirs-CMD): Use WINS_SUBDIR, not WINS_ALMOST.
+
+2009-09-28 Andreas Schwab <schwab@linux-m68k.org>
+
+ * Makefile.in (lisptagsfiles3): Define.
+ (TAGS, TAGS-LISP): Use it.
+ (update-elclist): Add third directory level to look for elc files.
+ (compile-always): Likewise.
+ (backup-compiled-files): Likewise.
+ (bootstrap-clean): Likewise.
+ (ELCFILES): Update.
+
+2009-09-28 Chong Yidong <cyd@stupidchicken.com>
+
+ * Makefile.in (ELCFILES): Add CEDET files.
+
+2009-09-28 Michael Albinus <michael.albinus@gmx.de>
+
+ * Makefile.in (ELCFILES): Add net/tramp-imap.elc.
+
+ * net/tramp.el (top): Require tramp-imap.
+
+ * net/tramp-smb.el (tramp-smb-handle-directory-files-and-attributes):
+ Use `tramp-compat-handle-file-attributes'.
+
+2009-09-28 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * 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)
+ (whitespace-empty-at-bob-regexp, whitespace-empty-at-eob-regexp):
+ Fix doc string.
+
+2009-09-27 Chong Yidong <cyd@stupidchicken.com>
+
+ * menu-bar.el: Remove menu-bar-ediff-misc-menu from the Tools
+ menu.
+
+ * ediff-hook.el: Move menu-bar-ediff-misc-menu into
+ menu-bar-ediff-menu.
+
+ * emacs-lisp/lisp-mode.el: Add doc-string-elt property to
+ define-overloadable-function.
+
+ * progmodes/autoconf.el: Provide autoconf as well, so that this
+ file can be `require'd.
+
+ * emacs-lisp/cl-macs.el (deftype): Add to cl-loaddefs.
+
+ * emacs-lisp/autoload.el (generated-autoload-feature)
+ (generated-autoload-load-name): New vars.
+ (autoload-rubric, autoload-generate-file-autoloads): Use them.
+ (make-autoload): Recognize define-overloadable-function and
+ defclass forms (for EIEIO).
+
+ * Makefile.in (update-subdirs): Exclude cedet directory.
+
+2009-09-27 Adrian Robert <Adrian.B.Robert@gmail.com>
+
+ * term/ns-win.el: Don't set the region face background. (Bug#4381)
+
+ * faces.el: Default light-background background for region face to
+ ns_selection_color under NS.
+
+2009-09-27 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * net/imap-hash.el: New library, see NEWS.
+
+ * Makefile.in (ELCFILES): Add imap-hash.el.
+
+2009-09-27 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * help.el (help-for-help-internal): Don't purecopy the text (bug#4560).
+ * isearch.el (isearch-help-for-help-internal): Purecopy the second arg.
+ * help-macro.el (make-help-screen): Avoid using an ambiguous function
+ definition where the docstring could be taken for the return value.
+
+2009-09-26 Glenn Morris <rgm@gnu.org>
+
+ * mail/rmailmm.el (rmail-mime-show-images, rmail-mime-bulk-handler):
+ Add option to only show images below a certain size.
+ (rmail-mime-multipart-handler): Remove unnecessary save-match-data and
+ save-excursion calls.
+
+2009-09-26 Eli Zaretskii <eliz@gnu.org>
+
+ * makefile.w32-in (WINS_ALMOST): Add cedet (with its
+ subdirectories) and eieio.
+
+2009-09-26 Alan Mackenzie <acm@muc.de>
+
+ * progmodes/cc-engine.el (c-beginning-of-statement-1):
+ Correct buggy bracketing. (Bug#4289)
+
+ * progmodes/cc-langs.el (c-nonlabel-token-key): Allow quoted
+ character constants (as case labels). (Bug#4289)
+
+2009-09-25 Juri Linkov <juri@jurta.org>
+
+ * files.el (safe-local-eval-forms): Allow time-stamp in
+ before-save-hook (Bug#4554).
+
+2009-09-25 Drew Adams <drew.adams@oracle.com>
+
+ * menu-bar.el (list-buffers-directory): Doc fix.
+
+2009-09-25 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * log-edit.el (log-edit-changelog-entries): Avoid inf-loops.
+ Try and avoid copying twice the same paragraph.
+ (log-edit-changelog-paragraph, log-edit-changelog-subparagraph):
+ Remove save-excursion.
+ (log-edit-changelog-entry): Do it here instead.
+
+2009-09-25 Juanma Barranquero <lekktu@gmail.com>
+
+ * bs.el (bs--get-file-name): Use `list-buffers-directory'
+ when available, instead of hardcoding mode names. Doc fix.
+
+ * menu-bar.el (list-buffers-directory): Add docstring.
+ Make automatically buffer-local.
+
+ * dired.el (dired-mode):
+ * files.el (cd-absolute):
+ * pcvs.el (cvs-temp-buffer):
+ * pcvs-util.el (cvs-get-buffer-create):
+ * shell.el (shell-mode):
+ * vc-dir.el (vc-dir-mode):
+ Don't make `list-buffers-directory' buffer local.
+
+2009-09-25 Devon Sean McCullough <emacs-hacker@Jovi.Net>
+
+ * comint.el (comint-exec, comint-run, make-comint):
+ Doc fixes (Bug#4542).
+
+2009-09-25 Glenn Morris <rgm@gnu.org>
+
+ * mail/rmailmm.el (rmail-mime): New custom group.
+ Move all defcustoms in this file into this group.
+ (rmail-mime-media-type-handlers-alist): Revert previous change.
+ (rmail-mime-show-images): New option.
+ (rmail-mime-total-number-of-bulk-attachments): Remove variable and all
+ references to it, since it wasn't actually used for anything.
+ (rmail-mime-insert-image): New function.
+ (rmail-mime-image): Use rmail-mime-insert-image.
+ (rmail-mime-bulk-handler): Remove optional `image' argument, instead
+ obey the value of `rmail-mime-show-images' option. Print the size of
+ attachments.
+
+2009-09-25 David Engster <deng@randomsample.de>
+
+ * progmodes/hideshow.el (hs-show-block): Run `hs-show-hook'. (Bug#4548)
+
+2009-09-24 Vinicius Jose Latorre <viniciusjl@ig.com.br>
+
+ * whitespace.el: Does not highlight trailing spaces While point is
+ at end of line. Does not highligt spaces at beginning of buffer
+ while point is at beginning of buffer. Does not highlight spaces
+ at end of buffer while point is at end of buffer. (Bug#4177)
+ New version 12.0.
+ (whitespace-display-mappings): Adjust initialization.
+ (whitespace-point, whitespace-font-lock-refontify): New vars.
+ (whitespace-color-on, whitespace-color-off): Adjust code.
+ (whitespace-trailing-regexp, whitespace-empty-at-bob-regexp)
+ (whitespace-empty-at-eob-regexp, whitespace-space-regexp)
+ (whitespace-tab-regexp, whitespace-post-command-hook): New funs.
+
+2009-09-24 Chong Yidong <cyd@stupidchicken.com>
+
+ * nxml/nxml-mode.el: Alias xml-mode to nxml-mode.
+
+ * textmodes/sgml-mode.el: Remove xml-mode alias.
+
+ * files.el (auto-mode-alist, conf-mode-maybe)
+ (magic-fallback-mode-alist): Revert 2009-09-18 and 2009-09-21 changes.
+
+2009-09-24 Alan Mackenzie <acm@muc.de>
+
+ * progmodes/cc-cmds.el (c-scan-conditionals): A new function like
+ c-forward-conditionals, but it doesn't move point and doesn't set
+ the mark.
+ (c-up-conditional, c-up-conditional-with-else, c-down-conditional)
+ (c-down-conditional-with-else, c-backward-conditional)
+ (c-forward-conditional): Refactor to use c-scan-conditionals.
+
+2009-09-24 Juanma Barranquero <lekktu@gmail.com>
+
+ * help-fns.el (help-downcase-arguments): New option, defaulting to nil.
+ (help-default-arg-highlight): Remove.
+ (help-highlight-arg): New function.
+ (help-do-arg-highlight): Use it.
+ Suggested by Drew Adams <drew.adams@oracle.com>. (Bug#4510, bug#4520)
+
+2009-09-24 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * term.el (term-set-scroll-region, term-handle-ansi-escape):
+ Undo last change, which didn't fix the problem and introduced others.
+
+2009-09-24 Nick Roberts <nickrob@snap.net.nz>
+
+ * progmodes/gdb-mi.el: Don't require speedbar.
+ (gdb-jsonify-buffer): Handle case where "=" is part of value string.
+
+2009-09-24 Glenn Morris <rgm@gnu.org>
+
+ * calendar/diary-lib.el (diary-fancy-display): Always run the hook.
+
+ * term/ns-win.el (ns-reg-to-script): Define for compiler.
+
+ * mail/rmailmm.el (rmail-mime-multipart-handler): Accept the case where
+ there is no newline after the final mime boundary. (Bug#4539)
+ Move markers on insertion so that any buttons inserted don't end up in
+ the next part of a multipart message.
+ (rmail-mime-media-type-handlers-alist): Doc fix. Add image handler.
+ (rmail-mime-bulk-handler): Optionally handle images.
+ (rmail-mime-image): New button action.
+ (rmail-mime-image-handler): New function.
+ (rmail-mime-mode): New mode.
+ (rmail-mime): Doc fix. Use rmail-mime-mode (for font-lock).
+
+2009-09-24 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * minibuffer.el (minibuffer-force-complete): Cycle the list, rather
+ than just dropping elements from it (bug#4504).
+
+ * term.el (term-set-scroll-region): Don't move cursor any more.
+ (term-handle-ansi-escape): Call term-goto here instead.
+ Suggested by Ivan Kanis <apple@kanis.eu>.
+
+ * term.el: Require CL.
+ (term-ansi-reset): New function.
+ (term-mode, term-emulate-terminal, term-handle-colors-array): Use it.
+ (term-handle-colors-array): Simplify.
+
+2009-09-24 Juanma Barranquero <lekktu@gmail.com>
+
+ * allout.el (allout-overlay-interior-modification-handler)
+ (allout-obtain-passphrase):
+ * epa-file.el (epa-file-write-region):
+ * ps-print.el (ps-begin-job):
+ * vc-hooks.el (vc-toggle-read-only):
+ * vc-rcs.el (vc-rcs-rollback):
+ * vc-sccs.el (vc-sccs-rollback):
+ * vc.el (vc-deduce-fileset, vc-next-action, vc-register-with)
+ (vc-version-diff, vc-revert, vc-rollback):
+ * wdired.el (wdired-check-kill-buffer):
+ * emacs-lisp/authors.el (authors):
+ * net/socks.el (socks-open-connection):
+ * net/zeroconf.el (zeroconf-service-add-hook):
+ * obsolete/vc-mcvs.el (vc-mcvs-register):
+ * progmodes/gdb-mi.el (def-gdb-thread-buffer-gud-command)
+ (gdb-select-frame):
+ * progmodes/grep.el (lgrep, rgrep):
+ * progmodes/idlw-help.el (idlwave-help-check-locations)
+ (idlwave-help-html-link, idlwave-help-assistant-open-link):
+ * textmodes/ispell.el (ispell-find-aspell-dictionaries):
+ * textmodes/reftex-toc.el (reftex-toc-promote-prepare)
+ (reftex-toc-rename-label): Fix typos in error messages.
+
+ * dired-aux.el (dired-do-shell-command): Reflow docstring.
+ (dired-copy-how-to-fn): Doc fix.
+ (dired-files-attributes, dired-read-shell-command):
+ Fix typos in docstrings.
+
+ * dired-x.el (dired-enable-local-variables, dired-filename-at-point)
+ (dired-x-find-file-other-window): Reflow docstrings.
+ (dired-omit-marker-char, dired-read-shell-command)
+ (dired-x-submit-report): Fix typos in docstrings.
+
+ * shell.el (shell-mode-hook):
+ * view.el (View-scroll-line-forward):
+ * progmodes/inf-lisp.el (inferior-lisp-mode-hook):
+ Fix typos in docstrings.
+
+ * net/dig.el (dig-invoke): Fix typo in docstring.
+ (query-dig): Reflow docstring.
+
+ * progmodes/idlwave.el (idlwave-create-user-catalog-file)
+ (idlwave-quoted, idlwave-rinfo-max-source-lines): Doc fixes.
+ (idlwave-abbrev-move, idlwave-auto-routine-info-updates)
+ (idlwave-begin-block-reg, idlwave-begin-unit-reg)
+ (idlwave-beginning-of-subprogram, idlwave-block-jump-out)
+ (idlwave-block-match-regexp, idlwave-calculate-paren-indent)
+ (idlwave-check-abbrev, idlwave-class-file-or-buffer)
+ (idlwave-class-found-in, idlwave-complete, idlwave-complete-in-buffer)
+ (idlwave-completion-map, idlwave-current-indent)
+ (idlwave-custom-ampersand-surround, idlwave-customize)
+ (idlwave-default-font-lock-items, idlwave-default-insert-timestamp)
+ (idlwave-define-abbrev, idlwave-determine-class-special)
+ (idlwave-do-action, idlwave-doc-header, idlwave-doc-modification)
+ (idlwave-end-block-reg, idlwave-end-of-statement)
+ (idlwave-end-of-statement0, idlwave-end-of-subprogram)
+ (idlwave-end-unit-reg, idlwave-entry-find-keyword)
+ (idlwave-explicit-class-listed, idlwave-file-header)
+ (idlwave-fill-paragraph, idlwave-find-class-definition)
+ (idlwave-fix-keywords, idlwave-hang-indent-regexp, idlwave-hard-tab)
+ (idlwave-idlwave_routine_info-compiled, idlwave-in-comment)
+ (idlwave-in-quote, idlwave-indent-action-table)
+ (idlwave-indent-expand-table, idlwave-indent-line)
+ (idlwave-indent-subprogram, idlwave-indent-to-open-paren)
+ (idlwave-is-comment-line, idlwave-is-comment-or-empty-line)
+ (idlwave-is-continuation-line, idlwave-is-pointer-dereference)
+ (idlwave-kill-autoloaded-buffers, idlwave-lib-p, idlwave-look-at)
+ (idlwave-make-tags, idlwave-mode, idlwave-mode-abbrev-table)
+ (idlwave-mouse-active-rinfo, idlwave-newline, idlwave-no-change-comment)
+ (idlwave-outlawed-buffers, idlwave-popup-select)
+ (idlwave-previous-statement, idlwave-rescan-catalog-directories)
+ (idlwave-routine-entry-compare, idlwave-routine-info.pro)
+ (idlwave-scan-all-buffers-for-routine-info, idlwave-scan-class-info)
+ (idlwave-shell-automatic-start, idlwave-shell-explicit-file-name)
+ (idlwave-show-begin, idlwave-split-line, idlwave-split-link-target)
+ (idlwave-statement-type, idlwave-struct-skip)
+ (idlwave-substitute-link-target, idlwave-toggle-comment-region)
+ (idlwave-update-current-buffer-info, idlwave-use-library-catalogs)
+ (idlwave-what-module-find-class): Fix typos in docstrings.
+ (idlwave-all-method-classes, idlwave-calc-hanging-indent)
+ (idlwave-calculate-cont-indent, idlwave-expand-equal)
+ (idlwave-find-module, idlwave-find-structure-definition)
+ (idlwave-init-rinfo-when-idle-after, idlwave-insert-source-location)
+ (idlwave-list-load-path-shadows, idlwave-next-statement)
+ (idlwave-routine-entry-compare-twins, idlwave-routine-info)
+ (idlwave-routines, idlwave-sintern-rinfo-list, idlwave-statement-match)
+ (idlwave-template): Reflow docstrings.
+
+ * progmodes/idlw-shell.el (idlwave-shell-syntax-error): Doc fix.
+ (idlwave-shell-batch-command, idlwave-shell-bp-alist)
+ (idlwave-shell-bp-get, idlwave-shell-bp-overlays)
+ (idlwave-shell-bp-query, idlwave-shell-break-here, idlwave-shell-buffer)
+ (idlwave-shell-display-line, idlwave-shell-display-wframe)
+ (idlwave-shell-electric-debug-mode, idlwave-shell-examine-select)
+ (idlwave-shell-file-name-chars, idlwave-shell-filter-bp)
+ (idlwave-shell-goto-frame, idlwave-shell-halt-messages-re)
+ (idlwave-shell-highlighting-and-faces, idlwave-shell-idl-wframe)
+ (idlwave-shell-mode-hook, idlwave-shell-mode-line-info)
+ (idlwave-shell-mode-map, idlwave-shell-module-source-filter)
+ (idlwave-shell-mouse-help, idlwave-shell-mouse-print)
+ (idlwave-shell-pc-frame, idlwave-shell-pending-commands)
+ (idlwave-shell-print, idlwave-shell-quit, idlwave-shell-redisplay)
+ (idlwave-shell-scan-for-state, idlwave-shell-send-command)
+ (idlwave-shell-sentinel-hook, idlwave-shell-separate-examine-output)
+ (idlwave-shell-shell-command, idlwave-shell-sources-alist)
+ (idlwave-shell-sources-bp, idlwave-shell-sources-filter)
+ (idlwave-shell-step, idlwave-shell-use-breakpoint-glyph)
+ (idlwave-toolbar-add-everywhere, idlwave-toolbar-toggle):
+ Fix typos in docstrings.
+ (idlwave-shell-bp, idlwave-shell-clear-current-bp)
+ (idlwave-shell-hide-output, idlwave-shell-mode)
+ (idlwave-shell-run-region, idlwave-shell-set-bp-in-module):
+ Reflow docstrings.
+
+ * textmodes/bibtex.el (bibtex-sort-entry-class): Fix group name.
+
+2009-09-24 Ivan Kanis <apple@kanis.eu>
+
+ * term.el (term-bold-attribute): New var.
+ (term-handle-colors-array): Use it.
+
+2009-09-23 Nick Roberts <nickrob@snap.net.nz>
+
+ * progmodes/gdb-mi.el (gdb-version): New variable.
+ (gdb-non-stop-handler): Set gdb-version.
+ (gdb-gud-context-command, gdb-current-context-command, gdb-stopped):
+ Condition "--thread" option on gdb-version.
+ (gdb-invalidate-threads): Remove unused argument.
+
+2009-09-23 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * textmodes/flyspell.el (sgml-mode-flyspell-verify): Pass limit args
+ to looking-back to avoid ridiculous slow down in large files (bug#4511).
+
+2009-09-23 Glenn Morris <rgm@gnu.org>
+
+ * mail/rmail.el (rmail-reply): Don't try to add a References header when
+ replying to mail without References or Message-Id. (Bug#4525)
+
+2009-09-23 Adrian Robert <Adrian.B.Robert@gmail.com>
+
+ * term/ns-win.el (ns-reg-to-script): New variable.
+
+2009-09-23 Daiki Ueno <ueno@unixuser.org>
+
+ * epg.el (epg-wait-for-status): Preserve existing 'error results.
+
+2009-09-22 Sam Steingold <sds@gnu.org>
+
+ * vc-hg.el (vc-hg-print-log): Fix shortlog arg passing.
+ (vc-hg-outgoing, vc-hg-incoming): Bump okstatus in `vc-hg-command'
+ to 1 because hg returns status 1 when nothing is found.
+ Bind `vc-short-log' for the sake of `vc-hg-log-view-mode'.
+
+2009-09-22 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * textmodes/fill.el: Convert to utf-8 encoding.
+ (fill-french-nobreak-p): Remove redundant » and « inherited from our
+ pre-Unicode days.
+
+ * add-log.el (change-log-fill-forward-paragraph): New function.
+ (change-log-mode): Use it so fill-region DTRT.
+ Set fill-indent-according-to-mode here rather than in
+ change-log-fill-paragraph.
+ (change-log-fill-paragraph): Remove.
+
+2009-09-22 Juanma Barranquero <lekktu@gmail.com>
+
+ * info.el (Info-try-follow-nearest-node): Use the URL extracted by
+ `Info-get-token', instead of `browse-url-url-at-point'. (Bug#4508)
+
+2009-09-22 Glenn Morris <rgm@gnu.org>
+
+ * calendar/calendar.el (calendar-mode-map): Make mouse-1 and 3 clicks on
+ the scroll-bar scroll the calendar window rather than the buffer.
+
+ * calendar/cal-menu.el (cal-menu-scroll-menu): Add a sub-section with
+ commands that move point (as opposed to scrolling).
+
+ * emulation/tpu-edt.el (tpu-copy-keyfile): Fix condition-case handler.
+
+ * emacs-lisp/elint.el (elint): New custom group.
+ (elint-log-buffer): Make it a defcustom.
+ (elint-scan-preloaded, elint-ignored-warnings)
+ (elint-directory-skip-re): New options.
+ (elint-builtin-variables): Doc fix.
+ (elint-preloaded-env): New variable.
+ (elint-unknown-builtin-args): Add an entry for encode-time.
+ (elint-extra-errors): Make it a variable rather than a constant.
+ (elint-preloaded-skip-re): New constant.
+ (elint-directory): Skip files matching elint-directory-skip-re.
+ (elint-features): New variable, local to linted buffers.
+ (elint-update-env): Initialize elint-features. Possibly add
+ elint-preloaded-env to the buffer's environment.
+ (elint-get-top-forms): Bind elint-current-pos, for log messages.
+ Skip quoted forms.
+ (elint-init-form): New function, extracted from elint-init-env.
+ Make non-list forms a warning rather than an error.
+ Add the mode-map for define-derived-mode. Handle define-minor-mode,
+ easy-menu-define, put that adds an error-condition, and provide.
+ When requiring cl, also require cl-macs. Really require cl, to handle
+ some cl macros. Store required libraries in the list elint-features,
+ so as not to re-load them. Treat cc-require like require.
+ (elint-init-env): Call elint-init-form to do the work.
+ Handle eval-and-compile and such like.
+ (elint-add-required-env): Do not clear messages.
+ (elint-special-forms): Add handlers for function, defalias, if, when,
+ unless, and, or.
+ (elint-form): Add optional argument to ignore elint-special-forms,
+ useful to prevent recursive calls from handlers. Doc fix.
+ Respect elint-ignored-warnings.
+ (elint-form): Respect elint-ignored-warnings.
+ (elint-bound-variable, elint-bound-function): New variables.
+ (elint-unbound-variable): Respect elint-bound-variable.
+ (elint-get-args): Respect elint-bound-function.
+ (elint-check-cond-form): Add some simple handling for (f)boundp and
+ featurep tests.
+ (elint-check-defalias-form): New handler.
+ (elint-check-let-form): Make an empty let a warning rather than an
+ error.
+ (elint-check-setq-form): Make an empty setq a warning rather than an
+ error. Respect elint-ignored-warnings.
+ (elint-check-defvar-form): Accept null doc-strings.
+ (elint-check-conditional-form): New handler. Does some simple-minded
+ checking of featurep and (f)boundp tests.
+ (elint-put-function-args): New function.
+ (elint-initialize): Use elint-scan-doc-file rather than
+ elint-find-builtin-variables. Use elint-put-function-args.
+ Possibly scan preloaded-file-list.
+ (elint-scan-doc-file): Rename from elint-find-builtin-variables and
+ extend to handle functions as well.
+
+2009-09-22 Lennart Borgman <lennart.borgman@gmail.com>
+
+ * linum.el (linum-delete-overlays, linum-update-window):
+ Do not modify the right margin. (Bug#3971)
+
+2009-09-21 Chong Yidong <cyd@stupidchicken.com>
+
+ * files.el (conf-mode-maybe, magic-fallback-mode-alist):
+ Use nxml-mode instead of xml-mode.
+
+2009-09-21 Kevin Ryde <user42@zip.com.au>
+
+ * net/dig.el: Add "Keywords: comm", as per net-utils.el. (Bug#4501)
+
+2009-09-21 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * net/dig.el (dig-mode): Use define-derived-mode.
+
+2009-09-20 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-dispatcher.el (vc-do-command): Return the process object in
+ the asynchronous case. Use when instead of if. Do not run
+ vc-exec-after to display a message if not enabled. (Bug#4463)
+
+ * vc-git.el (vc-git-dir-extra-headers): Add keymap and mouse-face
+ properties to the stash strings.
+ (vc-git-stash-list): Return a list of strings.
+ (vc-git-stash-get-at-point, vc-git-stash-delete-at-point)
+ (vc-git-stash-show-at-point): New functions.
+ (vc-git-stash-map): New keymap.
+
+ * register.el (ctl-x-r-map): Define the keys here instead of
+ using autoload.
+
+2009-09-20 Thierry Volpiatto <thierry.volpiatto@gmail.com> (tiny change)
+
+ * bookmark.el (bookmark-write-file): Avoid calling `pp' with large
+ list, to workaround performance problem (bug#4485).
+
+2009-09-20 Nick Roberts <nickrob@snap.net.nz>
+
+ * progmodes/gud.el (gud-sentinel): Revert indavertant change.
+
+2009-09-20 Daiki Ueno <ueno@unixuser.org>
+
+ * epa-file.el (epa-file-cache-passphrase-for-symmetric-encryption):
+ Document that this option is not recommended to use.
+
+2009-09-19 Glenn Morris <rgm@gnu.org>
+
+ * calc/calc-graph.el (calc-graph-lookup): Avoid assignment to free
+ variable `var'.
+
+ * calc/calc-alg.el (var):
+ * calc/calcalg2.el (var): Define for compiler.
+
+2009-09-19 Chong Yidong <cyd@stupidchicken.com>
+
+ * emacs-lisp/advice.el (ad-get-argument, ad-set-argument):
+ Doc fix (Bug#3932).
+
+ * subr.el (baud-rate): Remove long-obsolete function (Bug#4372).
+
+ * time-stamp.el (time-stamp-month-dd-yyyy)
+ (time-stamp-dd/mm/yyyy, time-stamp-mon-dd-yyyy)
+ (time-stamp-dd-mon-yy, time-stamp-yy/mm/dd)
+ (time-stamp-yyyy/mm/dd, time-stamp-yyyy-mm-dd)
+ (time-stamp-yymmdd, time-stamp-hh:mm:ss, time-stamp-hhmm):
+ Remove functions that have been obsolete since 1995 (Bug#4436).
+
+ * progmodes/sh-script.el (sh-learn-buffer-indent): Pop to the
+ indent buffer only if called interactively (Bug#4452).
+
+2009-09-19 Juanma Barranquero <lekktu@gmail.com>
+ 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.
+ (server-ensure-safe-dir): Accept FAT32 directories as "safe",
+ but warn against using them.
+
+2009-09-19 Nick Roberts <nickrob@snap.net.nz>
+
+ * progmodes/gdb-mi.el (gdb-var-update-handler-1): Include case of
+ older GDB where there is no has_more field.
+
+2009-09-19 Glenn Morris <rgm@gnu.org>
+
+ * pgg-pgp.el (pgg-pgp-encrypt-region): Add missing mapconcat separator.
+
+2009-09-18 Chong Yidong <cyd@stupidchicken.com>
+
+ * files.el (auto-mode-alist): Change default for XML files to nXML
+ mode (Bug#4169).
+
+2009-09-18 Juanma Barranquero <lekktu@gmail.com>
+
+ * server.el (server-ensure-safe-dir): Pass 'integer
+ to `file-attributes', as suggested.
+
+2009-09-18 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * dired-aux.el (dired-query-alist): Remove spurious backslash.
+ (dired-query): Use read-key.
+
+2009-09-18 Adrian Robert <Adrian.B.Robert@gmail.com>
+
+ * cus-start.el (ns-use-qd-smoothing): Remove.
+
+2009-09-18 Glenn Morris <rgm@gnu.org>
+
+ * allout.el (top-level): Remove unnecessary progn.
+
+ * progmodes/js.el (js-end-of-defun): Remove malformed and unneeded let.
+
+ * emacs-lisp/derived.el (define-derived-mode): Fix paren typo in
+ definition of abbrev table.
+
+ * speedbar.el (speedbar-track-mouse):
+ * net/eudc-bob.el (eudc-bob-pipe-object-to-external-program):
+ * net/eudc.el (eudc-expand-inline):
+ * net/newst-backend.el (newsticker--cache-read-feed):
+ * nxml/nxml-outln.el (nxml-end-of-heading): Fix typos in
+ condition-case handlers.
+
+2009-09-18 Nick Roberts <nickrob@snap.net.nz>
+
+ * progmodes/gdb-mi.el (gdb-frame-address): New variable.
+ (gdb-var-list): Add an element for has_more field.
+ (gdb-non-stop-handler): Enable pretty printing for STL containers.
+ (gdb-var-create-handler, gdb-var-list-children-handler-1)
+ (gdb-var-update-handler-1): Parse output of dynamic variable
+ objects (STL containers).
+ (gdb-var-delete-1): Pass var1 as an explicit second argument.
+ (gdb-get-field): Delete alias. Use bindat-get-field directly.
+
+ * progmodes/gud.el (gud-speedbar-item-info): Adjust for change to
+ gdb-var-list.
+ (gud-speedbar-buttons): Make node expandable if expression "has more"
+ children.
+
+2009-09-17 Juanma Barranquero <lekktu@gmail.com>
+
+ * startup.el (emacs-quick-startup): Remove variable and all uses.
+ (command-line): Set `inhibit-x-resources' instead.
+ (command-line-1): Use `inhibit-x-resources' instead.
+
+2009-09-17 Chong Yidong <cyd@stupidchicken.com>
+
+ * subr.el: Fix last change to avoid using the `unless' macro,
+ which breaks bootstrapping.
+
+2009-09-17 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * subr.el (push, pop, dolist, dotimes, declare): Don't overwrite CL's
+ extended definitions, in case we reload subr.el after having
+ loaded CL.
+ (eval-next-after-load): Mark as obsolete.
+
+2009-09-17 Juri Linkov <juri@jurta.org>
+
+ * menu-bar.el (menu-bar-search-menu, menu-bar-edit-menu)
+ (menu-bar-options-menu, menu-bar-showhide-fringe-menu)
+ (menu-bar-showhide-menu, menu-bar-tools-menu)
+ (menu-bar-describe-menu, menu-bar-help-menu)
+ (minibuffer-local-completion-map, minibuffer-local-map):
+ Fix list quoting.
+
+2009-09-17 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/bytecomp.el (byte-compile-form): Always check the function
+ arguments, whether or not it has a handler.
+
+ * ansi-color.el (ansi-color-get-face-1): Fix typo in handler.
+
+ * simple.el (hard-newline): Give it a doc-string.
+
+ * emacs-lisp/lisp-mode.el (emacs-lisp-mode-syntax-table):
+ (lisp-mode-syntax-table): Give them doc-strings.
+
+2009-09-17 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * menu-bar.el (menu-bar-file-menu, menu-bar-file-menu)
+ (menu-bar-i-search-menu, menu-bar-edit-menu, menu-bar-custom-menu)
+ (menu-bar-options-menu, menu-bar-showhide-menu)
+ (menu-bar-showhide-fringe-ind-menu, menu-bar-showhide-fringe-menu)
+ (menu-bar-showhide-scroll-bar-menu, menu-bar-showhide-menu)
+ (menu-bar-options-menu, menu-bar-line-wrapping-menu)
+ (menu-bar-options-menu, menu-bar-tools-menu)
+ (menu-bar-describe-menu, menu-bar-search-documentation-menu)
+ (menu-bar-help-menu):
+ (menu-bar-make-mm-toggle, menu-bar-make-toggle): Purecopy the
+ string arguments.
+
+ * ediff-hook.el (menu-bar-ediff-menu, menu-bar-ediff-merge-menu)
+ (menu-bar-epatch-menu, menu-bar-ediff-misc-menu): Add purecopy
+ calls for the menu names and :help.
+
+2009-09-17 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * mouse.el (minor-mode-menu-from-indicator): Pay attention
+ to :minor-mode-function (bug#4455).
+
+2009-09-16 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * startup.el (command-line): Initialize the window-system after
+ processing the command-line.
+
+ * textmodes/page.el (what-page): Make sure we don't inf-loop if
+ page-delimiter matches the empty string.
+
+2009-09-16 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/bytecomp.el (byte-compile-not-obsolete-vars): Rename from
+ byte-compile-not-obsolete-var. It's a list now.
+ (byte-compile-not-obsolete-funcs): New variable.
+ (byte-compile-warn-obsolete): Don't warn about functions if they are in
+ byte-compile-not-obsolete-funcs.
+ (byte-compile-variable-ref, byte-compile-defvar): Update for
+ byte-compile-not-obsolete-vars name-change and list nature.
+ (byte-compile-maybe-guarded): Suppress warnings about obsolete functions
+ and variables behind (f)boundp tests.
+ * net/tramp-compat.el (byte-compile-not-obsolete-vars): Set if bound.
+
+2009-09-15 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-git.el (vc-git-log-view-mode): Undo inadvertent change.
+
+2009-09-15 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * Makefile.in (compile-onefile): Use byte-compile-refresh-preloaded.
+ * emacs-lisp/bytecomp.el (byte-compile-refresh-preloaded):
+ Don't autoload.
+
+2009-09-15 Stephen Eglen <stephen@gnu.org>
+
+ * iswitchb.el (iswitchb-read-buffer): When selecting a match from
+ the virtual-buffers, use the name of the buffer specified by
+ find-file-noselect, as the match may be a symlink. (This was a
+ problem if the target and the symlink had different names.)
+
+2009-09-15 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * custom.el (custom-initialize-default, custom-initialize-set): CSE.
+
+ * desktop.el (desktop-path): Check user-emacs-directory.
+
+ * emacs-lisp/bytecomp.el (byte-compile-refresh-preloaded): New function.
+
+ * loadup.el: Use after-load-functions to GC after loading each file.
+ Remove the explicit GC calls that used to be sprinkled around.
+
+ * subr.el (after-load-functions): New hook.
+ (do-after-load-evaluation): Run it. Use string-match-p to detect
+ `obsolete' packages, rather than painfully extracting the relevant
+ directory name.
+
+2009-09-15 Glenn Morris <rgm@gnu.org>
+
+ * apropos.el (apropos-documentation-check-doc-file): Avoid assignment to
+ free variable `doc'.
+
+ * dired.el (dired-mode-map): Add menu entry for async shell command.
+
+ * help-fns.el (find-lisp-object-file-name): When looking for autoloaded
+ variables, also consider the .elc files, since the .el files are
+ normally gzipped (subsequent code locates the .el.gz from the .elc).
+
+ * calc/calc-prog.el (arglist): Define for compiler.
+
+ * calendar/diary-lib.el (diary-display-function): Change the default to
+ fancy display.
+ (body): Define for compiler.
+
+ * emacs-lisp/bytecomp.el (byte-compile-keep-pending)
+ (byte-compile-file-form, byte-compile-lambda)
+ (byte-compile-top-level-body, byte-compile-form)
+ (byte-compile-variable-ref, byte-compile-setq)
+ (byte-compile-setq-default, byte-compile-body)
+ (byte-compile-body-do-effect, byte-compile-and, byte-compile-or)
+ (batch-byte-compile): Give some more local variables with common names
+ a "bytecomp-" prefix to avoid masking warnings about free variables.
+
+ * startup.el (command-line-1): Give local variables with common names a
+ distinguishing prefix, so as not to hide free variable warnings during
+ bootstrap.
+
+ * mail/rmailmm.el (rmail-mime-save): If file exists, don't try to be
+ clever and add a suffix to make a unique name, just let the user decide
+ whether or not to overwrite it. If the input is a directory, write the
+ default filename to that directory. (Bug#4388)
+ (rmail-mime-bulk-handler): Ensure the save button's 'directory property
+ is a filename-as-a-directory.
+
+2009-09-15 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * textmodes/page.el (what-page): Don't move to beginning of line.
+ See <87tyz5ajte.fsf@x2.delysid.org> in emacs-devel.
+
+2009-09-15 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-git.el (vc-git-dir-extra-headers): Show the remote location.
+
+2009-09-14 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * bindings.el (mode-line-mode-menu): Add purecopy calls for :help.
+ * help.el (help-for-help-internal): Add purecopy calls for text.
+
+ * vc.el (top): print-log method now takes an optional SHORTLOG
+ argument. Add a new method: root.
+ (vc-root-diff, vc-print-root-log): New functions.
+ (vc-log-short-style): New variable.
+ (vc-print-log-internal): Add support for showing short logs.
+
+ * vc-hooks.el (vc-prefix-map, vc-menu-map): Add bindings for
+ vc-print-root-log and vc-print-root-diff.
+
+ * vc-bzr.el (vc-bzr-log-view-mode, vc-bzr-print-log):
+ * vc-git.el (vc-git-print-log, vc-git-log-view-mode):
+ * vc-hg.el (vc-hg-print-log, vc-hg-log-view-mode): Add support for
+ short logs.
+
+ * vc-cvs.el (vc-cvs-print-log):
+ * vc-mtn.el (vc-mtn-print-log):
+ * vc-rcs.el (vc-rcs-print-log):
+ * vc-sccs.el (vc-sccs-print-log):
+ * vc-svn.el (vc-svn-print-log): Add an optional argument shortlog
+ that is ignored for now.
+
+ * vc-mtn.el (vc-mtn-annotate-command):
+ * vc-svn.el (vc-svn-annotate-command): Run asynchronously.
+
+2009-09-14 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * simple.el: Add mapping for backspace/delete/clear/tab/escape/return
+ to function-key-map, and give them ascii-character property.
+ * term/x-win.el (x-alternatives-map):
+ * term/ns-win.el (ns-alternatives-map):
+ * term/internal.el (msdos-key-remapping-map):
+ * w32-fns.el (x-alternatives-map): Remove redundant mappings.
+
+2009-09-14 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/elint.el (elint-add-required-env): Revert to not using
+ temp-buffers (2009-09-12).
+
+2009-09-13 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * textmodes/ispell.el (ispell-command-loop): Improve last fix, using
+ the new read-key function.
+
+2009-09-13 Chong Yidong <cyd@stupidchicken.com>
+
+ * term/x-win.el (x-menu-bar-open): Only call accelerate-menu if it
+ is defined (Bug#4405).
+
+2009-09-13 Vincent Belaïche <vincent.belaiche@gmail.com>
+
+ * recentf.el (recentf-cleanup): Use a hash table to find
+ duplicates (Bug#4407).
+
+2009-09-13 Per Starbäck <per@starback.se> (tiny change)
+
+ * textmodes/ispell.el (ispell-command-loop): Convert keys such as
+ kp-0 to ascii equivalents (Bug#4325).
+
+2009-09-13 Chong Yidong <cyd@stupidchicken.com>
+
+ * progmodes/cperl-mode.el (cperl-init-faces): Revert last change.
+
+ * eshell/em-hist.el:
+ * eshell/em-dirs.el (eshell-complete-user-reference):
+ Declare pcomplete functions and variables to avoid compiler warnings.
+
+2009-09-13 Leo <sdl.web@gmail.com> (tiny change)
+
+ * eshell/em-script.el (eshell-login-script, eshell-rc-script):
+ * eshell/em-dirs.el (eshell-last-dir-ring-file-name):
+ * eshell/em-alias.el (eshell-aliases-file):
+ * eshell/em-hist.el (eshell-history-file-name):
+ Use expand-file-name instead of concat to make file names (Bug#4308).
+
+2009-09-13 Glenn Morris <rgm@gnu.org>
+
+ * ediff-merg.el (ediff-do-merge):
+ * filesets.el (filesets-run-cmd):
+ * emulation/ws-mode.el (ws-show-markers, ws-move-block, ws-delete-block)
+ (ws-find-marker-0, ws-find-marker-1, ws-find-marker-2, ws-find-marker-3)
+ (ws-find-marker-4, ws-find-marker-5, ws-find-marker-6, ws-find-marker-7)
+ (ws-find-marker-8, ws-find-marker-9, ws-goto-block-begin)
+ (ws-goto-block-end, ws-goto-last-cursorposition, ws-copy-block):
+ Replace empty `let's with `progn'.
+
+2009-09-13 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * mail/sendmail.el (send-mail-function):
+ * tooltip.el (tooltip-mode):
+ * simple.el (transient-mark-mode):
+ * rfn-eshadow.el (file-name-shadow-mode):
+ * frame.el (blink-cursor-mode):
+ * font-core.el (global-font-lock-mode):
+ * files.el (temporary-file-directory)
+ (small-temporary-file-directory, auto-save-file-name-transforms):
+ * epa-hook.el (auto-encryption-mode):
+ * composite.el (global-auto-composition-mode):
+ Use custom-initialize-delay.
+ * startup.el (command-line): Don't explicitly call
+ custom-reevaluate-setting for all the above vars.
+ * custom.el (custom-initialize-safe-set)
+ (custom-initialize-safe-default): Delete.
+
+2009-09-12 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * term/x-win.el (x-initialize-window-system):
+ * term/w32-win.el (w32-initialize-window-system):
+ * term/ns-win.el (ns-initialize-window-system): Don't call
+ mouse-wheel-mode since it's enabled globally by default already.
+
+ * mwheel.el (mouse-wheel-mode): Make sure the new defvar doesn't
+ actually define the variable, but only silences the byte-compiler.
+ (mouse-wheel-change-button): Check whether mouse-wheel-mode is bound
+ before looking it up.
+ (mouse-wheel-scroll-amount): Also reset the bindings if this value
+ is changed.
+
+2009-09-12 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/elint.el (elint-file): Make max-lisp-eval-depth at least
+ 1000.
+ (elint-add-required-env): Don't beep on error.
+ (elint-forms): In case of error, return ENV unchanged.
+ (elint-init-env): Skip non-list forms.
+ (elint-log): Handle unknown file positions.
+
+2009-09-12 Daiki Ueno <ueno@unixuser.org>
+
+ * epg.el (epg-make-context): Add autoload cookie.
+ (epg-list-keys, epg-cancel, epg-start-decrypt, epg-decrypt-file)
+ (epg-decrypt-string, epg-start-verify, epg-verify-file)
+ (epg-verify-string, epg-start-sign, epg-sign-file)
+ (epg-sign-string, epg-start-encrypt, epg-encrypt-file)
+ (epg-encrypt-string, epg-start-export-keys)
+ (epg-export-keys-to-file, epg-export-keys-to-string)
+ (epg-start-import-keys, epg-import-keys-from-file)
+ (epg-import-keys-from-string, epg-start-receive-keys)
+ (epg-receive-keys, epg-import-keys-from-server)
+ (epg-start-delete-keys, epg-delete-keys, epg-start-sign-keys)
+ (epg-sign-keys, epg-start-generate-key)
+ (epg-generate-key-from-file, epg-generate-key-from-string):
+ Remove autoload cookie.
+
+2009-09-12 Eli Zaretskii <eliz@gnu.org>
+
+ * dos-fns.el (dos-reevaluate-defcustoms): Comment out the
+ reevaluation of trash-directory.
+
+ * mwheel.el: Fix last change.
+ (mouse-wheel-mode): New defvar.
+ (mouse-wheel-mode): Remove autoload cookie.
+
+2009-09-12 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * mwheel.el (mwheel-installed-bindings): New var.
+ (mouse-wheel-mode): Use it, so as to make sure we really remove all
+ the bindings we set last time. Use custom-initialize-delay.
+ * loadup.el: Load mwheel after term/*-win.el.
+ * startup.el (command-line): Don't reevaluate mouse-wheel-down-event
+ and mouse-wheel-up-event now that their first evaluation is done
+ sufficiently late to be correct.
+
+ * startup.el (tutorial-directory): Make it a defcustom.
+ Use custom-initialize-delay rather than eval-at-startup to set it.
+ * image.el (image-load-path): Make it a defcustom.
+ Use custom-initialize-delay rather than eval-at-startup to set it.
+ * subr.el (eval-at-startup): Remove.
+ * font-lock.el (lisp-font-lock-keywords-2): Remove eval-at-startup.
+
+ * subr.el (do-after-load-evaluation): Warn the user after loading an
+ obsolete package.
+
+2009-09-12 Glenn Morris <rgm@gnu.org>
+
+ * proced.el (proced-mark-alt): Remove alias.
+ (proced-mode-map): Remove proced-mark-alt.
+
+ * emacs-lisp/lisp-mode.el (emacs-lisp-mode-map): Add menu entries to
+ Elint file and directory. Remove initialization entry.
+
+ * emacs-lisp/elint.el (elint-file, elint-directory): New autoloaded
+ commands.
+ (elint-current-buffer): Set mode-line-process.
+ (elint-init-env): Handle define-derived-mode.
+ Fix declare-function with unspecified arglist. Guard against odd
+ defalias statements (eg iso-insert's 8859-1-map).
+ (elint-add-required-env): Use a temp buffer.
+ (elint-form): Just print the function/macro name, not the whole form.
+ Return env unchanged if we fail to parse a macro.
+ (elint-forms): Guard against parse errors.
+ (elint-output): New function, to handle batch mode.
+ (elint-log-message): Add optional argument. Use elint-output.
+ (elint-set-mode-line): New function.
+
+2009-09-12 Andreas Politz <politza@fh-trier.de> (tiny change)
+
+ * emacs-lisp/elp.el (elp-not-profilable): Add more
+ functions (Bug#4233).
+
+2009-09-12 Chong Yidong <cyd@stupidchicken.com>
+
+ * emulation/pc-select.el (scroll-down-mark, scroll-down-nomark)
+ (scroll-up-mark, scroll-up-nomark): Doc fix (Bug#4190).
+
+2009-09-11 Nick Roberts <nickrob@snap.net.nz>
+
+ * progmodes/gdb-mi.el (gdb-var-list-children-regexp): Delete.
+ (gdb-var-list-children): Use json parsing.
+
+2009-09-11 Daniel Colascione <dan.colascione@gmail.com>
+
+ * progmodes/js.el (js--proper-indentation): Handle the case where
+ char-before is null. Reported by Deniz Dogan.
+
+2009-09-11 Juanma Barranquero <lekktu@gmail.com>
+
+ * emacs-lisp/cl-macs.el (help-add-fundoc-usage): Declare.
+
+2009-09-11 Daiki Ueno <ueno@unixuser.org>
+
+ * epg.el (epg-cipher-algorithm-alist): Add CAMELLIA.
+ (epg-digest-algorithm-alist): Add SHA224.
+ (epg-context-set-passphrase-callback)
+ (epg-context-set-progress-callback): Add description about
+ callback function.
+
+2009-09-11 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * custom.el (custom-delayed-init-variables): New var.
+ (custom-initialize-delay): New function.
+ * startup.el (command-line): "Re"evaluate all vars in
+ custom-delayed-init-variables. Don't reevaluate abbrev-file-name
+ explicitly any more.
+ * abbrev.el (abbrev-file-name): Use custom-initialize-delay
+ to avoid creating a ~/.emacs.d at build-time (bug#4347).
+
+ * proced.el (proced-mode-map): Prefer "m" for proced-mark (bug#4362).
+
+2009-09-11 Nick Roberts <nickrob@snap.net.nz>
+
+ * progmodes/gdb-mi.el (gdb-var-update-regexp): Delete.
+ (gdb-var-update-handler): Use json parsing.
+
+2009-09-11 Juanma Barranquero <lekktu@gmail.com>
+
+ * vc-annotate.el (vc-annotate): Use the main file's coding-system to
+ decode annotated text, regardless of language environment. (Bug#2741)
+
+2009-09-11 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * Makefile.in (autoloads): Make rmail.el writable as well.
+
+2009-09-11 Glenn Morris <rgm@gnu.org>
+
+ * dired-aux.el, dired-x.el: Put autoloads in dired.el rather than
+ loaddefs.el.
+ * dired.el: Regenerate with extracted autoloads.
+ * Makefile.in (autoloads): Make dired.el writable.
+
+ * ibuf-ext.el: Put autoloads in ibuffer.el rather than loaddefs.el.
+ * ibuffer.el: Regenerate with extracted autoloads.
+ * Makefile.in (autoloads): Make ibuffer.el writable.
+
+ * paths.el (prune-directory-list, gnus-nntp-service, rmail-file-name):
+ * version.el (emacs-copyright, emacs-major-version)
+ (emacs-minor-version): Reformat doc-strings for make-docfile.
+
+ * apropos.el (apropos-documentation-check-doc-file): Exclude unbound
+ functions and variables, since they must be stuff specific to some other
+ platform.
+ (apropos-print): Make mouse-click message less specific about button.
+
+ * emacs-lisp/cl-macs.el (define-compiler-macro): Add a property
+ that records where a macro was defined.
+ * help-fns.el (describe-function-1): Mention if a function has a
+ compiler-macro.
+ * help-mode.el (help-function-cmacro): New button.
+
+ * locate.el (top-level): Always require dired.
+ (locate-mode-map): Initialize inside the defvar.
+
+ * net/ange-ftp.el (dired-compress-file): Declare.
+ (ange-ftp-dired-compress-file): Add doc string.
+
+ * term/ns-win.el (x-display-name, x-setup-function-keys):
+ Unify doc-strings with X versions.
+
+2009-09-11 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emulation/crisp.el (crisp-mode-map): Move initialization
+ into declaration.
+ (crisp-mode): Use define-minor-mode.
+
+ * progmodes/xscheme.el (xscheme-evaluation-commands):
+ Put a :advertised-binding property rather than using
+ advertised-xscheme-send-previous-expression.
+ (advertised-xscheme-send-previous-expression): Declare obsolete.
+ * emulation/crisp.el (crisp-mode-map): Use `undo' rather than
+ `advertised-undo'.
+ (crisp-mode): Add corresponding bindings to
+ undo's :advertised-binding instead.
+ * dired.el (dired-mode-map): Put a :advertised-binding property rather
+ than using dired-advertised-find-file.
+ (dired-advertised-find-file):
+ * simple.el (advertised-undo):
+ * wid-edit.el (advertised-widget-backward): Declare obsolete.
+ (widget-keymap): Put a :advertised-binding property rather
+ than using advertised-widget-backward.
+ * bindings.el (ctl-x-map): Put a :advertised-binding property rather
+ than using advertised-undo.
+ * tutorial.el (tutorial--default-keys): Adjust accordingly.
+
+2009-09-10 Simon South <ssouth@slowcomputing.org>
+
+ * progmodes/delphi.el (delphi-tab): Indent region when Transient
+ Mark mode is enabled and region is active; otherwise indent or
+ insert TAB as usual.
+ (delphi-mode): Update description of TAB-key binding.
+
+2009-09-10 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * subr.el (define-key-rebound-commands): Mark obsolete.
+ * startup.el (precompute-menubar-bindings): Remove.
+ (normal-top-level): Remove obsolete code that tried to precompute
+ menubar bindings.
+ * loadup.el (define-key-rebound-commands): Don't bother fiddling with
+ define-key-rebound-commands and precompute-menubar-bindings.
+
+2009-09-10 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * net/imap.el (imap-interactive-login): Better messages.
+ (imap-open): Fix bug with renamed buffer on reconnect.
+ (imap-authenticate): Add buffer-local imap-last-authenticator variable
+ for easier debugging and cleaner code. On successful (guessed based on
+ server capabilities) secondary authentication, set imap-state
+ correctly.
+ (imap-last-authenticator): Define imap-last-authenticator as a variable
+ to avoid warnings.
+
+2009-09-10 Glenn Morris <rgm@gnu.org>
+
+ * pcvs.el (cvs-mode-find-file): Use forward-line rather than goto-line.
+
+ * emacs-lisp/bytecomp.el (byte-compile-function-environment): Doc fix.
+ (byte-compile-file-form-autoload): Don't warn about unknown functions
+ where the autoload statement comes after the use.
+ (with-no-warnings): Give it a byte-hunk-handler like than of progn, so
+ that any handlers inside the body (eg require) are in turn respected.
+
+ * emacs-lisp/byte-opt.el (degrees-to-radians): Mark as free from side
+ effects.
+
+ * emacs-lisp/derived.el (define-derived-mode): Give the mode's map,
+ and syntax and abbrev tables basic docs, if they don't have any.
+
+ * emacs-lisp/easy-mmode.el (easy-mmode-defmap): Add doc-string.
+
+ * international/mule-cmds.el (top-level): Require cl when compiling.
+ (view-hello-file): Use default-value rather than
+ default-enable-multibyte-characters.
+
+ * progmodes/fortran.el: Move all safe and risky properties into the
+ defcustoms.
+
+ * mail/rmailedit.el, mail/rmailkwd.el, mail/rmailmm.el:
+ * mail/rmailmsc.el, mail/rmailsort.el, mail/rmailsum.el:
+ * mail/undigest.el:
+ Put autoloads in rmail.el rather than loaddefs.el.
+ * mail/rmail.el: Regenerate with extracted autoloads.
+
+ * mail/rmailsum.el (rmail-user-mail-address-regexp): Move to rmail.el.
+ * mail/rmail.el (rmail-user-mail-address-regexp): Move from rmailsum.el.
+
+2009-09-10 Nick Roberts <nickrob@snap.net.nz>
+
+ Reported in thread for Bug#4375.
+ * progmodes/gud.el (gud-tooltip-print-command): Use MI command
+ "-data-evaluate-expression" instead of print.
+ * progmodes/gdb-mi.el (gdb-tooltip-print-1): Ditto.
+ (gdb-tooltip-print): Parse output from above MI command.
+ (gdb): Revert 2009-08-11 change. User should detach inferior
+ manually.
+
+ Remove the word "separate" from IO functions as inferior
+ output is now never displayed in the GUD buffer.
+
+2009-09-10 Juanma Barranquero <lekktu@gmail.com>
+
+ * startup.el (command-line-normalize-file-name): On Windows and
+ MS-DOS, also convert C:\/ and C:\\ (two backslashes) into C:/.
+
+2009-09-10 Juri Linkov <juri@jurta.org>
+
+ * isearch.el (isearch-text-char-description): Propertize escape
+ character sequences with the `escape-glyph' face. (Bug#4344)
+
+ * simple.el (shell-command): Set asynchronous process filter to
+ `comint-output-filter'. (Bug#4343)
+
+ * progmodes/grep.el (grep-template): Add "<X>" to docstring.
+ (grep-files-aliases): Add "all". Move "el" and "ch" to the top of
+ the list. Move "asm" to the bottom.
+ (grep-find-ignored-directories): Add `choice' with nil value
+ to empty the list easily.
+ (grep-find-ignored-files): New option.
+ (grep-files-history): Set to nil by default instead of '("ch" "el").
+ (grep-compute-defaults): Add "<X>" to `grep-template'.
+ (grep-read-files): Bind new local variables `default-alias' and
+ `default-extension'. Use a list of default values for the file prompt.
+ (lgrep): Add `--exclude=' command line options composed from
+ `grep-find-ignored-files'.
+ (rgrep): Add `-name' command line options composed from
+ `grep-find-ignored-files'. (Bug#4301)
+
+2009-09-09 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * diff-mode.el (diff-hunk-kill): Fix the search of the next hunk
+ (bug#4368).
+
+2009-09-09 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * calendar/time-date.el (autoload):
+ Expand define-obsolete-function-alias into defalias and make-obsolete
+ for old Emacsen that Gnus supports.
+ (with-no-warnings): Define it for old Emacsen.
+ (time-to-seconds): Don't use (featurep 'xemacs) to check if float-time
+ is available.
+ (time-to-number-of-days): Don't use (featurep 'xemacs) to check if
+ float-time is available; suppress compile warning for time-to-seconds.
+
+2009-09-09 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * net/imap.el (imap-message-map): Docstring fix.
+
+2009-09-09 Glenn Morris <rgm@gnu.org>
+
+ * ffap.el (ffap-file-at-point): Handle absolute (non-remote) files with
+ line numbers too. (Bug#4374)
+
+2009-09-08 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * smerge-mode.el (smerge-remove-props, smerge-refine):
+ Use with-silent-modifications (bug#4342).
+
+ * subr.el (with-silent-modifications): New macro.
+
+2009-09-07 Juanma Barranquero <lekktu@gmail.com>
+
+ * files.el (top-level): Require `cl' when compiling.
+
+2009-09-07 Glenn Morris <rgm@gnu.org>
+
+ * files.el (auto-mode-alist): Use delphi-mode for .dpr files.
+
+ * proced.el (proced-mode-map): Bind "d" to proced-mark-alt.
+ (proced-mark-alt): New alias, to control the advertised key. (Bug#4362)
+
+2009-09-06 Nick Roberts <nickrob@snap.net.nz>
+
+ * vc-git.el (vc-git-annotate-command): Use separator to parse
+ arguments correctly.
+
+2009-09-06 Eli Zaretskii <eliz@gnu.org>
+
+ * proced.el (proced-mode): Doc fix.
+
+2009-09-06 Julian Scheid <julians37@gmail.com> (tiny change)
+
+ * net/tramp.el (tramp-perl-file-attributes): Print "nil" when
+ lstat fails.
+ (tramp-do-file-attributes-with-ls): Check for file existence at
+ remote end.
+ (tramp-do-file-attributes-with-stat): Likewise.
+ (tramp-convert-file-attributes): Return nil when attr is nil.
+
+2009-09-05 Glenn Morris <rgm@gnu.org>
+
+ * calendar/diary-lib.el (diary-entry): Add help-echo and follow-link
+ properties to this button.
+ (diary-fancy-display): Don't extend the button to the final newline.
+ (diary-fancy-display-mode): Continue to define "q" as a local key.
+
+ * calendar/cal-china.el (holiday-chinese): Make it slightly more
+ efficient.
+
+ * font-lock.el (lisp-font-lock-keywords-2): Add letf.
+
+ * emacs-lisp/bytecomp.el (emacs-lisp-file-regexp): Doc fix.
+ (byte-compile-dest-file-function): New option.
+ (byte-compile-dest-file): Doc fix.
+ Obey byte-compile-dest-file-function.
+ (byte-compile-cl-file-p): New function.
+ (byte-compile-eval): Only suppress noruntime warnings about cl functions
+ if the cl-functions warning is enabled. Use byte-compile-cl-file-p.
+ (byte-compile-eval): Check for non-nil byte-compile-cl-functions rather
+ than for file being previously loaded.
+ (byte-compile-find-cl-functions): Use byte-compile-cl-file-p.
+ (byte-compile-file-form-require): Handle the case where requiring a file
+ indirectly causes CL to be loaded.
+
+2009-09-05 Karl Fogel <kfogel@red-bean.com>
+
+ * files.el (find-alternate-file): Run `kill-buffer-hook' manually
+ before killing the old buffer, since by the time `kill-buffer' is
+ run so many buffer variables have been set to nil that it may not
+ behave as expected. (Bug#4061)
+
+2009-09-05 Karl Fogel <kfogel@red-bean.com>
+
+ * files.el (find-alternate-file): If the old buffer is modified
+ and visiting a file, behave similarly to `kill-buffer' when
+ killing it, thus reverting to the pre-1.878 behavior; see
+ http://lists.gnu.org/archive/html/emacs-devel/2009-09/msg00101.html
+ for discussion. Also, consult `buffer-file-name' as a variable
+ not as a function, for consistency with the rest of the code.
+
+2009-09-04 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-handle-insert-directory): Handle "--dired"
+ also when adding a new directory.
+
+ * net/tramp-compat.el (tramp-compat-line-beginning-position):
+ New defun.
+
+2009-09-04 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * files.el (locate-file-completion-table): Make it provide boundary
+ information, so partial-completion works better.
+
+2009-09-04 Leo <sdl.web@gmail.com> (tiny change)
+
+ * mail/footnote.el (Footnote-text-under-cursor):
+ Check footnote-text-marker-alist before using it (bug#4324).
+
+2009-09-04 Glenn Morris <rgm@gnu.org>
+
+ * play/5x5.el, play/decipher.el, play/gametree.el, play/handwrite.el:
+ * play/hanoi.el, play/landmark.el, play/mpuz.el, play/pong.el:
+ * play/solitaire.el, play/tetris.el:
+ Remove leading * from defcustom and defface docs.
+
+ * calendar/diary-lib.el (diary-fancy-display): Only switch modes if
+ necessary.
+ (diary-fancy-overriding-map): New variable.
+ (diary-fancy-display-mode): Set minor-mode-overriding-map-alist.
+ Use view-mode.
+
+ * vc-rcs.el (vc-rcs-annotate-command): Use forward-line rather than
+ goto-line.
+
+2009-09-03 Glenn Morris <rgm@gnu.org>
+
+ * arc-mode.el (archive-mode):
+ * dos-fns.el (set-default-process-coding-system):
+ * man.el (Man-getpage-in-background):
+ * menu-bar.el (menu-bar-describe-menu):
+ * server.el (server-process-filter):
+ * startup.el (command-line):
+ * tar-mode.el (tar-header-block-tokenize, tar-extract):
+ * w32-fns.el (set-default-process-coding-system):
+ * x-dnd.el (x-dnd-handle-file-name):
+ * international/mule-cmds.el (mule-menu-keymap)
+ (set-default-coding-systems, language-info-alist, set-language-info)
+ (set-language-environment, standard-display-european-internal)
+ (set-locale-environment):
+ * international/mule-diag.el (mule-diag):
+ * mail/emacsbug.el (report-emacs-bug):
+ * mail/rmail.el (rmail-mode):
+ * mail/sendmail.el (mail-setup):
+ Use default-value rather than default-enable-multibyte-characters.
+
+ * progmodes/f90.el: Move all safe properties into the defcustoms.
+ (f90-get-correct-indent, f90-indent-region, f90-abbrev-start): Use memq.
+
+ * calendar/appt.el (appt-check):
+ * calendar/diary-lib.el (diary-set-header, diary-live-p)
+ (diary-check-diary-file, diary-list-entries)
+ (diary-include-other-diary-files, diary-simple-display)
+ (diary-fancy-display, diary-print-entries)
+ (diary-mark-included-diary-files, diary-make-entry):
+ Don't call substitute-in-file-name on diary-file.
+
+2009-09-03 Eduard Wiebe <usenet@pusto.de>
+ Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * mail/footnote.el (footnote-prefix): Make it a defcustom.
+ (footnote-mode-map): Move initialization into the declaration.
+ (footnote-minor-mode-map): Define it rather than changing global-map.
+ (footnote-mode): Use define-minor-mode.
+
+2009-09-02 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-handle-file-attributes-with-ls)
+ (tramp-do-file-attributes-with-perl)
+ (tramp-do-file-attributes-with-stat): Rename from
+ `tramp-handle-file-attributes-with-*'.
+ (tramp-handle-file-attributes): Use them.
+ (tramp-do-directory-files-and-attributes-with-perl)
+ (tramp-do-directory-files-and-attributes-with-stat): Rename from
+ `tramp-handle-directory-files-and-attributes-with-*'.
+ (tramp-handle-directory-files-and-attributes): Use them.
+ (tramp-method-out-of-band-p): Additional parameter SIZE.
+ (tramp-do-copy-or-rename-file, tramp-handle-file-local-copy)
+ (tramp-handle-write-region): Use it.
+ (tramp-handle-insert-directory): Use "?\ " for compatibility reasons.
+ (tramp-handle-vc-registered): Check, whether the first run did
+ return files to be tested.
+ (tramp-advice-make-auto-save-file-name): Do not call directly
+ `tramp-handle-make-auto-save-file-name', because this would bypass
+ the locking mechanism.
+
+ * net/tramp-compat.el (top): Autoload used functions from tramp.el.
+ (file-remote-p, process-file, start-file-process, set-file-times)
+ (tramp-compat-file-attributes): Compatibility functions shall not
+ call directly `tramp-handle-*', because this would bypass the
+ locking mechanism.
+ (tramp-compat-number-sequence): New defun.
+
+2009-09-02 Glenn Morris <rgm@gnu.org>
+
+ * calendar/time-date.el (time-to-seconds): In Emacs, make it an obsolete
+ alias for float-time.
+ (time-to-number-of-days): In Emacs, use float-time.
+ * net/newst-backend.el (time-add): Suppress warnings from compat
+ function.
+ * time.el (emacs-uptime, emacs-init-time):
+ * net/rcirc.el (rcirc-keepalive, rcirc-handler-ctcp-KEEPALIVE):
+ Use float-time rather than time-to-seconds.
+
+ * minibuffer.el (completion-initials-expand): Fix typo.
+
+ * faces.el (modeline, modeline-inactive, modeline-highlight)
+ (modeline-buffer-id):
+ * info.el (info-menu-5): Mark these face aliases as obsolete.
+
+2009-09-01 Nick Roberts <nickrob@snap.net.nz>
+
+ * progmodes/gdb-mi.el (gdb-current-context-command): Move the
+ space ...
+ (gdb-gud-context-call): ... to here for pre GDB 7.0 when there is
+ no "--thread" option.
+ (gdb-stopped): Don't print "Switched to thread" message when it is
+ unchanged.
+
+2009-09-01 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * minibuffer.el (completion-try-completion)
+ (completion-all-completions): Remove ill-defined (and
+ mistakenly installed and luckily never used nor documented)
+ `completion-styles' property.
+ (completion-initials-expand, completion-initials-all-completions)
+ (completion-initials-try-completion): New functions.
+ (completion-styles-alist): Add doc to each entry.
+ Add new `initials' entry.
+
+2009-09-01 Nick Roberts <nickrob@snap.net.nz>
+
+ * progmodes/gdb-mi.el (gdb-var-create-handler): Remove redundant
+ MI command -var-evaluate-expression.
+ (gdb-var-list-children-regexp): Update from regexp-1 in gdb-ui.el
+ and tweak for case of string child.
+ (gdb-var-list-children-handler): Update from handler-1 in gdb-ui.el.
+
+2009-09-01 Glenn Morris <rgm@gnu.org>
+
+ * add-log.el (change-log-date-face, change-log-name-face)
+ (change-log-email-face, change-log-file-face, change-log-list-face)
+ (change-log-conditionals-face, change-log-function-face)
+ (change-log-acknowledgement-face):
+ * cus-edit.el (custom-invalid-face, custom-rogue-face)
+ (custom-modified-face, custom-set-face, custom-changed-face)
+ (custom-saved-face, custom-button-face, custom-button-pressed-face)
+ (custom-documentation-face, custom-state-face, custom-comment-face)
+ (custom-comment-tag-face, custom-variable-tag-face)
+ (custom-variable-button-face, custom-face-tag-face)
+ (custom-group-tag-face-1, custom-group-tag-face):
+ * diff-mode.el (diff-header-face, diff-file-header-face)
+ (diff-index-face, diff-hunk-header-face, diff-removed-face)
+ (diff-added-face, diff-changed-face, diff-function-face)
+ (diff-context-face, diff-nonexistent-face):
+ * generic-x.el (show-tabs-tab-face, show-tabs-space-face):
+ * hilit-chg.el (highlight-changes-face, highlight-changes-delete-face):
+ * info.el (Info-title-1-face, Info-title-2-face, Info-title-3-face)
+ (Info-title-4-face):
+ * isearch.el (isearch-lazy-highlight-face):
+ * log-view.el (log-view-file-face, log-view-message-face):
+ * paren.el (show-paren-match-face, show-paren-mismatch-face):
+ * pcvs-info.el (cvs-header-face, cvs-filename-face, cvs-unknown-face)
+ (cvs-handled-face, cvs-need-action-face, cvs-marked-face)
+ (cvs-msg-face):
+ * smerge-mode.el (smerge-mine-face, smerge-other-face)
+ (smerge-base-face, smerge-markers-face):
+ * wid-edit.el (widget-documentation-face, widget-button-face)
+ (widget-field-face, widget-single-line-field-face)
+ (widget-inactive-face, widget-button-pressed-face):
+ * woman.el (woman-italic-face, woman-bold-face, woman-unknown-face)
+ (woman-addition-face):
+ * eshell/em-ls.el (eshell-ls-directory-face, eshell-ls-symlink-face)
+ (eshell-ls-executable-face, eshell-ls-readonly-face)
+ (eshell-ls-unreadable-face, eshell-ls-special-face)
+ (eshell-ls-missing-face, eshell-ls-archive-face)
+ (eshell-ls-backup-face, eshell-ls-product-face)
+ (eshell-ls-clutter-face):
+ * eshell/em-prompt.el (eshell-prompt-face):
+ * eshell/esh-test.el (eshell-test-ok-face, eshell-test-failed-face):
+ * obsolete/old-whitespace.el (whitespace-highlight-face):
+ * progmodes/antlr-mode.el (antlr-font-lock-default-face)
+ (antlr-font-lock-keyword-face, antlr-font-lock-syntax-face)
+ (antlr-font-lock-ruledef-face, antlr-font-lock-tokendef-face)
+ (antlr-font-lock-ruleref-face, antlr-font-lock-tokenref-face)
+ (antlr-font-lock-literal-face):
+ * progmodes/ebrowse.el (ebrowse-tree-mark-face)
+ (ebrowse-root-class-face, ebrowse-file-name-face)
+ (ebrowse-default-face, ebrowse-member-attribute-face)
+ (ebrowse-member-class-face, ebrowse-progress-face):
+ * progmodes/make-mode.el (makefile-space-face):
+ * progmodes/sh-script.el (sh-heredoc-face):
+ * textmodes/flyspell.el (flyspell-incorrect-face)
+ (flyspell-duplicate-face):
+ * textmodes/tex-mode.el (tex-math-face, tex-verbatim-face):
+ * textmodes/texinfo.el (texinfo-heading-face):
+ Mark face aliases with "-face" suffix as obsolete.
+
+ * mail/feedmail.el (file-name-buffer-file-type-alist): Define for
+ compiler.
+
+ * net/eudc-bob.el (eudc-bob-generic-menu, eudc-bob-image-menu)
+ (eudc-bob-sound-menu): Use defvar rather than defconst, since
+ easy-menu-define wants to modify these.
+
+ * net/net-utils.el (nslookup): Use make-comint rather than comint-run.
+
+ * net/browse-url.el (browse-url-file-url):
+ * term/internal.el (dos-codepage-setup):
+ Use default-value rather than default-enable-multibyte-characters.
+
+ * progmodes/etags.el (etags-goto-tag-location):
+ * progmodes/flymake.el (flymake-highlight-line)
+ (flymake-goto-file-and-line, flymake-goto-line):
+ * progmodes/gdb-mi.el (gdb-mouse-until, gdb-mouse-jump)
+ (gdb-goto-breakpoint):
+ * progmodes/idlw-shell.el (idlwave-shell-move-to-bp):
+ * progmodes/python.el (python-find-function)
+ (python-pdbtrack-track-stack-file):
+ * progmodes/verilog-mode.el (verilog-surelint-off):
+ * term/ns-win.el (ns-open-file-select-line):
+ * textmodes/bibtex.el (bibtex-validate, bibtex-validate-globally):
+ Use forward-line rather than goto-line.
+
+ * textmodes/reftex-cite.el (reftex-offer-bib-menu):
+ * textmodes/reftex-index.el (reftex-display-index):
+ * textmodes/reftex-ref.el (reftex-offer-label-menu):
+ * textmodes/reftex-toc.el (reftex-toc):
+ Remove unnecessary bindings of default-major-mode (all are followed by
+ major-mode check and possible mode switch).
+
+2009-08-31 Nick Roberts <nickrob@snap.net.nz>
+
+ * progmodes/gdb-mi.el (gdb-breakpoints-list-handler-custom):
+ Handle watchpoints (bug#4282).
+ (def-gdb-thread-buffer-command): Enable thread to be selected by
+ clicking without selecting threads buffer first.
+ (gdb-current-context-command): Use selected frame so that "up",
+ "down" etc work in the GUD buffer.
+ (gdb-update): Find selected frame before rendering stack buffer.
+ (gdb-frame-handler): Set gdb-frame-number for stack buffer.
+
+2009-08-31 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/sym-comp.el (displayed-completions): Remove.
+ (symbol-complete): Use minibuffer-complete.
+
+2009-08-31 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/byte-run.el (define-obsolete-face-alias): New macro.
+
+ * apropos.el (apropos-symbols-internal):
+ Handle (obsolete) face aliases.
+
+ * faces.el (describe-face): Adjust the output format to be more like
+ describe-variable, and to mention (obsolete) face aliases.
+ Adjust the whitespace so that help-setup-xref works.
+
+ * calendar/calendar.el (calendar-today-face, diary-face, holiday-face):
+ * calendar/diary-lib.el (diary-button-face):
+ Mark these face aliases as obsolete.
+
+ * calendar/calendar.el (calendar-today): Doc fix.
+
+2009-08-31 Nick Roberts <nickrob@snap.net.nz>
+
+ * progmodes/gdb-mi.el (gdb-control-all-threads)
+ (gdb-control-current-thread): Force tool bar update.
+ (gdb-non-stop-handler): New function.
+ (gdb-init-1): Use it to test if non-stop mode is supported.
+ Remove unused gdbmi buffer type.
+
+2009-08-30 Kevin Rodgers <kevin.d.rodgers@gmail.com>
+
+ * progmodes/grep.el (grep-read-files): Strip trailing <N> from
+ buffer names not visiting a file (e.g. cloned buffers). (Bug#4210)
+
+2009-08-30 Nick Roberts <nickrob@snap.net.nz>
+
+ * comint.el (comint-exec-1): Check command is non-null first.
+ Part of gdb-mi.el change (2009-08-28).
+
+2009-08-30 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/lisp.el (lisp-complete-symbol): Use minibuffer-complete.
+
+2009-08-30 Juanma Barranquero <lekktu@gmail.com>
+
+ * subr.el (do-after-load-evaluation): Fix last change: use `mapc'
+ instead of `dolist' to avoid a recursive require when bootstrapping.
+
+2009-08-30 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/lisp.el (field-complete): Use minibuffer-complete.
+
+ * net/ldap.el (ldap-search-internal): Use with-current-buffer and push.
+
+ * net/imap.el (imap-send-command): Simplify.
+ (imap-wait-for-tag): point-max -> buffer-size.
+
+ * net/ange-ftp.el (internal-ange-ftp-mode): Use define-derived-mode.
+
+ * emacs-lisp/easy-mmode.el (define-minor-mode): Don't use symbol-value
+ with constant argument.
+
+ * emacs-lisp/debug.el (debugger-setup-buffer): Make it multibyte.
+
+ * emacs-lisp/cl.el (cl-macro-environment): Don't define it here.
+
+ * emacs-lisp/checkdoc.el (checkdoc-force-history-flag):
+ Change default, since most of our files don't have a history.
+ (checkdoc-display-status-buffer): Don't use a hidden buffer to show to
+ the user.
+
+ * emacs-lisp/bytecomp.el (byte-compile-interactive-only-functions):
+ Add comint-run.
+
+ * calc/calc.el: Improve commenting convention.
+ (calc-digit-map, toplevel): Simplify.
+
+ * comint.el (comint-insert-input): Be careful to only set point if we
+ don't delegate to some other command.
+
+ * proced.el (proced-signal-list): Make it an alist.
+ (proced-grammar-alist): Capitalize names.
+ (proced-send-signal): Use a non-hidden buffer (since it's displayed).
+ Disable undo manually and make it read-only.
+ Use completion-annotate-function.
+
+ * minibuffer.el (minibuffer-message): If the current buffer is not
+ a minibuffer, insert the message in the echo area rather than at the
+ end of the buffer.
+ (completion-annotate-function): New variable.
+ (minibuffer-completion-help): Use it.
+ (completion--embedded-envvar-table): Environment vars are
+ always case-sensitive.
+
+2009-08-30 Glenn Morris <rgm@gnu.org>
+
+ * progmodes/fortran.el (fortran-start-prog-re): New constant, extracted
+ from fortran-current-defun.
+ (fortran-beginning-of-subprogram): Be more precise about finding the
+ start, to avoid an infinite loop in end-of-defun. (Bug#4259)
+ (fortran-end-of-subprogram): Simplify.
+ (fortran-current-defun): Use fortran-start-prog-re.
+
+2009-08-29 Juanma Barranquero <lekktu@gmail.com>
+
+ * subr.el (do-after-load-evaluation): Simplify.
+
+2009-08-29 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc.el (vc-print-log-internal): Move RCS/CVS specific code ...
+
+ * vc-rcs.el (vc-rcs-print-log-cleanup): ... here. New function.
+ (vc-rcs-print-log): Use it.
+
+ * vc-cvs.el (vc-cvs-print-log): Use vc-rcs-print-log-cleanup.
+
+2009-08-29 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * paths.el (abbrev-file-name): Move to abbrev.el.
+ * abbrev.el (abbrev-file-name): Move from paths.el.
+ Obey user-emacs-directory.
+ * calc/calc.el (calc-settings-file): Don't autoload and instead obey
+ user-emacs-directory.
+ * dos-fns.el (dos-reevaluate-defcustoms): Don't reevaluate
+ abbrev-file-name and calc-settings-file any more.
+ * startup.el (command-line): Recompute abbrev-file-name and
+ abbreviated-home-dir.
+ (normal-no-mouse-startup-screen): Improve the generic code and get rid
+ of the special code for when C-h bindings haven't been changed.
+ (display-startup-echo-area-message): Use with-current-buffer.
+ (command-line-1): Use a list of strings, rather than a list of lists
+ of strings for longopts.
+
+ * files.el (get-free-disk-space): Use / for default-directory.
+
+ * textmodes/ispell.el (ispell-accept-output, ispell-command-loop):
+ Use with-current-buffer.
+
+ * emacs-lisp/bytecomp.el (byte-compile-const-symbol-p):
+ Recognize immutable variables like most-positive-fixnum.
+ (byte-compile-setq-default): Check and warn if trying to assign
+ to an immutable variable, or a non-variable.
+
+ * progmodes/cc-vars.el (c-comment-continuation-stars):
+ * progmodes/cc-engine.el (c-looking-at-bos):
+ * progmodes/cc-cmds.el (c-toggle-auto-state)
+ (c-forward-into-nomenclature, c-backward-into-nomenclature)
+ (c-comment-line-break-function): Add version of obsolescence.
+
+2009-08-28 Juri Linkov <juri@jurta.org>
+
+ * files.el (magic-fallback-mode-alist): Add ZIP magic number
+ associated with `archive-mode'.
+
+ * image.el (image-type-header-regexps): Use only JPEG magic number
+ to determine JPEG images, and don't use `image-jpeg-p' because
+ Emacs can display non-JFIF non-Exif JPEG images.
+
+2009-08-28 Juanma Barranquero <lekktu@gmail.com>
+
+ * arc-mode.el (archive-mode):
+ * emacs-lisp/re-builder.el (re-builder-unload-function):
+ Protect against the default value of `major-mode' being nil.
+
+2009-08-28 Juanma Barranquero <lekktu@gmail.com>
+
+ * international/ucs-normalize.el (ucs-normalize-sort, quick-check-list):
+ Fix typos in docstrings.
+
+ * progmodes/js.el (js--macro-decl-re): Doc fix.
+ (js--plain-method-re, js--split-name): Refloc docstring.
+ (js--class-styles, js--make-merged-item, js--splice-into-items):
+ Fix typos in docstrings; reflow docstrings.
+ (js--maybe-join, js--function-prologue-beginning, js--flush-caches)
+ (js--variable-decl-matcher, js--inside-pitem-p)
+ (js--parse-state-at-point, js--get-all-known-symbols)
+ (js--symbol-history, js-find-symbol, js--js-references)
+ (js--moz-interactor, js--js-encode-value, js--read-tab):
+ Fix typos in docstrings.
+
+2009-08-28 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * textmodes/reftex.el (reftex-get-file-buffer-force):
+ * progmodes/verilog-mode.el (verilog-batch-execute-func):
+ * emulation/viper.el (viper-go-away, viper-set-hooks):
+ * emacs-lisp/re-builder.el (re-builder-unload-function):
+ * emacs-lisp/bytecomp.el (byte-compile-file):
+ * ses.el (ses-unload-function):
+ * hexl.el (hexl-find-file):
+ * files.el (normal-mode):
+ * ehelp.el (with-electric-help):
+ * autoinsert.el (auto-insert-alist):
+ * arc-mode.el (archive-mode):
+ Use (default-value 'major-mode) instead of default-major-mode.
+
+ * textmodes/ispell.el (ispell-check-version, ispell-send-string):
+ * international/mule.el (load-with-code-conversion):
+ * emacs-lisp/debug.el (debug):
+ * ediff-vers.el (ediff-rcs-get-output-buffer):
+ * dired.el (dired-internal-noselect): Don't let-bind
+ default-major-mode around code that doesn't use it.
+ E.g. buffer creation via get-buffer-create doesn't use it.
+
+2009-08-28 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (all): Replace "'(lambda" by "(lambda".
+ (tramp-handle-file-local-copy): Unset `file-name-handler-alist'
+ when writing the temp file. Otherwise, epa-file gets confused.
+ (tramp-register-file-name-handlers): Make it a defun. Move also
+ `epa-file-handler' to the front of `file-name-handler-alist'.
+
+2009-08-28 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * net/tramp.el (tramp-shell-prompt-pattern): Allow a prompt to
+ start right after a ^M.
+ (tramp-root-regexp, tramp-completion-file-name-regexp-unified)
+ (tramp-completion-file-name-regexp-separate)
+ (tramp-completion-file-name-regexp-url): Use \\` and \\'.
+ (tramp-handle-file-attributes, tramp-set-file-uid-gid):
+ Don't modify last-coding-system-used by accident.
+ (tramp-completion-file-name-handler): Apply the checks here,
+ instead during registration.
+ (tramp-register-file-name-handlers): Rename from
+ `tramp-register-file-name-handler'. Register both
+ `tramp-file-name-handler' and `tramp-completion-file-name-handler'.
+ (tramp-register-completion-file-name-handler): Remove. (Bug#4260)
+
+2009-08-28 Nick Roberts <nickrob@snap.net.nz>
+
+ * progmodes/gdb-mi.el (gdb-use-separate-io-buffer):
+ Remove variable ...
+ (gdb-init-1, gdb-display-separate-io-buffer)
+ (gdb-frame-separate-io-buffer, gdb-setup-windows): ... and
+ references to it.
+ (gdb-inferior-io-mode): Use make-comint-in-buffer.
+ (gdb-inferior-filter): Use comint-output-filter to stop
+ echoing and remove ^M characters.
+
+2009-08-28 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emulation/viper-init.el (viper-restore-cursor-type):
+ * emulation/cua-base.el (cua--update-indications):
+ Replace default-cursor-type with (default-value 'cursor-type).
+
+ * mail/sendmail.el (mail-recover-1):
+ * international/mule-diag.el (describe-current-coding-system-briefly)
+ (describe-current-coding-system):
+ * international/mule-cmds.el (select-safe-coding-system)
+ (select-message-coding-system)
+ (set-language-environment-coding-systems, set-locale-environment):
+ * hexl.el (hexl-insert-multibyte-char):
+ * dos-w32.el (find-buffer-file-type-coding-system):
+ * simple.el (what-cursor-position):
+ Replace uses of default-buffer-file-coding-system
+ with (default-value 'buffer-file-coding-system).
+
+ * emacs-lisp/edebug.el (edebug-display, edebug-outside-excursion):
+ Replace uses of default-cursor-in-non-selected-windows
+ with (default-value 'cursor-in-non-selected-windows).
+ Use with-current-buffer.
+
+ * mail/feedmail.el: Use CL macros.
+ (feedmail-run-the-queue, feedmail-send-it-immediately):
+ * dos-w32.el (find-buffer-file-type): Replace uses of
+ default-buffer-file-type with (default-value 'buffer-file-type).
+
+2009-08-28 Glenn Morris <rgm@gnu.org>
+
+ * calendar/diary-lib.el (diary-list-entries, diary-goto-entry)
+ (diary-show-all-entries, diary-mark-entries, diary-make-entry):
+ Use default-value of major-mode rather than default-major-mode.
+
+2009-08-27 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * Makefile.in (update-elcfiles): Report left over elc files.
+
+ * mail/mailalias.el (build-mail-aliases): Use with-temp-buffer,
+ expand-file-name and with-current-buffer.
+ (mail-get-names, mail-directory): Use with-current-buffer.
+
+ * vc.el (vc-read-revision): New function.
+ (vc-version-diff, vc-merge): Use it.
+
+2009-08-27 Sam Steingold <sds@gnu.org>
+
+ * simple.el (kill-do-not-save-duplicates): New user option.
+ (kill-new): When it is non-nil, and the new string is the same as
+ the latest kill, set replace to t to avoid duplicates in kill-ring.
+
+2009-08-27 Julian Scheid <julians37@gmail.com> (tiny change)
+
+ * net/tramp.el (tramp-handle-process-file): Do not flush all
+ caches when `process-file-side-effects' is set.
+ (tramp-handle-vc-registered): Use `tramp-get-file-exists-command'
+ instead of `tramp-find-file-exists-command'.
+ Unset `process-file-side-effects'.
+
+2009-08-27 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-methods): New method "rsyncc".
+ (top): Add completion function for "rsyncc".
+ (tramp-message-show-message): New defvar.
+ (tramp-message, tramp-error): Use it.
+ (tramp-do-copy-or-rename-file-directly): Extend check for direct
+ remote copying.
+ (tramp-do-copy-or-rename-file-out-of-band): Handle new
+ `tramp-methods' entry `copy-env' of "rsyncc".
+ (tramp-vc-registered-read-file-names): New defconst.
+ (tramp-vc-registered-file-names): New defvar.
+ (tramp-handle-vc-registered): Implement optimization strategy.
+ (tramp-run-real-handler): Add `tramp-vc-file-name-handler'.
+ (tramp-vc-file-name-handler): New defun.
+ (tramp-get-ls-command, tramp-get-test-command)
+ (tramp-get-file-exists-command, tramp-get-remote-ln)
+ (tramp-get-remote-perl, tramp-get-remote-stat)
+ (tramp-get-remote-id): Remove superfluous `with-current-buffer'.
+
+ * net/tramp-cache.el (top): Autoload `tramp-time-less-p'.
+ (tramp-cache-inhibit-cache): Extend doc string. It allows also
+ timestamps.
+ (tramp-get-file-property): Check for timestamps in
+ `tramp-cache-inhibit-cache'.
+ (tramp-set-file-property): Write timestamp.
+
+2009-08-27 ARISAWA Akihiro <ari@mbf.ocn.ne.jp> (tiny change)
+
+ * language/japan-util.el (japanese-symbol-table): Add entries for
+ cp932-2-byte.
+
+ * international/characters.el: Add category `j' to cp932-2-byte.
+
+2009-08-27 Kenichi Handa <handa@m17n.org>
+
+ * international/fontset.el (build-default-fontset-data): New macro.
+ (setup-default-fontset): Use build-default-fontset-data for CJK,
+ tibetan, ethiopic, and ipa.
+
+2009-08-27 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * cus-start.el (default-major-mode): Customize `major-mode' instead.
+ (enable-multibyte-characters): Not customizable any more.
+
+ * subr.el (default-mode-line-format, default-header-line-format)
+ (default-line-spacing, default-abbrev-mode, default-ctl-arrow)
+ (default-direction-reversed, default-truncate-lines)
+ (default-left-margin, default-tab-width, default-case-fold-search)
+ (default-left-margin-width, default-right-margin-width)
+ (default-left-fringe-width, default-right-fringe-width)
+ (default-fringes-outside-margins, default-scroll-bar-width)
+ (default-vertical-scroll-bar, default-indicate-empty-lines)
+ (default-indicate-buffer-boundaries, default-fringe-indicator-alist)
+ (default-fringe-cursor-alist, default-scroll-up-aggressively)
+ (default-scroll-down-aggressively, default-fill-column)
+ (default-cursor-type, default-buffer-file-type)
+ (default-cursor-in-non-selected-windows)
+ (default-buffer-file-coding-system, default-major-mode)
+ (default-enable-multibyte-characters): Mark as obsolete.
+
+2009-08-27 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-dir.el (vc-dir-update): Remove debug helper.
+
+ * vc-cvs.el (vc-cvs-update-changelog): Fix typo.
+
+2009-08-26 Sam Steingold <sds@gnu.org>
+
+ * simple.el (save-interprogram-paste-before-kill): New user option.
+ (kill-new): When `save-interprogram-paste-before-kill' is non-nil,
+ save the interprogram-paste into kill-ring before overriding it
+ with the Emacs kill.
+
+2009-08-26 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc.el (vc-trunk-p): Rename to vc-rcs-trunk-p and move to vc-rcs.el.
+ (vc-minor-part): Rename to vc-rcs-minor-part and move to vc-rcs.el.
+ (vc-default-previous-revision): Rename to vc-rcs-previous-revision
+ and move to vc-rcs.el.
+ (vc-default-next-revision): Rename to vc-rcs-next-revision and
+ move to vc-rcs.el.
+ (vc-cvs-update-changelog): Move to vc-cvs.el, use vc-call-backend.
+ (vc-rcs-update-changelog): Remove.
+ (vc-update-changelog-rcs2log): Rename to vc-rcs-update-changelog
+ and move to vc-rcs.el.
+
+ * vc-rcs.el (vc-rcs-latest-on-branch-p, vc-rcs-checkin)
+ (vc-rcs-checkout, vc-rcs-rollback): Adjust for the vc-rcs-trunk-p
+ renaming.
+ (vc-rcs-trunk-p, vc-rcs-minor-part, vc-rcs-previous-revision)
+ (vc-rcs-next-revision, vc-rcs-update-changelog): Move here from
+ vc.el, renamed to be RCS specific.
+
+ * vc-cvs.el (vc-cvs-previous-revision, vc-cvs-next-revision):
+ New functions.
+ (vc-cvs-update-changelog): Move here from vc.el.
+
+ * vc-sccs.el (vc-sccs-previous-revision, vc-sccs-next-revision):
+ New functions.
+
+2009-08-26 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/bytecomp.el (byte-compile-lapcode): Fix up last change.
+
+2009-08-26 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-git.el (vc-git-register): Use "git add" for directories.
+ (vc-git-stash, vc-git-stash-show): New functions.
+ (vc-git-extra-menu-map): Bind them.
+
+ * vc-dir.el (vc-dir-node-directory, vc-dir-update): Get the parent
+ directory correctly in case the item is a directory itself.
+
+ * vc.el: Document the desired behavior for reverted files in the
+ `added' state.
+ (vc-default-prettify-state-info): Remove function, unused.
+
+ * vc-bzr.el (vc-bzr-prettify-state-info): Remove function, unused.
+
+2009-08-26 Glenn Morris <rgm@gnu.org>
+
+ * bindings.el (standard-mode-line-format): Reposition dashes in
+ which-func entry. (Bug#4217)
+
+ * files.el (enable-local-variables, enable-local-eval)
+ (safe-local-variable-values, safe-local-eval-forms): Mark as risky in
+ the defcustoms.
+ (auto-mode-alist, ignored-local-variables)
+ (save-some-buffers-action-alist): Move risky declarations to the
+ definitions.
+ (dabbrev-case-fold-search, dabbrev-case-replace, display-time-string)
+ (font-lock-defaults, format-alist, imenu--index-alist)
+ (imenu-generic-expression, input-method-alist, minor-mode-alist)
+ (mode-line-buffer-identification, mode-line-client, mode-line-modes)
+ (mode-line-modified, mode-line-mule-info, mode-line-position)
+ (mode-line-process, mode-line-remote, outline-level)
+ (parse-time-rules, rmail-output-file-alist)
+ (special-display-buffer-names, vc-mode):
+ Move risky declarations to the relevant files.
+ * bindings.el (mode-line-client, mode-line-mule-info, mode-line-remote)
+ (mode-line-modified, mode-line-process, mode-line-position)
+ (mode-line-modes, mode-line-buffer-identification, minor-mode-alist)
+ * font-core.el (font-lock-defaults):
+ * format.el (format-alist):
+ * vc-hooks.el (vc-mode):
+ * window.el (special-display-buffer-names):
+ * international/mule-cmds.el (input-method-alist):
+ Define riskiness here (dumped file) rather than in files.el.
+ * dabbrev.el (dabbrev-case-fold-search, dabbrev-case-replace):
+ * imenu.el (imenu-generic-expression, imenu--index-alist):
+ * outline.el (outline-level):
+ * time.el (display-time-string):
+ * calendar/parse-time.el (parse-time-rules):
+ * mail/rmailout.el (rmail-output-file-alist):
+ Autoload riskiness here, rather than placing in files.el.
+
+2009-08-26 Andreas Schwab <schwab@linux-m68k.org>
+
+ * emacs-lisp/bytecomp.el (byte-compile-lapcode): Signal overflow.
+
+2009-08-25 Michael Albinus <michael.albinus@gmx.de>
+
+ * simple.el (process-file-side-effects): New defvar.
+
+ * dired-aux.el (dired-show-file-type):
+ * vc.el (vc-diff-internal):
+ * vc-arch.el (vc-arch-diff):
+ * vc-bzr.el (vc-bzr-sha1, vc-bzr-revision-completion-table):
+ * vc-cvs.el (vc-cvs-state, vc-cvs-diff, vc-cvs-revision-table):
+ * vc-git.el (vc-git-registered, vc-git-working-revision)
+ (vc-git-find-revision, vc-git-diff, vc-git-revision-table)
+ (vc-git--empty-db-p):
+ * vc-hooks.el (vc-user-login-name):
+ * vc-svn.el (vc-svn-registered, vc-svn-state)
+ (vc-svn-dir-extra-headers, vc-svn-find-revision):
+ * progmodes/grep.el (grep-probe): Let-bind
+ `process-file-side-effects' with nil.
+
+ * net/dbus.el (dbus-ping): Add optional parameter TIMEOUT.
+
+ * net/tramp-gvfs.el (top): Use timeout of 100 msec pinging GVFS
+ daemon. Replace ping by checking for running service for bluez
+ and zeroconf. (Bug#4239)
+
+2009-08-25 Kevin Ryde <user42@zip.com.au>
+
+ * net/dig.el (dig): Add autoload cookie.
+
+2009-08-25 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/bytecomp.el (byte-compile-eval): Fix test for cl in
+ load-history for absolute file-names.
+ (byte-compile-file-form-require): Warn about use of the cl package.
+
+ * format.el (format-alist): Doc fix.
+
+ * play/bubbles.el (top-level): Don't require cl at run-time.
+
+ * progmodes/verilog-mode.el (top-level): Don't require lucid (and hence
+ run-time cl).
+
+2009-08-24 Dmitry Dzhus <dima@sphinx.net.ru>
+
+ * progmodes/gdb-mi.el (gdb-mapcar*): Replacement for `mapcar*'
+ from cl package.
+ (gdb-table-add-row, gdb-table-string): Use `gdb-mapcar*'.
+
+2009-08-24 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc-alg.el (math-trig-rewrite)
+ (math-hyperbolic-trig-rewrite): New functions.
+ (calc-simplify): Simplify trig functions when asked.
+
+2009-08-24 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * diff-mode.el (diff-find-source-location): Avoid goto-line.
+
+2009-08-24 Kenichi Handa <handa@m17n.org>
+
+ * language/ind-util.el (mapthread): Delete it.
+ (combinatorial): New function.
+ (indian--puthash-cv): Use combinatorial instead of mapthread.
+
+2009-08-22 Kevin Ryde <user42@zip.com.au>
+
+ * emacs-lisp/checkdoc.el (checkdoc-force-history-flag)
+ (checkdoc-arguments-in-order-flag): Add safe-local-variable booleanp.
+ (checkdoc-symbol-words): Add safe-local-variable for list of strings.
+ Clarify docstring that the value is strings not symbols.
+ (checkdoc-list-of-strings-p): New function.
+
+2009-08-22 Glenn Morris <rgm@gnu.org>
+
+ * files.el (auto-mode-alist):
+ * hippie-exp.el (he-concat-directory-file-name):
+ * lpr.el (lpr-windows-system, printer-name):
+ * ls-lisp.el (ls-lisp-emulation, ls-lisp-use-insert-directory-program):
+ * ps-print.el (ps-windows-system):
+ * startup.el (command-line):
+ * emulation/viper-ex.el (viper-glob-function):
+ * international/mule-cmds.el (set-language-environment-coding-systems):
+ * net/ange-ftp.el (ange-ftp-write-region):
+ * obsolete/fast-lock.el (fast-lock-cache-name):
+ Remove code for defunct system-types emx, macos, mswindows, next-mach,
+ unisoft-unix, vax-vms, win32, w32.
+
+ * calendar/diary-lib.el (diary-mark-entries-1): Only mark all days of a
+ given name if the pattern is not more specific.
+
+ * calendar/lunar.el (lunar-phase-names): New option.
+ (lunar-phase): Doc fix.
+ (lunar-cycles-per-year): New constant.
+ (lunar-index): New function.
+ (lunar-phase-list, diary-lunar-phases): Use lunar-index.
+ (lunar-phase-name): Use lunar-phase-names.
+ (calendar-lunar-phases): Use format.
+ (lunar-new-moon-on-or-after): Use lunar-cycles-per-year.
+
+ * progmodes/cperl-mode.el (cperl-imenu-name-and-position):
+ Copy imenu-example--name-and-position function here for own use.
+ (cperl-xsub-scan): Use cperl-imenu-name-and-position.
+
+ * bs.el (bs--redisplay):
+ * cus-edit.el (custom-redraw):
+ * ibuffer.el (ibuffer-bury-buffer):
+ * server.el (server-goto-line-column):
+ * startup.el (command-line-1):
+ * strokes.el (strokes-xpm-for-stroke):
+ * term.el (term-display-buffer-line):
+ * view.el (View-goto-line):
+ * calc/calc.el (calc-do, calc-trail-buffer):
+ * play/gamegrid.el (gamegrid-add-score-insecure):
+ * progmodes/ada-mode.el (ada-compile-goto-error):
+ * progmodes/ada-xref.el (ada-xref-find-in-modified-ali):
+ (ebrowse-select-1st-to-9nth):
+ * progmodes/cperl-mode.el (cperl-time-fontification):
+ * progmodes/ebrowse.el (ebrowse-toggle-file-name-display)
+ * progmodes/gud.el (gud-display-line):
+ (idlwave-shell-display-line):
+ * progmodes/idlw-shell.el (idlwave-shell-goto-frame)
+ * progmodes/make-mode.el (makefile-browser-toggle):
+ (vhdl-speedbar-port-copy, vhdl-compose-components-package):
+ * progmodes/vhdl-mode.el (vhdl-speedbar-find-file)
+ * textmodes/picture.el (picture-draw-rectangle):
+ * textmodes/reftex-index.el (reftex-index-goto-letter):
+ (reftex-select-jump-to-previous):
+ * textmodes/reftex-sel.el (reftex-find-start-point)
+ * textmodes/reftex-toc.el (reftex-toc, reftex-toc-restore-region):
+ (rst-straighten-deco-spacing, rst-section-tree, rst-toc):
+ * textmodes/rst.el (rst-promote-region, rst-straighten-decorations)
+ * textmodes/tex-mode.el (tex-compilation-parse-errors):
+ * textmodes/two-column.el (2C-associated-buffer):
+ Use forward-line rather than goto-line.
+
+ * emulation/vi.el (vi-goto-line): Don't warn about non-interactive
+ goto-line.
+
+ * international/ucs-normalize.el (nfd, decomposition-translation-alist)
+ (decomposition-char-recursively, alist-list-to-vector, quick-check-list)
+ (quick-check-list-to-regexp): Declare.
+
+ * progmodes/make-mode.el (makefile-browser-insert-selection):
+ Use goto-char rather than goto-line.
+
+ * progmodes/prolog.el (compilation-error-regexp-alist)
+ (compilation-forget-errors): Declare.
+
+2009-08-22 Juri Linkov <juri@jurta.org>
+
+ * progmodes/grep.el (lgrep, rgrep): At the beginning
+ set `dir' to `default-directory' unless `dir' is a non-nil
+ readable directory. (Bug#4052)
+ (lgrep, rgrep): Change a weird way to report an error
+ from using `read-string' to using `error'.
+ Instead of using interactive arguments in the function body,
+ add new argument `confirm'.
+
+2009-08-21 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * textmodes/remember.el (remember-buffer):
+ * progmodes/cperl-mode.el (cperl-vc-header-alist):
+ * calendar/icalendar.el (icalendar-convert-diary-to-ical)
+ (icalendar-extract-ical-from-buffer):
+ * net/newst-treeview.el (newsticker-groups-filename):
+ * net/newst-backend.el (newsticker-cache-filename):
+ * speedbar.el (speedbar-update-speed, speedbar-navigating-speed)
+ (speedbar-ignored-path-expressions, speedbar-ignored-path-regexp)
+ (speedbar-add-ignored-path-regexp, speedbar-line-path)
+ (speedbar-buffers-line-path, speedbar-path-line)
+ (speedbar-buffers-line-path):
+ * epg.el (epg-passphrase-callback-function, epg-start-sign-keys)
+ (epg-sign-keys):
+ * epa.el (epa-display-verify-result):
+ * progmodes/pascal.el (pascal-outline): Add version of obsolescence.
+
+2009-08-21 Glenn Morris <rgm@gnu.org>
+
+ * progmodes/js.el (inferior-moz-process): Fix declaration.
+
+ * imenu.el (imenu-example--name-and-position): Fix obsolescence message.
+
+ * obsolete/rnewspost.el (news-mail-reply):
+ Use goto-char rather than goto-line.
+
+ * term/ns-win.el (ns-open-file-select-line):
+ Use line-beginning-position rather than goto-line.
+
+ * apropos.el (apropos-command):
+ * ehelp.el (electric-helpify):
+ * printing.el (pr-show-setup):
+ * strokes.el (strokes-help):
+ * tutorial.el (tutorial--describe-nonstandard-key)
+ (tutorial--detailed-help):
+ * woman.el (woman-mini-help, woman-display-extended-fonts):
+ * calc/calc-help.el (calc-describe-key):
+ * emulation/edt.el (edt-electric-helpify):
+ * international/mule-diag.el (mule-diag):
+ * play/yow.el (apropos-zippy):
+ * progmodes/python.el (python-describe-symbol):
+ * progmodes/vhdl-mode.el (vhdl-doc-variable, vhdl-doc-mode):
+ * textmodes/table.el (*table--cell-describe-mode)
+ (*table--cell-describe-bindings):
+ Use help-print-return-message rather than the now obsolete alias.
+
+ * calendar/cal-move.el (calendar-cursor-to-nearest-date)
+ (calendar-cursor-to-visible-date):
+ * play/5x5.el (5x5-position-cursor):
+ * play/decipher.el (decipher):
+ * play/gomoku.el (gomoku-goto-xy):
+ * play/landmark.el (lm-goto-xy):
+ * play/mpuz.el (mpuz-paint-errors, mpuz-paint-statistics)
+ (mpuz-paint-digit):
+ Use forward-line, not goto-line.
+
+ * mail/rmail.el (rmail-obsolete): Delete custom group.
+ (rmail-pop-password, rmail-pop-password-required): Make into aliases.
+ (rmail-remote-password, rmail-remote-password-required):
+ Remove unneeded :set-after and :set properties.
+
+2009-08-21 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/dbus.el (top): Initialize only when `dbusbind' is loaded.
+
+2009-08-21 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * loadup.el: Remove leftover macos code.
+
+ * vc-git.el (vc-git-annotate-command): Run asynchronously.
+ Explicitly pass the date format to git blame so that user local
+ so that the output format can be parsed.
+
+2009-08-20 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/dbus.el (top): Don't check for (getenv
+ "DBUS_SESSION_BUS_ADDRESS"). It's done in dbusbind.c now.
+
+2009-08-19 Magnus Henoch <magnus.henoch@gmail.com>
+
+ * log-edit.el (log-edit-strip-single-file-name): New var.
+ (log-edit-insert-changelog): Use it. Bug#3571.
+
+2009-08-19 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * subr.el (read-passwd): Use read-key so keypad keys work as well.
+ Bug#3287.
+
+ * help.el (help-print-return-message): Rename from
+ print-help-return-message.
+
+ * log-view.el (log-view-mode-map): Remove `q' binding, and unreliable
+ cvs-mode-map parent hack.
+ (log-view-mode): Derive from special-mode.
+
+ * linum.el (linum-mode): window-size-change-functions is redundant.
+ Adapt to new window-configuration-change-hook behavior.
+ (linum-after-size, linum-after-config): Remove.
+
+ * imenu.el (imenu-example--name-and-position)
+ (imenu-example--lisp-extract-index-name)
+ (imenu-example--create-lisp-index, imenu-example--create-c-index):
+ Mark as obsolete.
+
+ * progmodes/prolog.el (inferior-prolog-error-regexp-alist): New var.
+ (inferior-prolog-mode): Use it.
+ (inferior-prolog-load-file): Reset list of errors.
+
+2009-08-19 ARISAWA Akihiro <ari@mbf.ocn.ne.jp> (tiny change)
+
+ * language/tibetan.el ("Tibetan"): Fix sample-text entry.
+
+ * language/tai-viet.el ("TaiViet"): Fix sample-text entry.
+
+2009-08-19 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/dbus.el (top): Apply `dbus-init-bus' only if the session bus
+ is running already.
+
+2009-08-19 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * subr.el (listify-key-sequence-1): Use normal syntax since those
+ integers are nowadays always represented by the same (positive) number
+ on all platforms.
+ (read-key-empty-map): New const.
+ (read-key-delay): New var.
+ (read-key): New function.
+ (force-mode-line-update): Use with-current-buffer.
+ (locate-user-emacs-file): Don't forget to abbreviate the file name.
+ (start-process-shell-command, start-file-process-shell-command):
+ Discourage the use of command-args.
+
+2009-08-19 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/authors.el (authors-fixed-entries): Remove cvtmail.
+
+2009-08-19 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * simple.el (choose-completion-string): Don't rely on
+ minibuffer-completing-file-name and ad-hoc checks to decide whether
+ to continue completion or not.
+
+ * minibuffer.el (minibuffer-hide-completions): New function.
+ (completion--do-completion): Use it.
+ (completions-annotations): New face.
+ (completion--insert-strings): Use it.
+ (completion-pcm--delim-wild-regex): Add docstring.
+ (completion-pcm--string->pattern): Add support for 0-width delimiters
+ in completion-pcm--delim-wild-regex.
+
+2009-08-18 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * international/ucs-normalize.el (ucs-normalize-hfs-nfd-post-read-conversion):
+ Remove unused var `buffer-modified-p'.
+
+ * minibuffer.el (completion--do-completion): Move point for the #b001
+ case as well (bug#4176).
+ (minibuffer-complete, minibuffer-complete-word): Don't move point.
+
+2009-08-18 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/dbus.el (dbus-init-bus): Declare. Apply it for the :system
+ and :session buses.
+
+2009-08-18 Kenichi Handa <handa@m17n.org>
+
+ * international/ucs-normalize.el (ucs-normalize-version):
+ Change to 1.1.
+ (ucs-normalize-hfs-nfd-pre-write-conversion): New function.
+ (utf-8-hfs): Make it perform normalization on encoding too.
+
+ * textmodes/paragraphs.el: Change to utf-8. Adjust coding cookie.
+ (sentence-end-without-space): Delete duplicated chars.
+ (sentence-end-base): Likewise.
+
+ * textmodes/sgml-mode.el: Change to utf-8. Adjust coding cookie.
+ (html-mode): Delete duplicated chars from sentence-end-base.
+
+ * textmodes/texinfo.el: Change to utf-8. Adjust coding cookie.
+ (texinfo-mode): Delete duplicated chars from sentence-end-base.
+
+2009-08-17 Chong Yidong <cyd@stupidchicken.com>
+
+ * files.el (hack-one-local-variable): If the mode function is for
+ a minor mode, pass it an argument (Bug#4148).
+
+2009-08-17 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-register-completion-file-name-handler):
+ Check also for (member 'partial-completion completion-styles).
+
+2009-08-16 Chong Yidong <cyd@stupidchicken.com>
+
+ * progmodes/cperl-mode.el (cperl-electric-paren): Don't expand
+ abbrev (Bug#3943).
+
+2009-08-16 Ilya Zakharevich <ilyaz@cpan.org>
+
+ * progmodes/cperl-mode.el: Merge upstream 6.2.
+ (cperl-mode-syntax-table): Modify syntax entry for ["'`].
+ (cperl-forward-re): Check cperl-brace-recursing.
+ (cperl-highlight-charclass): New function.
+ (cperl-find-pods-heres): Use it.
+ (cperl-fill-paragraph): Synch to save-excursion placement used upstream.
+ (cperl-beautify-regexp-piece): Fix column calculation.
+ (cperl-make-regexp-x): Handle case where point is between "q" and "rs".
+ (cperl-beautify-level): Don't process entire regexp.
+ (cperl-build-manpage, cperl-perldoc): Bind Man-switches before
+ calling man.
+ (cperl-tips-faces, cperl-mode, cperl-electric-backspace): Doc fix.
+ (cperl-init-faces): Build a list in the normal way.
+
+2009-08-16 Chong Yidong <cyd@stupidchicken.com>
+
+ * calendar/parse-time.el (parse-time-string-chars): Save match
+ data.
+
+2009-08-16 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/sql.el (sql-product-alist): Add :name tag to entries.
+ (sql-product): Use it.
+ (sql-mode-menu): Auto-generate the menu based on sql-product-alist.
+ (sql-set-product): Add completion.
+ (sql-highlight-oracle-keywords, sql-highlight-postgres-keywords)
+ (sql-highlight-linter-keywords, sql-highlight-ms-keywords)
+ (sql-highlight-ansi-keywords, sql-highlight-sybase-keywords)
+ (sql-highlight-informix-keywords, sql-highlight-interbase-keywords)
+ (sql-highlight-ingres-keywords, sql-highlight-solid-keywords)
+ (sql-highlight-mysql-keywords, sql-highlight-sqlite-keywords)
+ (sql-highlight-db2-keywords): Remove.
+ (sql-find-sqli-buffer, sql-set-sqli-buffer-generally)
+ (sql-highlight-product): Use derived-mode-p.
+ (sql-set-sqli-buffer): Use with-current-buffer.
+ (sql-connect-informix, sql-connect-ingres, sql-connect-oracle):
+ Simplify.
+
+ * emacs-lisp/lisp-mode.el (lisp-indent-region): Remove unused function.
+
+ * term.el: Fix commenting convention, turn comments into docstrings.
+
+2009-08-16 E. Jay Berkenbilt <ejb@ql.org> (tiny change)
+
+ * whitespace.el (whitespace-style): Doc fix (Bug#3661).
+
+2009-08-16 Jan Seeger <jan.seeger@thenybble.de> (tiny change)
+
+ * calendar/parse-time.el (parse-time-string-chars): Compute using
+ character classes, to handle non-ascii characters (Bug#3190).
+
+2009-08-16 Chong Yidong <cyd@stupidchicken.com>
+
+ * progmodes/sh-script.el (sh-maybe-here-document): Avoid inserting
+ another heredoc if the user adds another < (Bug#3226).
+
+ * mwheel.el (mouse-wheel-down-event, mouse-wheel-up-event):
+ Don't initialize based on window-system (Bug#4124).
+
+ * facemenu.el (facemenu-read-color): Use a completion function
+ that accepts any defined color, such as RGB triplets (Bug#3677).
+
+ * files.el (get-free-disk-space): Change fallback default
+ directory to /. Expand DIR argument before switching to fallback.
+ Suggested by Kevin Ryde (Bug#2631, Bug#3911).
+
+2009-08-15 Chong Yidong <cyd@stupidchicken.com>
+
+ * files.el (load-library): Doc fix.
+
+2009-08-15 Michael Kifer <kifer@cs.stonybrook.edu>
+
+ * emulation/viper-cmd.el (viper-insert-isearch-string): New function.
+ (viper-if-string): Redefine C-s in the minibuffer to insert the last
+ incremental search string.
+
+ * ediff-init.el (ediff-coding-system): Use escape-quoted in case of
+ XEmacs.
+
+ * ediff-merg.el (ediff-merge-region-is-non-clash-to-skip)
+ (ediff-merge-region-is-non-clash)
+ (ediff-skip-merge-region-if-changed-from-default-p): Use defun.
+ Also check if the job is really a merge job.
+
+ * ediff.el (ediff-current-file): New function.
+
+2009-08-15 Chong Yidong <cyd@stupidchicken.com>
+
+ * progmodes/js.el: Edit docstrings throughout to follow Emacs
+ conventions.
+ (js-insert-and-indent): Delete function.
+ (js-mode-map): Don't bind keys to js-insert-and-indent.
+ (js-beginning-of-defun): Rename from js--beginning-of-defun.
+ (js-end-of-defun): Rename from js--end-of-defun.
+ (js-auto-indent-flag): Delete variable.
+
+2009-08-14 Chong Yidong <cyd@stupidchicken.com>
+
+ * progmodes/js.el: Remove proclaim statement.
+ Defvar which-func-imenu-joiner-function to silence compiler.
+
+ * files.el (auto-mode-alist): Use js-mode for .js files.
+
+ * progmodes/js2-mode.el: Remove file.
+
+ * Makefile.in (ELCFILES): Add js.el, and remove js2-mode.el.
+
+ * speedbar.el (speedbar-supported-extension-expressions): Add .js.
+
+ * 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>
+
+ * progmodes/js.el: New file.
+
+2009-08-14 Mark A. Hershberger <mah@everybody.org>
+
+ * timezone.el (timezone-parse-date): Add ability to understand ISO
+ basic format (minimal separators) dates in addition to the
+ already-supported extended format dates.
+
+2009-08-14 Eli Zaretskii <eliz@gnu.org>
+
+ * international/ucs-normalize.el: Add a `coding' file variable.
+
+ * Makefile.in (ELCFILES): Add international/ucs-normalize.elc.
+
+2009-08-14 Sam Steingold <sds@gnu.org>
+
+ * vc-cvs.el (vc-cvs-merge-news): Yet another fix of message parsing.
+
+2009-08-13 Chong Yidong <cyd@stupidchicken.com>
+
+ * faces.el (help-argument-name): Define it here instead of
+ help-fns.el, because in daemon mode help-fns.el may be loaded when
+ faces are still uninitialized (Bug#1078).
+
+ * help-fns.el (help-argument-name): Move defface to faces.el.
+
+2009-08-13 Nick Roberts <nickrob@snap.net.nz>
+
+ * progmodes/gdb-mi.el (gdb-inferior-io-mode): Use start-process to
+ create buffer with a pty but no process so that GDB can make the
+ inferior the controlling process.
+
+2009-08-13 Taichi Kawabata <kawabata.taichi@gmail.com>
+
+ * international/ucs-normalize.el: New file.
+
+2009-08-13 Richard Stallman <rms@gnu.org>
+
+ * mail/rmail.el (rmail-get-attr-names):
+ Accept an attribute header that is too short.
+
+ * mail/rmail.el (rmail-forget-messages):
+ Ignore nil elt in rmail-message-vector. Use dotimes.
+
+ * progmodes/compile.el (compilation-goto-locus):
+ Use next-error-move-function.
+
+ * simple.el (next-error-move-function): New variable.
+
+2009-08-12 Juri Linkov <juri@jurta.org>
+
+ * progmodes/grep.el (lgrep): Ensure that `default-directory' is
+ always non-nil. (Bug#4052)
+
+ * replace.el (read-regexp): Return empty string when
+ `default-value' is nil.
+ (keep-lines-read-args): Don't use empty string as the
+ default value for `read-regexp'. (Bug#2495)
+
+2009-08-12 Juri Linkov <juri@jurta.org>
+
+ * international/mule-cmds.el (ucs-insert): Change arguments
+ from `arg' to `character', `count', `inherit' to be the same
+ as in `insert-char'. Doc fix. (Bug#4039)
+
+ * international/mule-conf.el (utf-16be-with-signature): Doc fix.
+
+2009-08-12 Juri Linkov <juri@jurta.org>
+
+ * files-x.el: New file.
+
+ * files.el: Move code that deals with adding/deleting
+ file/directory-local variables to files-x.el.
+
+ * Makefile.in (ELCFILES): Add files-x.elc.
+
+2009-08-11 Dmitry Dzhus <dima@sphinx.net.ru>
+
+ * progmodes/gdb-mi.el (gdb-line-posns): New helper which helps not
+ to use `goto-line'.
+ (gdb-place-breakpoints, gdb-get-location): Rewritten without
+ `goto-line'.
+ (gdb-invalidate-disassembly): Do not refresh upon receiving
+ 'update signal. Instead, update all disassembly buffers only after
+ threads list.
+ (gdb): Send -target-detach when buffer is killed (Bug#3794).
+ (gdb-starting): Move -data-list-register-names...
+ (gdb-stopped): ...here so it's sent when first thread stops.
+ (gdb-registers-handler-custom): Do nothing if register names are
+ unknown yet.
+
+ * progmodes/gud.el (gud-stop-subjob): Rewritten without macros
+ from `gdb-mi.el' to avoid extra tangling.
+
+ * progmodes/gdb-mi.el (gdb-gud-context-call): Reverting previous
+ change which breaks `gud-def' definitions used in `gdb'.
+ (gdb-update-gud-running): No extra fuss for updating frame number.
+
+2009-08-10 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * international/mule-cmds.el (mule-keymap, mule-menu-keymap)
+ (describe-language-environment-map, setup-language-environment-map)
+ (set-coding-system-map): Move initialization into declaration.
+ (set-language-info-alist): Last arg to define-key-after can be skipped.
+
+ * international/quail.el (quail-completion-1): Simplify.
+ (quail-define-rules): Use slightly more compact code.
+ (quail-insert-decode-map): Propertize keys, compact columns.
+
+ * emacs-lisp/bytecomp.el (byte-compile-interactive-only-functions):
+ Add goto-line.
+
+2009-08-10 Miles Bader <miles@gnu.org>
+
+ * progmodes/js2-mode.el (js2-warning, js2-error, js2-jsdoc-tag)
+ (js2-jsdoc-type, js2-jsdoc-value, js2-function-param)
+ (js2-instance-member, js2-private-member, js2-private-function-call)
+ (js2-jsdoc-html-tag-name, js2-jsdoc-html-tag-delimiter)
+ (js2-magic-paren, js2-external-variable):
+ Remove "-face" suffix from face names.
+ (js2-jsdoc-highlight-helper, js2-highlight-jsdoc)
+ (js2-highlight-undeclared-vars, js2-peek-token)
+ (js2-parse-function-params, js2-mode-show-errors)
+ (js2-mode-show-warnings, js2-make-magic-delimiter)
+ (js2-mode-highlight-magic-parens): Update to use new face names.
+
+2009-08-09 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-get-ls-command-with-dired): New defun.
+ (tramp-handle-insert-directory): Handle "--dired". (Bug#4075)
+
+2009-08-09 Chong Yidong <cyd@stupidchicken.com>
+
+ * subr.el: Provide hashtable-print-readable.
+
+ * progmodes/hideshow.el (hs-special-modes-alist): Don't use
+ hs-c-like-adjust-block-beginning.
+ (hs-hide-block-at-point): Stop hiding at the beginning of
+ hs-block-end-regexp (Bug#700).
+
+2009-08-09 Dmitry Dzhus <dima@sphinx.net.ru>
+
+ * progmodes/gdb-mi.el (gdb-gud-context-call): Does not need to be
+ a macro.
+ (gdb-registers-handler-custom): Do not fail when register names
+ are unavailable.
+
+2009-08-08 Dmitry Dzhus <dima@sphinx.net.ru>
+
+ * progmodes/gdb-mi.el (gdb-control-all-threads)
+ (gdb-control-current-thread): Interactive setters for
+ `gdb-gud-control-all-threads' to use in menu.
+ (gdb-show-run-p): Show «Go» when process is not active.
+ (gud-tool-bar-map): Add non-stop/A,T indicator.
+ Uses gud/thread.xpm and gud/all.xpm.
+
+2009-08-08 Yoni Rabkin <yoni@rabkins.net>
+
+ * net/net-utils.el (net-utils-font-lock-keywords): New var.
+ (nslookup-font-lock-keywords): Make it a variable.
+ (net-utils-mode): New mode for viewing diagnostic network output.
+ (net-utils-remove-ctrl-m-filter): Set inhibit-read-only.
+ (net-utils-run-simple): New function.
+ (ifconfig, iwconfig, netstat, arp, route): Use it.
+
+2009-08-08 Dmitry Dzhus <dima@sphinx.net.ru>
+
+ * progmodes/gdb-mi.el (gdb-read-memory-custom)
+ (gdb-memory-set-address, def-gdb-set-positive-number)
+ (def-gdb-memory-format, def-gdb-memory-unit): Update memory buffer
+ after changing settings.
+ (gdb-invalidate-disassembly): Update when first shown.
+ (gdb-edit-locals-value): Fix.
+ (gdb-registers-handler-custom): Print registers in right order and
+ allow changing register values (only for current thread yet).
+ (gdb-breakpoints-mode-map): Don't assume threads buffer is present.
+ (gdb-threads-mode-map): Don't assume breakpoints buffer is present.
+ (gdb-disassembly-handler-custom, gdb-stack-list-frames-custom)
+ (gdb-locals-handler-custom, gdb-registers-handler-custom):
+ Thread info in mode name.
+ (gdb-registers-mode-map): TAB to switch to locals.
+
+2009-08-08 Eli Zaretskii <eliz@gnu.org>
+
+ * mail/rmail.el (rmail-add-mbox-headers)
+ (rmail-set-message-counters-counter): Search for
+ rmail-unix-mail-delimiter instead of just "From ". (Bug#4076)
+
+2009-08-08 Glenn Morris <rgm@gnu.org>
+
+ * Makefile.in (ELCFILES): Update.
+
+2009-08-07 Eli Zaretskii <eliz@gnu.org>
+
+ * mail/sendmail.el (mail-yank-original):
+ Set buffer-file-coding-system from the one used by the message whose
+ text is yanked.
+
+ * calc/calc-graph.el (calc-graph-plot): Set calc-graph-last-device
+ to "windows" when "pgnuplot" is used.
+ (calc-graph-command, calc-gnuplot-command, calc-graph-init):
+ Don't call accept-process-output if "pgnuplot" is used.
+ (calc-graph-init): Don't send -display and -geometry to
+ "pgnuplot". If "pgnuplot" is used, glean gnuplot version by
+ running "pgnuplot -V" with shell-command-to-string.
+
+ * calc/calc.el (calc-gnuplot-name) [windows-nt]: Use "pgnuplot" as
+ the default.
+
+2009-08-07 Eli Zaretskii <eliz@gnu.org>
+
+ * Makefile.in (ELCFILES): org/org-export-latex.elc renamed to
+ org/org-latex.elc.
+
+2009-08-07 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-dispatcher.el (vc-resynch-window): Update comment.
+
+ * term.el (term-handle-ansi-escape): Add comments with the
+ terminfo capabilities implemented.
+
+2009-08-06 Dmitry Dzhus <dima@sphinx.net.ru>
+
+ * progmodes/gdb-mi.el (gdb-var-create-regexp): Remove.
+ (gdb-var-create-handler): Rewritten using JSON parser.
+ (gdb-propertize-header): Move earlier.
+ (gdb-set-header): Remove to avoid duplication.
+ (gdb-thread-list-handler-custom, gdb-invalidate-disassembly):
+ Refresh disassembly buffers only after threads list have been
+ update.
+ (gdb-threads-header, gdb-registers-header): Per-buffer header line
+ variables.
+
+2009-08-04 Juri Linkov <juri@jurta.org>
+
+ * files.el: Commands to add/delete file/directory-local variables.
+ (read-file-local-variable, read-file-local-variable-value)
+ (read-file-local-variable-mode, modify-file-local-variable)
+ (modify-file-local-variable-prop-line)
+ (modify-dir-local-variable): New functions.
+ (add-file-local-variable, delete-file-local-variable)
+ (add-file-local-variable-prop-line, delete-file-local-variable-prop-line)
+ (add-dir-local-variable, delete-dir-local-variable)
+ (copy-file-locals-to-dir-locals, copy-dir-locals-to-file-locals)
+ (copy-dir-locals-to-file-locals-prop-line): New commands.
+
+2009-08-04 Chong Yidong <cyd@stupidchicken.com>
+
+ * abbrev.el (insert-abbrev-table-description): Prettify output.
+ Suggested by Karl Chen.
+
+2009-08-04 Dmitry Dzhus <dima@sphinx.net.ru>
+
+ * progmodes/gdb-mi.el (gdb-frame-number): Initialize with nil.
+ (gdb-overlay-arrow-position): Rename to `gdb-disassembly-position'.
+ (gdb-overlay-arrow-position, gdb-thread-position)
+ (gdb-disassembly-position): Declare variables.
+ (gdb-wait-for-pending): Function now.
+ (gdb-add-subscriber, gdb-delete-subscriber, gdb-get-subscribers)
+ (gdb-emit-signal, gdb-buf-publisher): Declare before first use so
+ compilation goes smoothly.
+ (gdb, gdb-non-stop, gdb-buffers): New customization groups.
+ (gdb-non-stop-setting): New customization setting which replaces
+ `gdb-non-stop' so changing it doesn't break active GDB session.
+ (gdb-stack-buffer-locations, gdb-stack-buffer-addresses)
+ (gdb-thread-buffer-verbose-names, gdb-thread-buffer-arguments)
+ (gdb-thread-buffer-locations, gdb-thread-buffer-addresses)
+ (gdb-show-threads-by-default): New customization options.
+ (gdb-buffer-type, gdb-buffer-shows-main-thread-p): New helper
+ routines.
+ (gdb-get-buffer-create): Send buffers update signal when they are
+ created.
+ (gdb-invalidate-locals, gdb-invalidate-registers)
+ (gdb-invalidate-breakpoints)
+ (gdb-invalidate-threads, gdb-invalidate-disassembly)
+ (gdb-invalidate-memory): Accept update signal.
+ (gdb-current-context-command): Use --frame option.
+ (gdb-update-gud-running, gdb-running, gdb-setq-thread-number):
+ Implement `gdb-frame-number' selection logic.
+ (gdb-show-run-p, gdb-show-stop-p): Helper functions which decide
+ whether to show GUD toolbar buttons.
+ (gdb-thread-exited): Unselect current thread when it exits.
+ (gdb-stopped): Typo fixed (now really runs `gdb-stopped-hooks').
+ (gdb-mark-line): Routine which sets overlay arrow or inverses
+ video on fringeless displays.
+ (gdb-table, gdb-table-add-row, gdb-table-string): Structure used
+ to build aligned columns of data in GDB buffers and set text
+ properties line-by-line.
+ (gdb-invalidate-breakpoints)
+ (gdb-breakpoints-list-handler-custom)
+ (gdb-thread-list-handler-custom, gdb-disassembly-handler-custom)
+ (gdb-stack-list-frames-custom, gdb-locals-handler-custom)
+ (gdb-registers-handler-custom): Align data columns.
+ (gdb-locals-handler-custom): Now prints data like in variable
+ declarations.
+ (gdb-jump-to, gdb-file-button, gdb-insert-file-location-button):
+ Remove confusing buttons.
+ (gdb-invalidate-threads): Append --frame.
+ (gdb-threads-mode-map, gdb-breakpoints-mode-map): TAB to switch
+ between breakpoints/threads buffers.
+ (gdb-set-window-buffer): Now can ignore dedicated windows.
+ (gdb-propertize-header): Use `gdb-set-window-buffer'.
+ (def-gdb-thread-buffer-simple-command): Numerous typos fixed.
+ (def-gdb-thread-buffer-gud-command): Replaces
+ `def-gdb-thread-buffer-gdb-command' and uses standard GUD commands
+ for fine thread control.
+ (gdb-preempt-existing-or-display-buffer): New function used to
+ display bound buffers without breaking window layout.
+ (gdb-frame-location): Replaces `gdb-insert-frame-location'.
+ (gdb-select-frame): New version of `gdb-frames-select' which now
+ sets `gdb-frame-number' so commands may use --frame option instead
+ of inner debugger state.
+ (gdb-frame-handler): Do not set `gdb-frame-number'.
+ (gdb-threads-mode-map): Select threads with mouse.
+
+ * progmodes/gud.el (gdb-gud-context-call): Declare function to
+ avoid compilation warning.
+ (gud-menu-map, gud-minor-mode-map): Use `gdb-show-run-p` and
+ `gdb-show-stop-p`.
+
+ * progmodes/gdb-mi.el (gdb-get-buffer, gdb-get-buffer-create):
+ Argument `key' renamed to `buffer-type'.
+ (gdb-current-context-buffer-name): Do not add thread info to
+ buffer name when no thread is selected.
+ (gdbmi-record-list, gdb-shell): Try to handle GDB `shell'
+ command (bug 3794).
+ (gdb-thread-selected): Handle `=thread-selected' notification.
+ (gdb-wait-for-pending): New macro to deal with congestion problems.
+ (gdb-breakpoints-list-handler-custom): Don't fail on pending
+ breakpoints.
+ (gdb-invalidate-disassembly): Use 'fullname instead of 'file.
+ This fixes problem similar to one described in bug 3947.
+ (gud-menu-map): More menu items.
+ (gdb-init-1): Reset `gdb-thread-number' to nil.
+
+ * progmodes/gud.el (gud-stop-subjob, gud-menu-map): Respect GDB
+ non-stop settings.
+
+ * progmodes/gdb-mi.el (gdb-thread-number): Initialize with nil.
+ (gdb-current-context-command): Do not append --thread if
+ `gdb-thread-number' is nil.
+ (gdb-running-threads-count, gdb-stopped-threads-count):
+ New variables.
+ (gdb-non-stop, gdb-gud-control-all-threads, gdb-switch-reasons)
+ (gdb-stopped-hooks, gdb-switch-when-another-stopped):
+ New customization options.
+ (gdb-gud-context-command, gdb-gud-context-call): New wrappers for
+ GUD commands.
+ (gdb): `gud-def' definitions changed to use `gdb-gud-context-call'.
+ (gdb-init-1): Activate non-stop mode if `gdb-non-stop' is enabled.
+ (gdb-setq-thread-number, gdb-update-gud-running): New functions to
+ set `gdb-thread-number' and update `gud-running' properly.
+ (gdb-running): Update threads list when new threads appear.
+ (gdb-stopped): Support non-stop operation and new thread switching
+ logic.
+ (gdb-jsonify-buffer, gdb-json-read-buffer, gdb-json-string)
+ (gdb-json-partial-output): New set of JSON routines.
+ (def-gdb-auto-update-trigger): New `signal-list' optional
+ argument.
+ (gdb-thread-list-handler-custom): Update `gud-running',
+ `gdb-stopped-threads-count' and `gdb-running-threads-count'.
+ (def-gdb-thread-buffer-gdb-command, gdb-interrupt-thread)
+ (gdb-continue-thread, gdb-step-thread): New commands for fine
+ thread execution control.
+ (gud-menu-map): New menu items to switch non-stop options.
+ (gdb-reset): Cleanup `gdb-thread-position' overlay arrow marker.
+ (gdb-send): Mimic RET properly (bug 3794).
+
+ * progmodes/gdb-mi.el (gdb-rules-name-maker)
+ (gdb-rules-buffer-mode, gdb-rules-update-trigger): Accessors for
+ gdb-buffer-rules.
+ (def-gdb-auto-update-handler): New nopreserve optional argument.
+ (gdb-stack-list-frames-custom): Print stack from top to bottom.
+
+ * progmodes/gdb-mi.el (gdb-pc-address): Remove unused variable.
+ (gdb-threads-list, gdb-breakpoints-list): New assoc lists.
+ (gdb-parent-mode): New mode to derive other GDB modes from.
+ (gdb-display-disassembly-for-thread)
+ (gdb-frame-disassembly-for-thread): New commands for threads
+ buffer.
+
+ * progmodes/gdb-mi.el (gdb-get-buffer, gdb-get-buffer-create)
+ (gdb-init-1, gdb-bind-function-to-buffer, gdb-add-subscriber)
+ (gdb-get-subscribers, gdb-emit-signal, gdb-buf-publisher)
+ (gdb-update): We now store all GDB buffers in a list so that they
+ can be updated by traversing a list instead of calling invalidate
+ triggers explicitly.
+ (def-gdb-trigger-and-handler): New macro to define trigger-handler
+ pair for GDB buffer.
+ (gdb-stack-buffer-name): Add thread information.
+ (gdb-add-pending, gdb-pending-p, gdb-delete-pending): Macros to
+ handle pending triggers.
+ (gdb-threads-mode-map, def-gdb-thread-buffer-command)
+ (def-gdb-thread-buffer-simple-command)
+ (gdb-display-stack-for-thread, gdb-display-locals-for-thread)
+ (gdb-display-registers-for-thread, gdb-frame-stack-for-thread)
+ (gdb-frame-locals-for-thread, gdb-frame-registers-for-thread):
+ New commands which show buffers bound to thread.
+ (gdb-stack-list-locals-regexp): Remove unused regexp.
+
+ * progmodes/gdb-mi.el (gdb-breakpoints-buffer-name)
+ (gdb-locals-buffer-name, gdb-registers-buffer-name)
+ (gdb-memory-buffer-name, gdb-stack-buffer-name): Do not switch
+ to (gud-comint-buffer) in *-buffer-name functions
+ because (gdb-get-target-string) already does that.
+ (gdb-locals-handler-custom, gdb-registers-handler-custom)
+ (gdb-changed-registers-handler): Rewritten without regexps.
+
+ * progmodes/gdb-mi.el: Basic thread selection support.
+ (gdb-thread-number): New variable.
+ (gdb-current-context-command): New macro which adds --thread
+ option to command.
+ (gdb-threads-mode-map): Select thread with SPC.
+ (gdb-thread-list-handler-custom): Mark current thread with overlay
+ arrow. Synchronize GDB thread and Emacs thread.
+ (gdb-select-thread): New command which selects current thread.
+ (gdb-invalidate-frames, gdb-invalidate-locals)
+ (gdb-invalidate-registers): Use --thread option.
+
+2009-08-04 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (top): Make check for tramp-gvfs loading more
+ robust. (Bug#3977)
+ (tramp-handle-insert-file-contents): `unwind-protect' must be
+ inside `with-parsed-tramp-file-name'.
+
+ * net/tramp-gvfs.el (top): Remove superfluous message when loading
+ fails.
+
+2009-08-03 Nick Roberts <nickrob@snap.net.nz>
+
+ * progmodes/gud.el (jdb): Set gud-jdb-classpath-string to current
+ directory if CLASSPATH is not set.
+
+2009-08-03 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-rfn-eshadow-update-overlay-regexp):
+ New defconst.
+ (tramp-rfn-eshadow-update-overlay): Use it. (Bug#4004)
+
+2009-08-02 Kevin Ryde <user42@zip.com.au>
+
+ * net/newst-backend.el (newsticker--raw-url-list-defaults):
+ Update freshmeat link. Delete newsforge.com as it seems gone.
+
+2009-08-02 Chong Yidong <cyd@stupidchicken.com>
+
+ * select.el (x-set-selection): Doc fix (Bug#4021).
+
+ * w32-fns.el (x-set-selection): Doc fix (Bug#4021).
+
+ * help-fns.el (describe-variable): Treat list return values from
+ dir-locals-find-file properly (Bug#4005).
+
+2009-08-02 Julian Scheid <julians37@googlemail.com> (tiny change)
+
+ * net/tramp.el (tramp-debug-message): Print also microseconds.
+
+2009-08-02 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-handle-insert-file-contents): Optimize, when BEG
+ or END is non-nil.
+ (tramp-handle-vc-registered): Use `tramp-cache-inhibit-cache'.
+ (tramp-get-debug-buffer): Change `outline-regexp' according to new
+ format.
+
+ * net/tramp-cache.el (tramp-cache-inhibit-cache): New defvar.
+ (tramp-get-file-property): Use it.
+
+ * autorevert.el (auto-revert-handler):
+ Allow `auto-revert-tail-mode' for remote files.
+
+2009-08-02 Jason Rumney <jasonr@gnu.org>
+
+ * minibuffer.el (read-file-name): Treat confirm options to
+ MUSTMATCH as nil when invoking x-file-dialog. (Bug#3969)
+
+2009-08-02 Chong Yidong <cyd@stupidchicken.com>
+
+ * font-lock.el (font-lock-string-face, font-lock-builtin-face)
+ (font-lock-variable-name-face, font-lock-constant-face):
+ Darken the colors for light backgrounds.
+
+2009-08-01 Eli Zaretskii <eliz@gnu.org>
+
+ * mail/rmailsum.el (rmail-header-summary): Ignore letter-case of
+ month names. (Bug#3987)
+
+2009-07-31 Chong Yidong <cyd@stupidchicken.com>
+
+ * simple.el (line-move-finish): Pass whole number to
+ line-move-to-column.
+ (line-move-visual): Perform hscroll to the recorded position.
+
+2009-07-30 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc-mode.el (calc-matrix-brackets): Remove "P" from prompt.
+
+2009-07-29 Alan Mackenzie <acm@muc.de>
+
+ * progmodes/cc-defs.el (c-version): Bump to 5.31.7.
+
+2009-07-29 Dmitry Dzhus <dima@sphinx.net.ru>
+
+ * progmodes/gdb-mi.el (gdb-goto-breakpoint)
+ (gdb-place-breakpoints): Use full path when setting breakpoints.
+
+2009-07-29 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc.el (calc-mode-map): Add keybinding for
+ `calc-transpose-lines'.
+
+2009-07-29 Vincent Belaïche <vincent.belaiche@gmail.com>
+
+ * calc/calc-misc.el (calc-transpose-lines): New function.
+
+2009-07-28 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-do-copy-or-rename-file): Add messages.
+ Simplify check for out-of-band methods.
+ (tramp-do-copy-or-rename-file-out-of-band): Allow both files to be
+ remote. Remove messages which are in `tramp-do-copy-or-rename-file'.
+
+2009-07-28 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-git.el (vc-git-checkin): Fix typo.
+
+2009-07-28 Steve Yegge <steve.yegge@gmail.com>
+
+ * progmodes/js2-mode.el: New file.
+
+2009-07-28 Nick Roberts <nickrob@snap.net.nz>
+
+ * progmodes/gud.el (jdb): Add gud-pstar to dump object information.
+ (gud-menu-map): Adjust tooltip accordingly.
+
+2009-07-27 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-bzr.el (vc-bzr-print-log): Pass multiple arguments to bzr log.
+ (vc-bzr-log-view-mode): Adjust log-view-file-re.
+
+ * add-log.el (change-log-mode-map): Add a menu.
+
+2009-07-27 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/dbus.el (dbus-call-method-non-blocking): Handle the case the
+ function returns nil.
+ (dbus-handle-event): Handle special return value :ignore.
+ Reported by Jan Moringen <jan.moringen@uni-bielefeld.de>.
+
+2009-07-26 Chong Yidong <cyd@stupidchicken.com>
+
+ * view.el (view-mode-enable): Don't define Helper-return-blurb if
+ it's not needed.
+
+2009-07-25 Eli Zaretskii <eliz@gnu.org>
+
+ Fix Bug#3888:
+
+ * w32-vars.el (x-select-enable-clipboard): Doc fix.
+
+ * term/pc-win.el (x-display-name, x-colors)
+ (x-select-enable-clipboard, x-select-text): Doc fix.
+
+ * term/common-win.el (x-display-name, x-colors): Doc fix.
+
+ * term/ns-win.el (x-select-text, x-setup-function-keys, x-colors)
+ (xw-defined-colors): Doc fix.
+
+ * w32-fns.el (x-select-text, x-setup-function-keys)
+ (x-get-selection, x-set-selection): Doc fix.
+
+ * term/x-win.el (x-select-text, x-setup-function-keys)
+ (x-select-enable-clipboard, xw-defined-colors): Doc fix.
+
+ * select.el (x-set-selection): Doc fix.
+
+2009-07-25 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/zeroconf.el (zeroconf-init): Check for "GetVersionString"
+ instead of "IsNSSSupportAvailable". Avahi ought to work also when
+ "IsNSSSupportAvailable" method is not available.
+ Reported by Steve Youngs <steve@sxemacs.org>.
+
+2009-07-24 Kenichi Handa <handa@m17n.org>
+
+ * international/characters.el: Fix setting of category ?C, ?|, ?K,
+ and ?H. Fix setting of case for Latin Extended and Greek Extended.
+ (build-unicode-category-table): Fix range checks.
+
+2009-07-24 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-dispatcher.el (vc-resynch-buffers-in-directory): Make sure
+ the buffer we try to sync is current when calling
+ vc-resynch-buffer.
+
+ * vc-dir.el (vc-dir-resynch-file): Make sure vc-dir-update does
+ not show up to date files.
+
+2009-07-24 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/elint.el (elint-current-buffer, elint-defun):
+ Add autoload cookies. If necessary, initialize.
+ (elint-log): Handle non-file buffers.
+ (elint-initialize): Add optional argument to reinitialize.
+ (elint-find-builtin-variables): Save excursion.
+
+2009-07-23 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * emacs-lisp/lisp-mode.el (emacs-lisp-mode-map): Add menu entries
+ for Lint.
+
+2009-07-22 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc.el (vc-print-log-internal): New function, split out from ...
+ (vc-print-log): ... here.
+ (vc-dir-move-to-goal-column): Declare.
+
+ * vc-git.el (vc-git-add-signoff): New variable.
+ (vc-git-checkin): Use it.
+ (vc-git-toggle-signoff): New function.
+ (vc-git-extra-menu-map): Bind it to menu.
+ (vc-git--run-command-string): Accept a nil FILE argument.
+ (vc-git-stash-list): New function.
+ (vc-git-dir-extra-headers): Use it.
+
+2009-07-23 Glenn Morris <rgm@gnu.org>
+
+ * help-fns.el (describe-variable): Describe ignored and risky local
+ variables in a similar way to that in which we describe safe ones.
+
+ * emacs-lisp/bytecomp.el (byte-compile-from-buffer)
+ (byte-compile-output-file-form, byte-compile-output-docform)
+ (byte-compile-file-form-defmumble, byte-compile-output-as-comment):
+ Give some more local variables with common names a "bytecomp-" prefix,
+ so as not to shadow things during compilation.
+ * emacs-lisp/cl-macs.el (load-time-value)
+ * emacs-lisp/cl.el (cl-compiling-file): Update for the name-change
+ `outbuffer' to `bytecomp-outbuffer'.
+
+ * emacs-lisp/elint.el (elint-standard-variables): Remove most members,
+ since the next two variables cover them automatically now.
+ (elint-builtin-variables, elint-autoloaded-variables): New.
+ (elint-unknown-builtin-args): Remove all members, since they can be
+ parsed automatically now.
+ (elint-extra-errors): New.
+ (elint-env-add-env, elint-env-add-macro): Use cadr.
+ (elint-current-buffer): Use or. Change final message.
+ (elint-get-top-forms): Use line-end-position.
+ (elint-init-env): Use cadr. Handle autoload, declare-function,
+ and defalias.
+ (elint-add-required-env): Doc fix. Use or. Standardize error.
+ (regexp-assoc): Remove unused function.
+ (elint-top-form): Set elint-current-pos, to record the start of the
+ top-level form, for compilation-mode.
+ (elint-form): Trap errors in macro expansion. Use dolist.
+ (elint-unbound-variable): Use elint-builtin-variables and
+ elint-autoloaded-variables.
+ (elint-get-args): Use cadr, or.
+ (elint-check-cond-form): Use dolist, cadr.
+ (elint-check-condition-case-form): Doc fix. Use cadr.
+ Use elint-extra-errors.
+ (elint-log): New function.
+ (elint-error, elint-warning): Use elint-log for a bytecomp-style format.
+ Distinguish errors and warnings.
+ (elint-log-message): Use with-current-buffer. Inhibit read-only.
+ Use a bytecomp-style format.
+ (elint-clear-log): Preserve default-directory. Inhibit read-only.
+ (elint-get-log-buffer): Use compilation mode. Disable undo.
+ Don't truncate lines.
+ (elint-initialize): Set builtin and autoloaded variable lists.
+ Only process elint-unknown-builtin-args if non-nil.
+ (elint-find-builtin-variables, elint-find-autoloaded-variables):
+ New functions.
+ (elint-find-builtin-args): Doc fix. Handle "BODY...)".
+
+2009-07-22 Kevin Ryde <user42@zip.com.au>
+
+ * net/newst-backend.el (newsticker--parse-atom-1.0)
+ (newsticker--parse-rss-0.91, newsticker--parse-rss-0.92)
+ (newsticker--parse-rss-1.0):
+ * progmodes/idlwave.el (idlwave-mode):
+ * progmodes/idlw-shell.el (idlwave-shell-mode):
+ * progmodes/vera-mode.el (vera-mode):
+ * progmodes/verilog-mode.el (verilog-auto-inst, verilog-auto):
+ * progmodes/vhdl-mode.el (vhdl-mode):
+ * textmodes/table.el (table-generate-source)
+ (table--warn-incompatibility):
+ Hyperlink urls in docstrings with URL `...'.
+
+2009-07-22 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/advice.el, emacs-lisp/checkdoc.el:
+ * emacs-lisp/debug.el, emacs-lisp/elp.el, emacs-lisp/gulp.el:
+ * emacs-lisp/lisp.el, emacs-lisp/pp.el, emacs-lisp/trace.el:
+ Remove leading * from defcustom docs.
+
+ * simple.el (blink-matching-paren-distance): Bump to 100k. (Bug#3889)
+
+ * emacs-lisp/shadow.el (shadows-compare-text-p): Remove leading * from
+ defcustom doc.
+ (list-load-path-shadows): Optionally, just return shadows as a string.
+
+ * mail/emacsbug.el (report-emacs-bug): Include any load-path shadows.
+
+2009-07-21 Chong Yidong <cyd@stupidchicken.com>
+
+ * mail/rmailedit.el (rmail-edit-mode):
+ Use auto-save-include-big-deletions.
+
+ * mail/rmail.el (rmail-variables):
+ Use auto-save-include-big-deletions.
+
+ * files.el (auto-save-mode): Revert 2009-07-21 and 2009-07-16
+ changes.
+
+2009-07-21 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc.el (calc-undo-length): New variable.
+ (calc-quit): Truncate rather than eliminate `calc-undo-list'.
+
+2009-07-21 Richard Stallman <rms@gnu.org>
+
+ * files.el (auto-save-mode): Handle buffer-save-size = -2
+ for toggling mode.
+
+2009-07-21 Glenn Morris <rgm@gnu.org>
+
+ * textmodes/ispell.el (ispell-looking-back): Update declaration.
+
+ * calendar/todo-mode.el (calendar-current-date): Update declaration.
+
+ * ps-print.el (ps-jitify, ps-lazify): Remove aliases only used to
+ silence compiler. Instead...
+ (jit-lock-fontify-now, lazy-lock-fontify-region): ...Declare.
+ (ps-print-ensure-fontified): Update for above function name changes.
+
+ * printing.el (pr-mh-get-msg-num, pr-mh-show)
+ (pr-mh-start-of-uncleaned-message): Remove aliases only used to
+ silence compiler. Instead...
+ (mh-get-msg-num, mh-show, mh-start-of-uncleaned-message): ...Declare.
+ (mh-show-buffer): Only define for compiler.
+ (pr-mh-current-message): Update for above function name changes.
+
+ * files.el (abort-if-file-too-large): Explicitly pass `filename'
+ as an argument.
+ (find-file-noselect, insert-file-1): Update for above change.
+
+ * mail/rmail.el (rmail-retry-ignored-headers): Bump :version.
+
+ * mail/mailclient.el (mailclient-send-it): Fix message.
+
+ * emacs-lisp/edebug.el (cl-debug-env): Only define for compiler.
+ (edebug-eval): Check cl-debug-env is bound.
+ (print-level, print-circle): Don't redefine built-in variables.
+
+ * emacs-lisp/cust-print.el: Remove leading * from defcustom docs.
+ (custom-print-vectors): Remove old comments from doc.
+
+ * emerge.el (menu-bar-emerge-menu): Remove unused variable.
+ (emerge-version): Make the variable an obsolete alias for the
+ emacs-version variable. Make the function obsolete.
+ (emerge-fast-keymap, emerge-edit-keymap): Make a separate menu for
+ Emerge options, rather than merging in into the main Options menu.
+ (emerge-options-menu): Adjust menu text. Use buttons for skip prefers
+ and auto advance modes. Disable edit/fast items when not relevant.
+
+2009-07-20 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * term/vt420.el (terminal-init-vt420): Fix typo.
+
+2009-07-20 Sam Steingold <sds@gnu.org>
+
+ * progmodes/ada-mode.el (compile-auto-highlight): Remove the
+ variable (removed from compile.el on 2004-03-11).
+
+2009-07-20 Chong Yidong <cyd@stupidchicken.com>
+
+ * files.el (hack-local-variables-filter): Fix last change.
+
+2009-07-19 Juri Linkov <juri@jurta.org>
+
+ * files.el (ignored-local-variables): Add `dir-local-variables-alist'.
+ (dir-local-variables-alist): New buffer-local variable.
+ (hack-local-variables-filter): If variable is not dir-local,
+ i.e. `dir-name' is nil, then remove it from `dir-local-variables-alist',
+ because file-local overrides dir-local.
+ (c-postprocess-file-styles) <declare-function>:
+ Remove obsolete declaration.
+ (hack-dir-local-variables): Add dir-local variable/value pair to
+ `dir-local-variables-alist' and remove duplicates. Doc fix.
+
+ * help-fns.el (describe-variable): Add information about
+ file-local and dir-local variables.
+
+2009-07-19 Chong Yidong <cyd@stupidchicken.com>
+
+ * files.el (hack-local-variables-filter): Rewrite.
+
+2009-07-19 Glenn Morris <rgm@gnu.org>
+
+ * progmodes/verilog-mode.el (verilog-error-regexp-add-xemacs):
+ Silence compiler by only defining on XEmacs.
+
+ * international/mule.el (auto-coding-regexp-alist): Only match
+ BABYL... at the start of buffer, not of lines. (Bug#3790)
+
+ * calendar/cal-menu.el (cal-menu-set-date-title): Handle calls from
+ non-calendar buffers (Bug#3862). Restore "not on a date" message.
+ (cal-menu-context-mouse-menu): Doc fix.
+
+ * desktop.el (desktop-buffers-not-to-save): Set :version tag.
+
+ * simple.el (mail-user-agent): Doc fix. Set :version tag.
+
+2009-07-18 Juri Linkov <juri@jurta.org>
+
+ * info.el: Virtual Info keyword finder.
+ (add-to-list) <Info-virtual-files>: Add "\\`\\*Finder.*\\*\\'".
+ (Info-finder-file): New variable.
+ (Info-finder-find-file): New function.
+ (finder-known-keywords, finder-package-info)
+ (find-library-name, lm-commentary): Use defvar and
+ declare-function to silence compiler warnings.
+ (Info-finder-find-node): New function.
+ (info-finder): New command.
+
+ * subr.el (process-kill-buffer-query-function): New function.
+ (add-hook)<kill-buffer-query-functions>: Add hook
+ `process-kill-buffer-query-function'.
+
+2009-07-18 Alan Mackenzie <acm@muc.de>
+
+ * progmodes/cc-mode.el (c-before-hack-hook)
+ (c-postprocess-file-styles): Give invocation of `c-set-style'
+ DONT-OVERRIDE parameter of t. Already set style variables will
+ thus not be overridden by style settings given by `c-file-syle'.
+
+ * files.el (hack-local-variables-filter): Remove entries with
+ duplicate keys from `file-local-variables-alist'.
+
+2009-07-18 Eli Zaretskii <eliz@gnu.org>
+
+ * simple.el (deactivate-mark, activate-mark, set-mark): Don't call
+ x-set-selection if display-selections-p returns nil for the
+ current frame.
+
+2009-07-18 Chong Yidong <cyd@stupidchicken.com>
+
+ * simple.el (region-active-p, use-region-p): Doc fix (Bug#3873).
+
+2009-07-18 Eli Zaretskii <eliz@gnu.org>
+
+ * desktop.el (desktop-buffers-not-to-save): Default value is nil.
+ Accept nil in addition to a regexp.
+ (desktop-files-not-to-save): Add "(ftp)$" to the default regexp.
+ Accept nil in addition to a regexp.
+ (desktop-save-buffer-p): Don't use desktop-buffers-not-to-save for
+ buffers that have an associated file. Handle nil values of
+ desktop-buffers-not-to-save and desktop-files-not-to-save.
+ (Bug#3833)
+
+ * term/pc-win.el (x-selection-owner-p, x-own-selection-internal)
+ (x-disown-selection-internal): New functions.
+
+2009-07-18 Nick Roberts <nickrob@snap.net.nz>
+
+ * progmodes/gdb-mi.el (speedbar-frame): Declare to avoid compiler
+ warning.
+ (gdb-breakpoints-header): Move forward to avoid compiler warning.
+ (gdb-make-header-line-mouse-map): Remove duplicate definition.
+
+2009-07-18 David De La Harpe Golden <david@harpegolden.net>
+
+ * simple.el (set-mark): Revert last change.
+
+2009-07-17 Tassilo Horn <tassilo@member.fsf.org>
+
+ * doc-view.el (doc-view-initiate-display): Add yes-or-no-p if
+ rendering of pngs is not possible instead of messaging a long
+ description.
+
+2009-07-17 David De La Harpe Golden <david@harpegolden.net>
+
+ * w32-fns.el (x-selection-owner-p): New function.
+
+ * mouse.el (mouse-drag-track): Call deactivate-mark earlier.
+ (mouse-yank-at-click, mouse-yank-primary):
+ If select-active-regions is non-nil, deactivate the mark before
+ insertion.
+
+ * simple.el (deactivate-mark, set-mark): Only save selection if we
+ own it.
+
+2009-07-17 Kenichi Handa <handa@m17n.org>
+
+ * case-table.el (describe-buffer-case-table): Fix for the case
+ that KEY is a cons.
+
+2009-07-16 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-rcs.el (vc-rcs-find-file-hook):
+ * vc-sccs.el (vc-sccs-find-file-hook): Fix cut and paste error.
+
+2009-07-16 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-wait-for-output): Handle the case when
+ commands do not return a newline but a null byte before the shell
+ prompt. (Bug#3858)
+
+2009-07-16 YAMAMOTO Mitsuharu <mituharu@math.s.chiba-u.ac.jp>
+
+ * term/ns-win.el (ns-set-alpha): Don't declare.
+ (ns-set-background-alpha): Remove function.
+
+2009-07-16 Kevin Ryde <user42@zip.com.au>
+
+ * emacs-lisp/copyright.el (copyright-update): Save match-data across
+ y-or-n-p, for safety.
+
+2009-07-16 Richard Stallman <rms@gnu.org>
+
+ * files.el (auto-save-mode): If buffer-saved-size is -2,
+ don't clobber it.
+
+ * mail/rmail.el (rmail-variables): Set buffer-saved-size to -2.
+ (rmail-retry-ignored-headers): Add more uninteresting fields.
+
+2009-07-15 Jari Aalto <jari.aalto@cante.net>
+
+ * net/rcirc.el (rcirc): Use history variables.
+ (rcirc-server-name-history, rcirc-nick-name-history)
+ (rcirc-server-port-history): New variables.
+
+2009-07-15 Kenichi Handa <handa@m17n.org>
+
+ * international/mule-cmds.el (set-language-environment-charset):
+ If coding-system-charset-list returns `iso-2022' or `emacs-mule',
+ ignore them.
+
+ * language/misc-lang.el ("IPA"): Change coding systems to utf-8.
+ Delete unibyte-display.
+
+2009-07-15 Chong Yidong <cyd@stupidchicken.com>
+
+ * simple.el (kill-visual-line): Obey kill-whole-line (Bug#3695).
+
+2009-07-15 Chong Yidong <cyd@stupidchicken.com>
+
+ * simple.el (deactivate-mark): Optional argument FORCE.
+ (set-mark): Use deactivate-mark.
+
+ * info.el (Info-search): No need to check transient-mark-mode
+ before calling deactivate-mark.
+
+ * select.el (x-set-selection): Doc fix.
+ (x-valid-simple-selection-p): Allow buffer values.
+ (xselect--selection-bounds): Handle buffer values.
+ Suggested by David De La Harpe Golden.
+
+ * mouse.el (mouse-set-region, mouse-drag-track):
+ Call copy-region-as-kill before setting the mark, to let
+ select-active-regions work.
+
+2009-07-15 David De La Harpe Golden <david@harpegolden.net>
+
+ * simple.el (deactivate-mark): If select-active-regions is
+ non-nil, copy the selection data into a string.
+ (activate-mark): If select-active-regions is non-nil, set the
+ selection to the current buffer.
+ (set-mark): Update selection if select-active-regions is non-nil.
+
+ * select.el (x-valid-simple-selection-p): Allow buffer values.
+
+2009-07-14 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * simple.el (mail-user-agent): Default to the upwardly-UI-compatible
+ and more featureful message-mode.
+
+2009-07-14 Chong Yidong <cyd@stupidchicken.com>
+
+ * select.el (x-set-selection): Doc fix.
+ (x-valid-simple-selection-p): Disallow selection data consisting
+ of a list or cons of integers, since that is not used.
+ (xselect--selection-bounds, xselect--int-to-cons): New functions.
+ (xselect-convert-to-string, xselect-convert-to-length)
+ (xselect-convert-to-filename, xselect-convert-to-charpos)
+ (xselect-convert-to-lineno, xselect-convert-to-colno): Use them.
+
+2009-07-14 Dmitry Dzhus <dima@sphinx.net.ru>
+
+ * progmodes/gdb-mi.el (json-partial-output): Fix broken GDB/MI
+ output in -break-info command (Emacs bug #3794).
+
+2009-07-14 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/edebug.el (edebug-setup-hook, edebug-all-forms)
+ (edebug-eval-macro-args, edebug-save-displayed-buffer-points)
+ (edebug-print-length, edebug-print-level, edebug-print-circle)
+ (edebug-sit-for-seconds, edebug-view-outside)
+ (edebug-bounce-point, edebug-set-global-break-condition)
+ (edebug-Go-nonstop-mode, edebug-trace-mode)
+ (edebug-Trace-fast-mode, edebug-continue-mode)
+ (edebug-Continue-fast-mode, edebug-forward-sexp, edebug-help)
+ (edebug-visit-eval-list): Doc fixes.
+
+ * subr.el (def-edebug-spec): Doc fix.
+
+2009-07-14 Kenichi Handa <handa@m17n.org>
+
+ * international/characters.el: Fix setting of category ?C.
+
+2009-07-13 Jan Djärv <jan.h.d@swipnet.se>
+
+ * term/ns-win.el (x-select-font): defalias x-select-font to
+ ns-popup-font-panel instead of generate-fontset-menu.
+
+2009-07-12 Eli Zaretskii <eliz@gnu.org>
+
+ * desktop.el (desktop-buffers-not-to-save): Remove ".log". (Bug#3833)
+
+2009-07-12 Peter Jolly <peter@jollys.org> (tiny change)
+
+ * arc-mode.el (archive-find-type): Allow for a PK00 string before
+ the PK\003\004 header (Bug#3770).
+
+2009-07-12 Guanpeng Xu <herberteuler@hotmail.com>
+
+ * pcomplete.el (pcomplete-comint-setup): Check for
+ shell-dynamic-complete-filename too.
+
+2009-07-11 Chong Yidong <cyd@stupidchicken.com>
+
+ * simple.el (temporary-goal-column): Change the value for
+ line-move-visual to a cons cell.
+ (line-move-visual): Record or set the window hscroll, if
+ necessary (Bug#3494).
+ (line-move-1): Handle cons value of temporary-goal-column.
+
+2009-07-11 Kenichi Handa <handa@m17n.org>
+
+ * international/mule-diag.el (describe-character-set): Don't show
+ width.
+
+2009-07-10 Sam Steingold <sds@gnu.org>
+
+ * progmodes/compile.el (compilation-mode-font-lock-keywords):
+ Omake sometimes indents the errors it prints, so allow all
+ regexps to start with spaces.
+
+2009-07-10 Eli Zaretskii <eliz@gnu.org>
+
+ * cus-edit.el (customize-changed-options-previous-release):
+ Bump value to 22.1. (Bug#3804)
+
+2009-07-08 Sam Steingold <sds@gnu.org>
+
+ * progmodes/grep.el (rgrep): Allow grep-find-ignored-directories
+ to be a cons cell (test . ignored-directory) to selectively ignore
+ some directories depending on the location of the search.
+
+2009-07-08 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-set-file-uid-gid): Handle the case the
+ remote user is root, on the local host.
+ (tramp-local-host-p): Either the local user or the remote user
+ must be root. (Bug#3771)
+
+2009-07-08 Nick Roberts <nickrob@snap.net.nz>
+
+ * progmodes/gdb-mi.el (gdb): Remove description of
+ gdb-use-separate-io-buffer.
+ (menu): Don't allow toggling of or enable
+ gdb-use-separate-io-buffer from menubar.
+
+2009-07-08 E. Jay Berkenbilt <ejb@ql.org> (tiny change)
+
+ * mail/unrmail.el (unrmail): Make sure the message ends with two
+ newlines (Bug#3769).
+
+2009-07-08 Glenn Morris <rgm@gnu.org>
+
+ * calendar/calendar.el (calendar-current-date): Rework previous change.
+
+2009-07-08 Ed Reingold <reingold@emr.cs.iit.edu>
+
+ * calendar/calendar.el (calendar-current-date):
+ Add an optional argument giving an offset from today.
+
+2009-07-08 Glenn Morris <rgm@gnu.org>
+
+ * tutorial.el (tutorial--describe-nonstandard-key):
+ Adjust the message for when a key has been unbound.
+ (help-with-tutorial): Hide the arch-tag.
+
+2009-07-08 Kenichi Handa <handa@m17n.org>
+
+ * international/fontset.el (setup-default-fontset): For each
+ script, append (not set) font-specs.
+
+ * language/japanese.el (japanese-shift-jis-2004): Fix typo in the
+ docstring.
+
+2009-07-08 Nick Roberts <nickrob@snap.net.nz>
+
+ * progmodes/gdb-mi.el (gdb-init-1): Move sending
+ -data-list-register-names to ...
+ (gdb-starting): ... here because GDB 7.0 requires execution to
+ have started when using this MI command.
+ (gdb-set-header): New function to distinguish select and
+ unselected tabs in gdb buffers.
+ (gdb-propertize-header): New macro that uses gdb-set-header.
+ (gdb-breakpoints-header, gdb-locals-header): Use it.
+ (gdb-disassembly-mode-map): Add keybinding to kill buffer.
+
+2009-07-07 Chong Yidong <cyd@stupidchicken.com>
+
+ * Makefile.in (ELCFILES): Remove fadr.elc.
+
+2009-07-07 Dmitry Dzhus <dima@sphinx.net.ru>
+
+ * progmodes/gdb-mi.el (gdb-init-1): Disassembly buffer mode name
+ may contain frame information, so `string-match' should be used.
+ (gdb-update): Disassembly is invalidated through
+ `gdb-get-selected-frame'.
+ (gdb-pad-string): New function to pad string with spaces.
+ (gdb-invalidate-disassembly): Invalidate only if the buffer
+ exists.
+ (gdb-disassembly-handler-custom): Column alignment.
+ (gdb-disassembly-place-breakpoints): Clear old breakpoints before
+ placing new ones.
+ (gdb-toggle-breakpoint, gdb-delete-breakpoint): Now work from the
+ end of line, too.
+ (gdb-frame-handler): Match convention to for disassembly buffer
+ mode name.
+ (gdb-stack-list-frames-handler): Rewritten without regexps.
+ (gdb-breakpoints-list-handler-custom): y/n instead of on/off; do
+ not highlight breakpoints without line information.
+ (gdb-input): Add trailing newline to command.
+
+ * progmodes/gdb-mi.el (gdb-init-1): Set mode name for disassembly
+ buffer properly.
+ (gdb-breakpoints-list-handler-custom): Replacement for
+ `gdb-break-list-handler'. Using real parser instead of regexps
+ now.
+ (gdb-place-breakpoints): Replacement for `gdb-break-list-custom'.
+ Use `gdb-breakpoints-list' instead of parsing breakpoints buffer
+ to place breakpoints.
+ (def-gdb-memory-unit): A new macro to define gdb-memory-unit-..
+ functions.
+ (gdb-disassembly-handler-custom): Show overlay arrow.
+ (gdb-disassembly-place-breakpoints): Show breakpoints in
+ disassembly buffer.
+ (gdb-toggle-breakpoint, gdb-delete-breakpoint)
+ (gdb-goto-breakpoint): Using `gdb-breakpoint' text properties
+ instead of parsing breakpoints buffer. Fixed old menu references
+ in `gud-menu-map'.
+
+ * fadr.el: Remove.
+
+ * progmodes/gdb-mi.el: Port memory buffer from gdb-ui.el.
+ (gdb-memory-address): New variable which holds top address of
+ memory page shown in memory buffer.
+ (gdb-memory-repeat-count, gdb-memory-format, gdb-memory-unit):
+ New customization variables.
+ New functions:
+ (gdb-display-memory-buffer, gdb-frame-memory-buffer): Functions to
+ display the memory buffer.
+ (gdb-memory-set-address, gdb-memory-set-repeat-count): Set memory
+ buffer display parameters.
+ (def-gdb-memory-format, gdb-memory-format-binary)
+ (gdb-memory-format-octal, gdb-memory-format-unsigned)
+ (gdb-memory-format-signed, gdb-memory-format-hexadecimal):
+ Functions for setting memory buffer format.
+ (gdb-memory-unit-word, gdb-memory-unit-halfword)
+ (gdb-memory-unit-giant, gdb-memory-unit-byte): Functions to set
+ unit size used in memory buffer.
+ (gdb-memory-show-next-page, gdb-memory-show-previous-page):
+ Switch to next/previous page of memory buffer.
+ Now using (bindat-get-field) instead of fadr functions.
+
+2009-07-07 Sam Steingold <sds@gnu.org>
+
+ * vc-cvs.el (vc-cvs-merge-news): Fix message parsing for
+ non-top-level files.
+
+2009-07-07 Kenichi Handa <handa@m17n.org>
+
+ * international/mule-cmds.el (reset-language-environment):
+ Put the highset priority to the charset iso-8859-1.
+
+2009-07-06 Chong Yidong <cyd@stupidchicken.com>
+
+ * progmodes/hideshow.el (hs-hide-block-at-point): Don't move point
+ to the end of the line when locating the block (Bug#700).
+
+2009-07-06 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-handle-write-region): Flush file properties
+ in case of short track.
+
+2009-07-06 Michael McNamara <mac@mail.brushroad.com>
+
+ * progmodes/verilog-mode.el (verilog-error-regexp-emacs-alist):
+ Coded custom representation of verilog error regular expressions
+ to work with Emacs-22's new format.
+ (verilog-error-regexp-xemacs-alist): Coded custom representation
+ of verilog error regular expressions to work with XEmacs format.
+ (verilog-error-regexp-add-xemacs): Hook routine to install verilog
+ error recognition into XEmacs.
+ (verilog-error-regexp-add-emacs): Hook routine to install verilog
+ error recognition into Emacs-22.
+
+2009-07-06 Chong Yidong <cyd@stupidchicken.com>
+
+ * woman.el: Remove stand-alone closing parentheses.
+ (woman-file-name, woman2-format-paragraphs)
+ (woman-leave-blank-lines): Code cleanup.
+ (woman-use-own-frame): Change default to nil.
+ (woman-italic, woman-bold, woman-unknown, woman-addition):
+ Change defaults to inherit from default faces.
+ (woman2-process-escapes): Consume the newline after a stand-alone
+ filler character (Bug#3651).
+
+2009-07-06 Glenn Morris <rgm@gnu.org>
+
+ * ffap.el (ffap-version): Make it an obsolete alias for emacs-version.
+ (top-level): Move provide to the end.
+ (ffap): Remove defunct URL from custom group.
+
+ * subr.el (eval-after-load): Doc fix.
+
+2009-07-06 Vincent Belaïche <vincent.belaiche@gmail.com>
+
+ * calc/calc-embed.el (calc-embedded-make-info): Don't force when
+ `calc-embedded-word' is called twice.
+
+2009-07-05 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * files.el (find-alternate-file-other-window, find-alternate-file):
+ Obey confirm-nonexistent-file-or-buffer.
+
+2009-07-05 Michael Albinus <michael.albinus@gmx.de>
+
+ * dired-aux.el (dired-show-file-type): Handle remote files.
+
+2009-07-05 Jari Aalto <jari.aalto@cante.net>
+
+ * desktop.el (desktop-globals-to-save):
+ Add file-name-history (Bug#2750).
+
+2009-07-05 Chong Yidong <cyd@stupidchicken.com>
+
+ * add-log.el (add-log-current-defun-header-regexp): Doc fix (Bug#2217).
+
+2009-07-04 Johan Bockgård <bojohan@gnu.org>
+
+ * eshell/esh-arg.el (eshell-parse-argument-hook): Put `number'
+ property on entire argument since this is what eshell-lisp-command
+ expects.
+
+2009-07-03 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-gvfs.el (tramp-gvfs-methods)
+ (tramp-gvfs-zeroconf-domain)
+ (tramp-bluez-discover-devices-timeout): Add version flag.
+ (tramp-gvfs-handler-mounted-unmounted)
+ (tramp-gvfs-connection-mounted-p): Polish handling of
+ incompatibilities between GVFS 0.2 and 1.0.
+
+2009-07-03 Jan Djärv <jan.h.d@swipnet.se>
+
+ * cus-start.el (all): Add make-pointer-invisible.
+
+2009-07-03 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc-math.el (math-use-emacs-fn): Make sure that the number is
+ formatted correctly.
+
+2009-07-02 Juri Linkov <juri@jurta.org>
+
+ * info.el: Virtual Info files and nodes.
+ (Info-virtual-files, Info-virtual-nodes): New variables.
+ (Info-current-node-virtual): New variable.
+ (Info-virtual-file-p, Info-virtual-fun, Info-virtual-call):
+ New functions.
+ (Info-file-supports-index-cookies): Use Info-virtual-file-p
+ to check for a virtual file instead of checking a fixed list
+ of node names.
+ (Info-find-file): Use Info-virtual-fun and Info-virtual-call
+ instead of ad-hoc processing of "dir" and (apropos history toc).
+ (Info-find-node-2): Use Info-virtual-fun and Info-virtual-call
+ instead of ad-hoc processing of "dir" and (apropos history toc).
+ Reread a file when moving from a virtual node.
+ (add-to-list)<Info-virtual-files>: Add "\\`dir\\'".
+ (Info-directory-toc-nodes, Info-directory-find-file)
+ (Info-directory-find-node): New functions.
+ (add-to-list)<Info-virtual-files>: Add "\\`\\*History\\*\\'".
+ (Info-history): Move part of code to
+ `Info-history-find-node'.
+ (Info-history-toc-nodes, Info-history-find-file)
+ (Info-history-find-node): New functions.
+ (add-to-list)<Info-virtual-nodes>: Add "\\`\\*TOC\\*\\'".
+ (Info-toc): Move part of code to `Info-toc-find-node'.
+ (Info-toc-find-node): New function.
+ (Info-toc-insert): Rename from `Info-insert-toc'. Don't insert
+ the current Info file name to references because now the node
+ "*TOC*" belongs to the same Info manual.
+ (Info-toc-build): Rename from `Info-build-toc'.
+ (Info-toc-nodes): Rename input argument `file' to `filename'.
+ Use Info-virtual-fun, Info-virtual-call and Info-virtual-file-p
+ instead of ad-hoc processing of ("dir" apropos history toc).
+ (Info-index-nodes): Use Info-virtual-file-p
+ to check for a virtual file instead of checking a fixed list
+ of node names.
+ (Info-index-node): Add check for `Info-current-node-virtual'.
+ Raise `save-match-data' higher up the tree to contain
+ `search-forward' too (bug fix).
+ (add-to-list)<Info-virtual-nodes>: Add "\\`\\*Index.*\\*\\'".
+ (Info-virtual-index-nodes): New variable.
+ (Info-virtual-index-find-node, Info-virtual-index): New functions.
+ (add-to-list)<Info-virtual-files>: Add "\\`\\*Apropos\\*\\'".
+ (Info-apropos-file, Info-apropos-nodes): New variables.
+ (Info-apropos-toc-nodes, Info-apropos-find-file)
+ (Info-apropos-find-node, Info-apropos-matches): New functions.
+ (info-apropos): Move part of code to `Info-apropos-find-node' and
+ `Info-apropos-matches'.
+ (Info-mode-map): Bind "I" to `Info-virtual-index'.
+ (Info-desktop-buffer-misc-data): Use Info-virtual-file-p to check
+ for a virtual file instead of checking a fixed list of node names.
+
+ * simple.el (async-shell-command): New command.
+
+ * bindings.el (esc-map): Bind "&" to `async-shell-command'.
+
+ * net/tramp-gvfs.el (tramp-gvfs-connection-mounted-p): Use `elt'
+ instead of `mount-info'.
+
+2009-07-02 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-gvfs.el (tramp-gvfs-handler-mounted-unmounted)
+ (tramp-gvfs-connection-mounted-p): Handle changed mount-info interface.
+
+2009-07-02 Kenichi Handa <handa@m17n.org>
+
+ * international/mule.el (set-keyboard-coding-system): Force *-unix
+ coding-system to avoid eol conversion.
+
+2009-07-01 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-gvfs.el (tramp-gvfs-file-name-handler-alist):
+ Add handler for `process-file', `shell-command' and
+ `start-file-process'.
+ (tramp-gvfs-handle-shell-command)
+ (tramp-gvfs-handle-start-file-process)
+ (tramp-gvfs-handle-process-file): New defuns.
+ (tramp-synce-list-devices): Simplify check for existence of property.
+
+2009-07-01 Jan Djärv <jan.h.d@swipnet.se>
+
+ * startup.el (command-line-x-option-alist): Add -mm and --maximized.
+
+2009-07-01 Eduard Wiebe <usenet@pusto.de> (tiny change)
+
+ * language/korean.el (set-language-info-alist): Add korean-cp949,
+ cp949 to spec.
+
+2009-07-01 Kenichi Handa <handa@m17n.org>
+
+ * Makefile.in (ELCFILES): Delete encoded-kb.elc.
+
+ * international/encoded-kb.el: Deleted.
+
+ * international/mule.el (set-keyboard-coding-system): Perform the
+ necessary setup here instead of calling encoded-kbd-setup-display.
+
+2009-07-01 Glenn Morris <rgm@gnu.org>
+
+ * progmodes/f90.el (f90-break-delimiters, f90-no-break-re): Doc fixes.
+
+2009-07-01 Evangelos Evangelou <vangelis@email.unc.edu> (tiny change)
+
+ * progmodes/f90.el (f90-no-break-re): Add "(/" and "/)". (Bug#3730)
+
+2009-06-30 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-do-copy-or-rename-file-directly):
+ Handle also the 'rename case, when setting file modes. (Bug#3712)
+ (tramp-default-file-modes): Remove execute permissions.
+
+ * net/tramp-gvfs.el (tramp-gvfs-methods): Add "synce" method.
+ (top): Add a default for "synce" in `tramp-default-user-alist'.
+ Add completion function for "synce" method.
+ (tramp-hal-service, tramp-hal-path-manager)
+ (tramp-hal-interface-manager, tramp-hal-interface-device):
+ New defconst.
+ (tramp-gvfs-connection-mounted-p): Handle empty user name for synce.
+ (tramp-synce-list-devices, tramp-synce-parse-device-names):
+ New defuns.
+
+ * net/trampver.el: Update release number.
+
+2009-06-30 Kenichi Handa <handa@m17n.org>
+
+ * international/fontset.el (setup-default-fontset): Add CJK fonts
+ for symbols and the other miscellaneous characters.
+
+ * language/korea-util.el (setup-korean-environment-internal):
+ Make char-width-table suitable for Korean environments.
+ (exit-korean-environment): Cancel above.
+
+ * language/chinese.el ("Chinese-GB", "Chinese-BIG5")
+ ("Chinese-CNS", "Chinese-EUC-TW", "Chinese-GBK"): Add a
+ setup-function to make char-width-table suitable for respective
+ environments, and an exit-function to cancel that.
+
+ * language/japan-util.el (setup-japanese-environment-internal):
+ Call use-cjk-char-width-table with arg `ja_JP'.
+
+ * international/characters.el (cjk-char-width-table): Delete it.
+ (cjk-char-width-table-list): New variable.
+ (use-cjk-char-width-table): New arg local-name.
+ (use-default-char-width-table): Fix for the case that Emacs is
+ already using the default char-width-table.
+
+2009-06-29 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-do-copy-or-rename-file-directly): Set file
+ modes mandatory. (Bug#3712)
+
+2009-06-29 Alan Mackenzie <acm@muc.de>
+
+ * progmodes/cc-cmds.el (c-mask-paragraph): Remove a spurious
+ correction between the visible width of TABs and their number of bytes.
+
+2009-06-29 Chong Yidong <cyd@stupidchicken.com>
+
+ * server.el (server-buffer-done): Prevent kill-buffer from
+ prompting by clearing the buffer modification flag (Bug#3696).
+
+2009-06-28 Michael McNamara <mac@mail.brushroad.com>
+
+ * progmodes/verilog-mode.el (verilog-beg-of-statement)
+ (verilog-endcomment-reason-re): Support unique case and priority case.
+ (verilog-basic-complete-re): Support localparam lineup.
+ (verilog-beg-of-statement-1): Fix for robustness, unique case.
+ (verilog-set-auto-endcomments): Fix for unique case, always_comb
+ commenting.
+ (verilog-leap-to-case-head): Now support *nested* unique &
+ priority case statements.
+ (verilog-auto-lineup): Make just declarations the default (as it
+ had been).
+ (verilog-leap-to-case-head): Support priority/unique case statements.
+ (verilog-auto-lineup): Rework to give users radio buttons to
+ select the various styles of automatic lineup.
+ (verilog-error-regexp-alist): Rework to support the XEmacs style
+ of error regular expressions from compilers, lint tools &
+ simulators. Note that GNU Emacs has made it impossible for a mode
+ to load such things.
+ (electric-verilog-terminate-line, verilog-indent-declaration)
+ (verilog-auto-wiure): Rework for radio button selection of
+ auto-lineup selection of specification of auto lineup.
+ (verilog-beg-of-statement-1): Redesign to support proper operation
+ in additional code, based on testing with auto-lineup.
+ (verilog-calculate-indent, assignments & declarations)
+ (verilog-backward-token): Enhance to support auto-lineup of
+ assignments & declarations.
+ (verilog-in-directive-p, verilog-at-struct-p): New function for
+ easy test of whether we are.
+ (verilog-pretty-declarations, verilog-pretty-expr): Massive rework
+ to support safe execution at almost anyline.
+ (verilog-calc-1): Properly support indenting deep inside generate
+ blocks.
+ (verilog-init-font): Remove definition & use of verilog-init-font,
+ as it is redundant with font-lock-defaults.
+ (verilog-mode): Alter the definition of verilog-font-lock-defaults
+ to avoid circular calls if syntax-ppss is a function (as is the
+ case now in 22.x GNU Emacs) as that function would sometimes call
+ itself, leading to (nearly) infinite recursion.
+ (verilog-ovm-begin-re, verilog-ovm-end-re)
+ (verilog-ovm-statement-re, verilog-leap-to-head)
+ (verilog-backward-token): Add support for OVM macros. Some are
+ complete statements, and others open and close scopes like begin
+ and end.
+ (verilog-defun-level-not-generate-re, verilog-defun-level-re)
+ (verilog-defun-level-generate-only-re): Really fix the defun-list
+ compilation issue.
+ (verilog-calc-1, verilog-beg-of-statement): Enhance support for
+ coverpoint, constraint and cross statements.
+ (verilog-defun-level-list, verilog-generate-defun-level-list)
+ (verilog-all-defun-level-list): Redo these specifications - it is
+ too hard to support eval-when compile aggregation of lists also
+ built at when-compile time.
+ (verilog-defun-level-list): Place defconsts of variables used in
+ building regular expressions which are built in eval-when-compile
+ bodies in the same eval-when-compile body to facilitate compile
+ without load.
+ (verilog-beg-block-re-ordered): Support indenting
+ virtual/protected tasks and functions.
+ (verilog-defun-level-list, verilog-in-generate-region-p)
+ (verilog-backward-ws&directives, verilog-calc-1): Speed up
+ indentation of some module items (generate items).
+ (verilog-forward-sexp, verilog-leap-to-head): Support stepping
+ across virtual/protected tasks and functions.
+
+2009-06-28 Wilson Snyder <wsnyder@wsnyder.org>
+
+ * progmodes/verilog-mode.el (verilog-auto-arg, verilog-auto-arg-sort):
+ Allow sorting AUTOARG lists. Suggested by Andrea Fedeli.
+ (verilog-read-sub-decls-line): Fix AUTOWIRE signals getting lost
+ in concatenations. Reported by Yishay Belkind.
+ (verilog-auto-ascii-enum): Support one-hot state machines in
+ AUTOASCIIENUM. Suggested by Lloyd Gomez.
+ (verilog-auto-inst, verilog-auto-inst-port): Include interface
+ modport in AUTOINST and add vl-modport for users.
+ Reported by David Rogoff.
+ (verilog-auto-inout-module, verilog-auto-inst)
+ (verilog-decls-get-interfaces, verilog-insert-definition)
+ (verilog-insert-one-definition, verilog-read-decls)
+ (verilog-read-sub-decls, verilog-read-sub-decls-sig)
+ (verilog-sig-modport, verilog-signals-combine-bus)
+ (verilog-subdecls-get-interfaces): Fix expansion of SystemVerilog
+ interfaces in AUTOINOUTMODULE, AUTOINOUTCOMP, and AUTOINST.
+ Suggested by David Rogoff.
+ (verilog-repair-open-comma): Fix non-insertion of comma when
+ `DEFINE occurs in V2K argument list. Reported by Lane Brooks.
+ (verilog-make-width-expression): Simplify [A-1:0] expression
+ widths to just {A{1'b0}}.
+ (verilog-mode): Cleanup checkdoc warnings.
+ (verilog-auto-inout-module, verilog-signals-matching-dir-re):
+ Add third optional regexp to AUTOINOUTMODULE to allow selecting only
+ inputs/outputs or data type. Suggested by Vasu Kandadi.
+ (next-error-last-buffer): Fix byte-compiler warning.
+ (verilog-auto, verilog-auto-insert-lisp, verilog-auto-inst)
+ (verilog-delete-auto): Add AUTOINSERTLISP to insert arbitrary lisp
+ or shell command text during AUTO expansion. Suggested by Tad Truex.
+ (verilog-read-sub-decls-expr, verilog-read-sub-decls-line)
+ (verilog-read-sub-decls-sig, verilog-symbol-detick-text):
+ Fix dotted nets {a.b,c.d} and escaped identifiers being mis-included
+ in AUTOINOUT. Reported by Matthew Lovell.
+ (verilog-read-always-signals-recurse): Fix AUTORESET "if (a<=b)"
+ causing use of <= assignments. Reported by Alex Reed.
+ (verilog-read-decls): Fix triand, trior, wand, wor to be
+ recognized by AUTOWIRE. Reported by Spencer Isaacson.
+ (verilog-extended-complete-re): Support import "DPI-C" functions.
+ (verilog-read-always-signals-recurse): Fix AUTORESET of "x <=
+ y[a+1:a+1]" to not include a in reset list. Reported by Dan Dever.
+ (verilog-insert-date, verilog-insert-year)
+ (verilog-sk-header-tmpl): Fix verilog-header inserting error on
+ Windows systems. Reported by Michael Potts.
+ (verilog-read-module-name): Fix AUTOINST when the child module
+ declaration's name is a tick define. Reported by Elliot Mednick.
+ (verilog-read-decls): Fix V2K parameter bit subscripts getting
+ passed to next parameter's definition. Reported by Bruce T.
+ (verilog-read-decls): Fix detecting "parameter int" when using
+ AUTOINSTPARAM. Reported by Bruce T.
+ (verilog-goto-defun): Fix goto not finding modules unless first
+ perform a verilog-auto expansion. Suggested by Lawrence Butcher.
+ (verilog-mode): Expand -f flag arguments on entry to mode so
+ verilog-goto-defun will work. Reported by Lawrence Butcher.
+ (verilog-getopt): Expand environment variables in -f file
+ arguments. Suggested by Lawrence Butcher.
+ (verilog-set-define): Fix "Symbol's value as variable is void"
+ when reading enumerations.
+ (verilog-auto-ascii-enum): Fix duplicate labels in AUTOASCIIENUM.
+ Suggested by Stephen Peltan.
+ (verilog-read-defines): Fix reading of enumerations in include
+ files. Reported by Steve Peltan.
+
+2009-06-28 David De La Harpe Golden <david@harpegolden.net>
+
+ * files.el (trash-directory): Fix defcustom type.
+
+2009-06-28 Juri Linkov <juri@jurta.org>
+
+ * help-fns.el (describe-function-1): Correctly locate adviced
+ functions in hyperlink (Bug#2438).
+
+2009-06-28 Chong Yidong <cyd@stupidchicken.com>
+
+ * files.el (trash-directory): Change default to nil.
+ (move-file-to-trash): If trash-directory is nil and
+ system-move-file-to-trash is unbound, perform freedesktop-style
+ trashing.
+
+2009-06-28 David De La Harpe Golden <david@harpegolden.net>
+
+ * files.el (move-file-to-trash): Add freedesktop trash
+ support (Bug#973).
+
+2009-06-28 Glenn Morris <rgm@gnu.org>
+
+ * autorevert.el (global-auto-revert-non-file-buffers)
+ (global-auto-revert-mode): Doc fixes.
+
+2009-06-27 Johan Bockgård <bojohan@gnu.org>
+
+ * emacs-lisp/cl-specs.el (defstruct): Fix :conc-name spec.
+
+2009-06-27 Chong Yidong <cyd@stupidchicken.com>
+
+ * faces.el (x-handle-named-frame-geometry): Ensure that we have
+ opened an X connection before calling x-get-resource (Bug#3194).
+
+ * play/doctor.el: Remove reference to obsolete website.
+ (make-doctor-variables): Correct grammar mistake (Bug#2633).
+
+2009-06-26 Dan Nicolaescu <dann@ics.uci.edu>
+
+ Remove find-file-not-found-hook VC method. (Bug#2757)
+ * vc-hooks.el (vc-file-not-found-hook)
+ (vc-default-find-file-not-found-hook): Remove functions.
+ (find-file-not-found-functions): Do not add vc-file-not-found-hook.
+ * vc-rcs.el (vc-rcs-find-file-not-found-hook): Remove function.
+ * vc.el:
+ * vc-hg.el:
+ * vc-git.el: Do not mention find-file-not-found-hook VC method.
+
+2009-06-25 Agustín Martín <agustin.martin@hispalinux.es>
+
+ * textmodes/ispell.el: Add `ispell-looking-back' XEmacs
+ compatibility function for `looking-back'.
+
+ * textmodes/flyspell.el (sgml-mode-flyspell-verify):
+ Use `ispell-looking-back'.
+
+2009-06-24 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-gvfs.el (tramp-gvfs-handle-make-directory): Use `dir'
+ rather than `filename'.
+
+2009-06-23 Miles Bader <miles@gnu.org>
+
+ * face-remap.el (text-scale-set): New function.
+
+2009-06-23 Glenn Morris <rgm@gnu.org>
+
+ * pcmpl-rpm.el (pcomplete/rpm): Doc fix.
+
+ * bindings.el (mode-line-modified): Fix case of "Buffer is modified".
+
+ * textmodes/ispell.el (ispell-local-dictionary): Doc fix.
+
+ * progmodes/gdb-mi.el (gud-remove, gud-break): Update declarations.
+
+ * calendar/cal-dst.el (calendar-time-zone-daylight-rules):
+ Simplify Persian conditionals.
+
+ * calc/calc-graph.el (calc-graph-plot): Avoid assignment to free
+ variable `filename'.
+
+ * comint.el (comint-insert-input): Doc fix.
+
+ * Makefile.in (ELCFILES): Fix typo in previous change.
+
+2009-06-23 Miles Bader <miles@gnu.org>
+
+ * cus-start.el: Add entry for `recenter-redisplay'.
+
+2009-06-23 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-hooks.el (vc-stay-local-p, vc-state, vc-working-revision):
+ Add an optional argument for the backend, use it instead of
+ calling vc-backend.
+ (vc-mode-line): Add an optional argument for the backend.
+ Pass the backend to vc-state and vc-working-revision. Move code for
+ special handling for vc-state being a buffer to ...
+
+ * vc-rcs.el (vc-rcs-find-file-hook):
+ * vc-sccs.el (vc-sccs-find-file-hook): ... here. New functions.
+
+ * vc-svn.el (vc-svn-state, vc-svn-dir-status, vc-svn-checkout)
+ (vc-svn-print-log, vc-svn-diff): Pass 'SVN to vc-state,
+ vc-stay-local-p and vc-mode-line calls.
+
+ * vc-cvs.el (vc-cvs-state, vc-cvs-checkout, vc-cvs-print-log)
+ (vc-cvs-diff, vc-cvs-annotate-command)
+ (vc-cvs-make-version-backups-p, vc-cvs-stay-local-p)
+ (vc-cvs-dir-status): Pass 'CVS to vc-state, vc-stay-local-p and
+ vc-mode-line calls.
+
+ * vc.el (vc-deduce-fileset): Use vc-deduce-fileset instead of
+ direct comparison.
+ (vc-next-action, vc-transfer-file, vc-rename-file): Also pass the
+ backend when calling vc-mode-line.
+ (vc-register): Do not create a closure for calling the vc register
+ function, call it directly.
+
+2009-06-23 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * emacs-lisp/elp.el (elp-output-insert-symname): Add a link face
+ to make it obvious item can be clicked.
+
+ * vc-mtn.el (vc-mtn-after-dir-status, vc-mtn-dir-status): New functions.
+
+2009-06-23 Kenichi Handa <handa@m17n.org>
+
+ * language/korea-util.el (korean-key-bindings): Change the binding
+ of F9 to hangul-to-hanja-conversion. Bind Hangul_Hanja to the
+ same command.
+
+2009-06-22 Michael Albinus <michael.albinus@gmx.de>
+
+ Sync with Tramp 2.1.16.
+
+ * Makefile.in (ELCFILES): Add net/tramp-gvfs.elc.
+
+ * net/tramp.el (top): Require tramp-gvfs. Catch `tramp-loading',
+ when a loading of a package fails. Completion function for rsync
+ is `tramp-completion-function-alist-ssh'.
+ (all): Replace all calls of `split-string' and
+ `tramp-split-string' by `tramp-compat-split-string'.
+ (tramp-default-method): Use `tramp-compat-process-running-p'.
+ (tramp-default-proxies-alist): Allow also Lisp forms.
+ (tramp-remote-path): Add choice "Private Directories".
+ (tramp-wrong-passwd-regexp): Remove "Tramp connection closed" option.
+ (tramp-domain-regexp): Allow also "-", "_" and ".".
+ (tramp-end-of-output): Remove newlines, and add "$" at the end.
+ (tramp-file-name-handler-alist): Add handler for `dired-uncache'.
+ (tramp-debug-message): Insert header line in debug buffer.
+ (tramp-handle-directory-files-and-attributes-with-stat):
+ Care about filenames with spaces, or starting with "-".
+ (tramp-handle-dired-uncache): New defun.
+ (tramp-handle-insert-directory): Don't flush the directory from
+ cache, this is handled by `dired-uncache' now.
+ (tramp-handle-insert-file-contents): Improve error handling.
+ (tramp-find-shell, tramp-open-connection-setup-interactive-shell):
+ Quote `tramp-end-of-output'.
+ (tramp-action-password): Improve trace message.
+ (tramp-check-for-regexp): Both echoes must be present, before removing.
+ (tramp-open-connection-setup-interactive-shell): Trace coding system.
+ (tramp-compute-multi-hops): Eval cons cells of
+ `tramp-default-proxies-alist'.
+ (tramp-maybe-open-connection): Use the same command pattern for
+ first hop and further hops.
+ (tramp-wait-for-output): Remove handling of newlines.
+ (tramp-get-remote-path): Handle also `tramp-own-remote-path'.
+ (tramp-split-string): Remove function. It is handled in
+ tramp-compat now.
+
+ * net/tramp-cmds.el (tramp-bug):
+ Recommend `tramp-cleanup-all-connections' in the bug mail.
+
+ * net/tramp-compat.el (tramp-compat-split-string)
+ (tramp-compat-process-running-p): New defuns.
+
+ * net/tramp-fish.el (tramp-fish-file-name-handler-alist): Add handler
+ for `dired-uncache'.
+
+ * net/tramp-gvfs.el: New package.
+
+ * net/tramp-smb.el (tramp-smb-file-name-handler-alist):
+ Add handler for `dired-uncache'.
+ (tramp-smb-handle-file-local-copy): Cleanup in case of error.
+
+ * net/trampver.el: Update release number. Make version check fit
+ for SXEmacs 22.
+
+2009-06-22 Jim Meyering <meyering@redhat.com>
+
+ Automatically handle .xz suffix (XZ-compressed files), too.
+ * jka-cmpr-hook.el (jka-compr-compression-info-list): Add xz.
+ 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>
+
+ * progmodes/gdb-mi.el: Pull further modified changes from Dmitry's
+ repository (http://sphinx.net.ru/hg/gdb-mi/).
+
+2009-06-22 Glenn Morris <rgm@gnu.org>
+
+ * files.el (dir-locals-collect-mode-variables): Allow for any number of
+ `mode' and `eval' entries. (Bug#3430)
+
+ * Makefile.in (ELCFILES): Add fadr.elc.
+
+ * calendar/appt.el (appt-make-list): Fix off-by-one error caused by
+ differing behavior of \n and ^ in strings. (Bug#3385)
+
+ * emacs-lisp/cl-indent.el: Remove leading "*" from defcustom docs.
+
+ * emacs-lisp/lisp-mode.el (lisp-indent-offset): Fix safe-local-variable
+ property.
+ (lisp-indent-function): Make it a defcustom.
+
+2009-06-21 Nick Roberts <nickrob@snap.net.nz>
+
+ * progmodes/gdb-ui.el: Replace with ...
+ * progmodes/gdb-mi.el: ... this file.
+ * progmodes/gud.el: Modify for gdb-mi.el.
+
+2009-06-21 Dmitry Dzhus <dima@sphinx.net.ru>
+
+ * fadr.el: New file.
+
+See ChangeLog.14 for earlier changes.
+
+;; Local Variables:
+;; coding: utf-8
+;; End:
+
+ Copyright (C) 2009-2011 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/>.
diff --git a/lisp/ChangeLog.2 b/lisp/ChangeLog.2
index 1686f599fb1..36046562653 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.
@@ -3992,8 +3992,7 @@
See ChangeLog.1 for earlier changes.
- Copyright (C) 1986, 1987, 1988, 2001, 2002, 2003, 2004, 2005, 2006,
- 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 1986-1988, 2001-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -4010,4 +4009,3 @@ See ChangeLog.1 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: c315ba16-14ba-4b07-86e6-013a18f11be7
diff --git a/lisp/ChangeLog.3 b/lisp/ChangeLog.3
index b26a048ac56..8cafac2c0c4 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.
@@ -12438,8 +12438,7 @@ See ChangeLog.2 for earlier changes.
;; coding: utf-8
;; End:
- Copyright (C) 1989, 1993, 2001, 2002, 2003, 2004, 2005, 2006,
- 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 1989, 1993, 2001-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -12456,4 +12455,3 @@ See ChangeLog.2 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: f07a3446-5672-464a-8fdc-2ca92e8e7b2a
diff --git a/lisp/ChangeLog.4 b/lisp/ChangeLog.4
index f0e9ea6a608..f9407ce20d8 100644
--- a/lisp/ChangeLog.4
+++ b/lisp/ChangeLog.4
@@ -8936,8 +8936,7 @@ See ChangeLog.3 for earlier changes.
;; coding: utf-8
;; End:
- Copyright (C) 1993, 1994, 2001, 2002, 2003, 2004, 2005, 2006,
- 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 1993-1994, 2001-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -8954,4 +8953,3 @@ See ChangeLog.3 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: 91035822-35c7-44a9-8417-2454b88c3db2
diff --git a/lisp/ChangeLog.5 b/lisp/ChangeLog.5
index ae8a6c096d7..1edf6d692a0 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.
@@ -5484,12 +5484,12 @@
1994-10-27 Francesco Potortì (pot@cnuce.cnr.it)
* man.el (Man-fontify-manpage-flag): defvar put at outer level.
- (manual-program, Man-untabify-command, Man-untabify-command-args,
- Man-sed-command, Man-awk-command, Man-mode-line-format,
- Man-mode-map, Man-mode-hook, Man-cooked-hook, Man-name-regexp,
- Man-section-regexp, Man-page-header-regexp, Man-heading-regexp,
- Man-see-also-regexp, Man-first-heading-regexp,
- Man-reference-regexp, Man-switches, Man-specified-section-option):
+ (manual-program, Man-untabify-command, Man-untabify-command-args)
+ (Man-sed-command, Man-awk-command, Man-mode-line-format)
+ (Man-mode-map, Man-mode-hook, Man-cooked-hook, Man-name-regexp)
+ (Man-section-regexp, Man-page-header-regexp, Man-heading-regexp)
+ (Man-see-also-regexp, Man-first-heading-regexp)
+ (Man-reference-regexp, Man-switches, Man-specified-section-option):
Make them normal defvars, no more user options.
(Man-overstrike-face, Man-underline-face): New user options.
(Man-init-defvars): Man-fontify-manpage-flag removed from here.
@@ -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
@@ -6228,10 +6228,10 @@
1994-10-05 Francesco Potortì (pot@cnuce.cnr.it)
- * man.el (Man-notify, Man-current-page, Man-page-list,
- Man-filter-list, Man-original-frame, Man-arguments,
- Man-fontify-manpage-flag, Man-sections-alist, Man-refpages-alist,
- Man-uses-untabify-flag, Man-page-mode-string, Man-sed-script):
+ * man.el (Man-notify, Man-current-page, Man-page-list)
+ (Man-filter-list, Man-original-frame, Man-arguments)
+ (Man-fontify-manpage-flag, Man-sections-alist, Man-refpages-alist)
+ (Man-uses-untabify-flag, Man-page-mode-string, Man-sed-script):
Added defvar's to keep the compiler quiet.
(Man-getpage-in-background): Start buffer name with "*Man ".
instead of "*man " to avoid conflict with "*mail*".
@@ -6425,8 +6425,7 @@
1994-09-29 Francesco Potortì (pot@cnuce.cnr.it)
- * man.el
- (Man-init-defvars, Man-cleanup-manpage, Man-fontify-manpage):
+ * man.el (Man-init-defvars, Man-cleanup-manpage, Man-fontify-manpage):
added support for the big cross present in the ksh manpage.
1994-09-29 Richard Stallman <rms@mole.gnu.ai.mit.edu>
@@ -6534,7 +6533,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 +6541,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
@@ -6884,8 +6883,8 @@
(Man-bgproc-sentinel): Cleanup, call Man-fontify-manpage and
Man-cleanup-page when necessary.
(Man-mode): Call Man-strip-page-headers and Man-unindent.
- (Man-build-section-alist, Man-build-references-alist,
- Man-build-page-list): substs instead of functions.
+ (Man-build-section-alist, Man-build-references-alist)
+ (Man-build-page-list): substs instead of functions.
(Man-build-references-alist): Cleanup.
(Man-build-page-list): New algorithm.
(Man-strip-page-headers, Man-unindent): New substs.
@@ -7051,7 +7050,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 +8049,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 +8794,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 +9193,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.
@@ -9265,8 +9264,7 @@ See ChangeLog.4 for earlier changes.
;; coding: utf-8
;; End:
- Copyright (C) 1994, 1995, 2001, 2002, 2003, 2004, 2005, 2006,
- 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 1994-1995, 2001-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -9283,4 +9281,3 @@ See ChangeLog.4 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: 1a8fbb45-25d0-48e2-a926-29ca4e3d343a
diff --git a/lisp/ChangeLog.6 b/lisp/ChangeLog.6
index e8fe7643616..2f73c290231 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>
@@ -8022,8 +8022,7 @@ See ChangeLog.5 for earlier changes.
;; coding: utf-8
;; End:
- Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004, 2005, 2006,
- 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 1995-1996, 2001-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -8040,4 +8039,3 @@ See ChangeLog.5 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: f90e8ffe-6bd0-4423-97d9-637ac4382520
diff --git a/lisp/ChangeLog.7 b/lisp/ChangeLog.7
index ec2ffb908b9..7ef7fe9dffc 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.
@@ -23107,8 +23107,7 @@ See ChangeLog.6 for earlier changes.
;; coding: utf-8
;; End:
- Copyright (C) 1997, 1998, 2001, 2002, 2003, 2004, 2005, 2006,
- 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 1997-1998, 2001-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -23125,4 +23124,3 @@ See ChangeLog.6 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: 0995d517-13da-45ab-9c2d-7911aa25512b
diff --git a/lisp/ChangeLog.8 b/lisp/ChangeLog.8
index e8df692afdc..ada6d98ce3d 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
@@ -9993,8 +9993,7 @@ See ChangeLog.7 for earlier changes.
;; add-log-time-zone-rule: t
;; End:
- Copyright (C) 1999, 2001, 2002, 2003, 2004, 2005, 2006,
- 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 1999, 2001-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -10011,4 +10010,3 @@ See ChangeLog.7 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: efdc1531-ed46-4e14-be59-bee4b23088f3
diff --git a/lisp/ChangeLog.9 b/lisp/ChangeLog.9
index bb5ee391683..14214ccc3d3 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>
@@ -20693,8 +20693,7 @@ See ChangeLog.8 for earlier changes.
;; coding: utf-8
;; End:
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006,
- 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 2000-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -20711,4 +20710,3 @@ See ChangeLog.8 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: a7cd2b86-43eb-409b-883f-3700fa85334f
diff --git a/lisp/Makefile.in b/lisp/Makefile.in
index 9abdb4133e0..d4ff6a4384b 100644
--- a/lisp/Makefile.in
+++ b/lisp/Makefile.in
@@ -1,6 +1,5 @@
# Maintenance productions for the Lisp directory
-# Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-# 2009, 2010, 2011 Free Software Foundation, Inc.
+# Copyright (C) 2000-2011 Free Software Foundation, Inc.
# This file is part of GNU Emacs.
@@ -19,19 +18,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 --no-site-lisp
# Extra flags to pass to the byte compiler
BYTE_COMPILE_EXTRA_FLAGS =
@@ -52,7 +55,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 \
@@ -66,12 +70,35 @@ AUTOGENEL = loaddefs.el \
cedet/ede/loaddefs.el \
cedet/srecode/loaddefs.el
+# Versioned files that are the value of someone's `generated-autoload-file'.
+# Note that update_loaddefs parses this.
+AUTOGEN_VCS = \
+ ps-print.el \
+ emulation/tpu-edt.el \
+ emacs-lisp/cl-loaddefs.el \
+ mail/rmail.el \
+ dired.el \
+ ibuffer.el \
+ htmlfontify.el \
+ emacs-lisp/eieio.el
+
+# Value of max-lisp-eval-depth when compiling initially.
+# During bootstrapping the byte-compiler is run interpreted when compiling
+# itself, and uses more stack than usual.
+#
+BIG_STACK_DEPTH = 1200
+BIG_STACK_OPTS = --eval "(setq max-lisp-eval-depth $(BIG_STACK_DEPTH))"
+
+BYTE_COMPILE_FLAGS = $(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS)
+
# Files to compile before others during a bootstrap. This is done to
# speed up the bootstrap process.
COMPILE_FIRST = \
$(lisp)/emacs-lisp/bytecomp.elc \
$(lisp)/emacs-lisp/byte-opt.elc \
+ $(lisp)/emacs-lisp/macroexp.elc \
+ $(lisp)/emacs-lisp/cconv.elc \
$(lisp)/emacs-lisp/autoload.elc
# The actual Emacs command run in the targets below.
@@ -79,29 +106,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 +134,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,24 +154,21 @@ 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
-# The chmod +w is to handle env var CVSREAD=1. Files named
-# are identified by being the value of `generated-autoload-file'.
+# The chmod +w is to handle env var CVSREAD=1.
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); \
+ cd $(lisp) && chmod +w $(AUTOGEN_VCS)
+ 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 +177,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 +193,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
@@ -1478,7 +214,9 @@ compile-onefile:
@echo Compiling $(THEFILE)
@# Use byte-compile-refresh-preloaded to try and work around some of
@# the most common bootstrapping problems.
- @$(emacs) -l bytecomp -f byte-compile-refresh-preloaded $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $(THEFILE)
+ @$(emacs) $(BYTE_COMPILE_FLAGS) \
+ -l bytecomp -f byte-compile-refresh-preloaded \
+ -f batch-byte-compile $(THEFILE)
# Files MUST be compiled one by one. If we compile several files in a
# row (i.e., in the same instance of Emacs) we can't make sure that
@@ -1491,17 +229,57 @@ 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 $<
+ @# The BIG_STACK_OPTS are only needed to byte-compile the byte-compiler
+ @# files, which is normally done in compile-first, but may also be
+ @# recompiled via this rule.
+ @$(emacs) $(BYTE_COMPILE_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 +289,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,24 +297,10 @@ 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; \
- $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $$el || exit 1; \
+ $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $$el || exit 1;\
done
# Backup compiled Lisp files in elc.tar.gz. If that file already
@@ -1556,8 +316,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.
@@ -1568,7 +327,8 @@ compile-after-backup: backup-compiled-files compile-always
# since the environment of later files is affected by definitions in
# earlier ones.
recompile: doit $(LOADDEFS) compile-first $(lisp)/progmodes/cc-mode.elc
- $(emacs) --eval "(batch-byte-recompile-directory 0)" $(lisp)
+ $(emacs) $(BYTE_COMPILE_FLAGS) \
+ --eval "(batch-byte-recompile-directory 0)" $(lisp)
# Update MH-E internal autoloads. These are not to be confused with
# the autoloads for the MH-E entry points, which are already in loaddefs.el.
@@ -1596,6 +356,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 tramp*.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-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 4ce4d82c7c2..b2cd2064da2 100644
--- a/lisp/abbrev.el
+++ b/lisp/abbrev.el
@@ -1,10 +1,10 @@
-;;; abbrev.el --- abbrev mode commands for Emacs
+;;; abbrev.el --- abbrev mode commands for Emacs -*- lexical-binding: t -*-
-;; Copyright (C) 1985, 1986, 1987, 1992, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1987, 1992, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: abbrev convenience
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -56,24 +56,17 @@ 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)
(defvar edit-abbrevs-map
(let ((map (make-sparse-keymap)))
- (define-key map "\C-x\C-s" 'edit-abbrevs-redefine)
+ (define-key map "\C-x\C-s" 'abbrev-edit-save-buffer)
+ (define-key map "\C-x\C-w" 'abbrev-edit-save-to-file)
(define-key map "\C-c\C-c" 'edit-abbrevs-redefine)
map)
"Keymap used in `edit-abbrevs'.")
@@ -131,8 +124,13 @@ Otherwise display all abbrevs."
(if local
(insert-abbrev-table-description
(abbrev-table-name local-table) t)
- (dolist (table abbrev-table-name-list)
- (insert-abbrev-table-description table t)))
+ (let (empty-tables)
+ (dolist (table abbrev-table-name-list)
+ (if (abbrev-table-empty-p (symbol-value table))
+ (push table empty-tables)
+ (insert-abbrev-table-description table t)))
+ (dolist (table (nreverse empty-tables))
+ (insert-abbrev-table-description table t))))
(goto-char (point-min))
(set-buffer-modified-p nil)
(edit-abbrevs-mode)
@@ -219,13 +217,15 @@ Does not display any message."
;(interactive "fRead abbrev file: ")
(read-abbrev-file file t))
-(defun write-abbrev-file (&optional file)
+(defun write-abbrev-file (&optional file verbose)
"Write all user-level abbrev definitions to a file of Lisp code.
This does not include system abbrevs; it includes only the abbrev tables
listed in listed in `abbrev-table-name-list'.
The file written can be loaded in another session to define the same abbrevs.
The argument FILE is the file name to write. If omitted or nil, the file
-specified in `abbrev-file-name' is used."
+specified in `abbrev-file-name' is used.
+If VERBOSE is non-nil, display a message indicating where abbrevs
+have been saved."
(interactive
(list
(read-file-name "Write abbrev file: "
@@ -233,21 +233,47 @@ specified in `abbrev-file-name' is used."
abbrev-file-name)))
(or (and file (> (length file) 0))
(setq file abbrev-file-name))
- (let ((coding-system-for-write 'emacs-mule))
- (with-temp-file file
- (insert ";;-*-coding: emacs-mule;-*-\n")
+ (let ((coding-system-for-write 'utf-8))
+ (with-temp-buffer
(dolist (table
- ;; We sort the table in order to ease the automatic
- ;; merging of different versions of the user's abbrevs
- ;; file. This is useful, for example, for when the
- ;; user keeps their home directory in a revision
- ;; control system, and is therefore keeping multiple
- ;; slightly-differing copies loosely synchronized.
- (sort (copy-sequence abbrev-table-name-list)
- (lambda (s1 s2)
- (string< (symbol-name s1)
- (symbol-name s2)))))
- (insert-abbrev-table-description table nil)))))
+ ;; We sort the table in order to ease the automatic
+ ;; merging of different versions of the user's abbrevs
+ ;; file. This is useful, for example, for when the
+ ;; user keeps their home directory in a revision
+ ;; control system, and is therefore keeping multiple
+ ;; slightly-differing copies loosely synchronized.
+ (sort (copy-sequence abbrev-table-name-list)
+ (lambda (s1 s2)
+ (string< (symbol-name s1)
+ (symbol-name s2)))))
+ (insert-abbrev-table-description table nil))
+ (when (unencodable-char-position (point-min) (point-max) 'utf-8)
+ (setq coding-system-for-write
+ (if (> emacs-major-version 24)
+ 'utf-8-emacs
+ ;; For compatibility with Emacs 22 (See Bug#8308)
+ 'emacs-mule)))
+ (goto-char (point-min))
+ (insert (format ";;-*-coding: %s;-*-\n" coding-system-for-write))
+ (write-region nil nil file nil (and (not verbose) 0)))))
+
+(defun abbrev-edit-save-to-file (file)
+ "Save all user-level abbrev definitions in current buffer to FILE."
+ (interactive
+ (list (read-file-name "Save abbrevs to file: "
+ (file-name-directory
+ (expand-file-name abbrev-file-name))
+ abbrev-file-name)))
+ (edit-abbrevs-redefine)
+ (write-abbrev-file file t))
+
+(defun abbrev-edit-save-buffer ()
+ "Save all user-level abbrev definitions in current buffer.
+The saved abbrevs are written to the file specified by
+`abbrev-file-name'."
+ (interactive)
+ (abbrev-edit-save-to-file abbrev-file-name))
+
(defun add-mode-abbrev (arg)
"Define mode-specific abbrev for last word(s) before point.
@@ -420,6 +446,19 @@ PROPS is a list of properties."
(and (vectorp object)
(numberp (abbrev-table-get object :abbrev-table-modiff))))
+(defun abbrev-table-empty-p (object &optional ignore-system)
+ "Return nil if there are no abbrev symbols in OBJECT.
+If IGNORE-SYSTEM is non-nil, system definitions are ignored."
+ (unless (abbrev-table-p object)
+ (error "Non abbrev table object"))
+ (not (catch 'some
+ (mapatoms (lambda (abbrev)
+ (unless (or (zerop (length (symbol-name abbrev)))
+ (and ignore-system
+ (abbrev-get abbrev :system)))
+ (throw 'some t)))
+ object))))
+
(defvar global-abbrev-table (make-abbrev-table)
"The abbrev table whose abbrevs affect all buffers.
Each buffer may also have a local abbrev table.
@@ -775,20 +814,19 @@ Returns the abbrev symbol, if expansion took place."
(destructuring-bind (&optional sym name wordstart wordend)
(abbrev--before-point)
(when sym
- (let ((value sym))
- (unless (or ;; executing-kbd-macro
- noninteractive
- (window-minibuffer-p (selected-window)))
- ;; Add an undo boundary, in case we are doing this for
- ;; a self-inserting command which has avoided making one so far.
- (undo-boundary))
- ;; Now sym is the abbrev symbol.
- (setq last-abbrev-text name)
- (setq last-abbrev sym)
- (setq last-abbrev-location wordstart)
- ;; If this abbrev has an expansion, delete the abbrev
- ;; and insert the expansion.
- (abbrev-insert sym name wordstart wordend))))))
+ (unless (or ;; executing-kbd-macro
+ noninteractive
+ (window-minibuffer-p (selected-window)))
+ ;; Add an undo boundary, in case we are doing this for
+ ;; a self-inserting command which has avoided making one so far.
+ (undo-boundary))
+ ;; Now sym is the abbrev symbol.
+ (setq last-abbrev-text name)
+ (setq last-abbrev sym)
+ (setq last-abbrev-location wordstart)
+ ;; If this abbrev has an expansion, delete the abbrev
+ ;; and insert the expansion.
+ (abbrev-insert sym name wordstart wordend)))))
(defun unexpand-abbrev ()
"Undo the expansion of the last abbrev that expanded.
@@ -927,5 +965,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/align.el b/lisp/align.el
index 72c12e14ab6..8767b6ff306 100644
--- a/lisp/align.el
+++ b/lisp/align.el
@@ -1,7 +1,6 @@
;;; align.el --- align text to a specific column, by regexp
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
;; Maintainer: FSF
@@ -1107,7 +1106,7 @@ documentation for `align-region-separate' for more details."
(setq seps (cdr seps))))
yes))))
-(defun align-adjust-col-for-rule (column rule spacing tab-stop)
+(defun align-adjust-col-for-rule (column _rule spacing tab-stop)
"Adjust COLUMN according to the given RULE.
SPACING specifies how much spacing to use.
TAB-STOP specifies whether SPACING refers to tab-stop boundaries."
@@ -1162,7 +1161,7 @@ have been aligned. No changes will be made to the buffer."
(justify (cdr (assq 'justify rule)))
(col (or fixed 0))
(width 0)
- ecol change look)
+ ecol change)
;; Determine the alignment column.
(let ((a areas))
@@ -1286,7 +1285,6 @@ purpose where you might want to know where the regions that the
aligner would have dealt with are."
(let ((end-mark (and end (copy-marker end t)))
(real-beg beg)
- (real-end end)
(report (and (not func) align-large-region beg end
(>= (- end beg) align-large-region)))
(rule-index 1)
@@ -1315,7 +1313,7 @@ aligner would have dealt with are."
tab-stop tab-stop-c
repeat repeat-c
valid valid-c
- pos-list first
+ first
regions index
last-point b e
save-match-data
@@ -1605,5 +1603,4 @@ aligner would have dealt with are."
(run-hooks 'align-load-hook)
-;; arch-tag: ef79cccf-1db8-4888-a8a1-d7ce2d1532f7
;;; align.el ends here
diff --git a/lisp/allout-widgets.el b/lisp/allout-widgets.el
new file mode 100644
index 00000000000..a83e5a2a85c
--- /dev/null
+++ b/lisp/allout-widgets.el
@@ -0,0 +1,2380 @@
+;; allout-widgets.el --- Visually highlight allout outline structure.
+
+;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011 Ken Manheimer
+
+;; Author: Ken Manheimer <ken dot manheimer at gmail dot com>
+;; Maintainer: Ken Manheimer <ken dot manheimer at gmail dot com>
+;; Version: 1.0
+;; Created: Dec 2005
+;; Version: 1.0
+;; Keywords: outlines
+;; Website: http://myriadicity.net/Sundry/EmacsAllout
+
+;;; Commentary:
+
+;; This is an allout outline-mode add-on that highlights outline structure
+;; with graphical widgets.
+;;
+;; To activate, customize `allout-widgets-auto-activation'. You can also
+;; invoke allout-widgets-mode in a particular allout buffer. When
+;; auto-enabled, you can inhibit widget operation in particular allout
+;; buffers by setting the variable `allout-widgets-mode-inhibit' non-nil in
+;; that file's buffer. Use emacs *file local variables* to generally
+;; inhibit for a file.
+;;
+;; See the `allout-widgets-mode' docstring for more details.
+;;
+;; Info about allout and allout-widgets development are available at
+;; http://myriadicity.net/Sundry/EmacsAllout
+;;
+;; The graphics include:
+;;
+;; - icons for item bullets, varying to distinguish whether the item either
+;; lacks any subitems, the subitems are currently collapsed within the
+;; item, or the item is currently expanded.
+;;
+;; - guide lines connecting item bullet-icons with those of their subitems.
+;;
+;; - cue area between the bullet-icon and the start of the body headline,
+;; for item numbering, encryption indicator, and distinctive bullets.
+;;
+;; The bullet-icon and guide line graphics provide keybindings and mouse
+;; bindings for easy outline navigation and exposure control, extending
+;; outline hot-spot navigation (see `allout-mode' docstring for details).
+;;
+;; Developers note: Our use of emacs widgets is unconventional. We
+;; decorate existing text rather than substituting for it, to
+;; piggy-back on existing allout operation. This employs the C-coded
+;; efficiencies of widget-apply, widget-get, and widget-put, along
+;; with the basic object-oriented organization of widget-create, to
+;; systematically couple overlays, graphics, and other features with
+;; allout-governed text.
+
+;;;_: Code (structured with comments that delinieate an allout outline)
+
+;;;_ : General Environment
+(require 'allout)
+(require 'widget)
+(require 'wid-edit)
+
+(eval-when-compile
+ (progn
+ (require 'overlay)
+ (require 'cl)
+ ))
+
+;;;_ : internal variables needed before user-customization variables
+;;; In order to enable activation of allout-widgets-mode via customization,
+;;; allout-widgets-auto-activation uses a setting function. That function
+;;; is invoked when the customization variable definition is evaluated,
+;;; during file load, so the involved code must reside above that
+;;; definition in the file.
+;;;_ = allout-widgets-mode
+(defvar allout-widgets-mode nil
+ "Allout mode enhanced with graphical widgets.")
+(make-variable-buffer-local 'allout-widgets-mode)
+
+;;;_ : USER CUSTOMIZATION VARIABLES and incidental functions:
+;;;_ > defgroup allout-widgets
+;;;###autoload
+(defgroup allout-widgets nil
+ "Allout extension that highlights outline structure graphically.
+
+Customize `allout-widgets-auto-activation' to activate allout-widgets
+with allout-mode."
+ :group 'allout)
+;;;_ > defgroup allout-widgets-developer
+(defgroup allout-widgets-developer nil
+ "Settings for development of allout widgets extension."
+ :group 'allout-widgets)
+;;;_ ; some functions a bit early, for allout-auto-activation dependency:
+;;;_ > allout-widgets-mode-enable
+(defun allout-widgets-mode-enable ()
+ "Enable allout-widgets-mode in allout-mode buffers.
+
+See `allout-widgets-mode-inhibit' for per-file/per-buffer
+inhibition of allout-widgets-mode."
+ (add-hook 'allout-mode-off-hook 'allout-widgets-mode-off)
+ (add-hook 'allout-mode-on-hook 'allout-widgets-mode-on)
+ t)
+;;;_ > allout-widgets-mode-disable
+(defun allout-widgets-mode-disable ()
+ "Disable allout-widgets-mode in allout-mode buffers.
+
+See `allout-widgets-mode-inhibit' for per-file/per-buffer
+inhibition of allout-widgets-mode."
+ (remove-hook 'allout-mode-off-hook 'allout-widgets-mode-off)
+ (remove-hook 'allout-mode-on-hook 'allout-widgets-mode-on)
+ t)
+;;;_ > allout-widgets-setup (varname value)
+;;;###autoload
+(defun allout-widgets-setup (varname value)
+ "Commission or decommision allout-widgets-mode along with allout-mode.
+
+Meant to be used by customization of `allout-widgets-auto-activation'."
+ (set-default varname value)
+ (if allout-widgets-auto-activation
+ (allout-widgets-mode-enable)
+ (allout-widgets-mode-disable)))
+;;;_ = allout-widgets-auto-activation
+;;;###autoload
+(defcustom allout-widgets-auto-activation nil
+ "Activate to enable allout icon graphics wherever allout mode is active.
+
+Also enable `allout-auto-activation' for this to take effect upon
+visiting an outline.
+
+When this is set you can disable allout widgets in select files
+by setting `allout-widgets-mode-inhibit'
+
+Instead of setting `allout-widgets-auto-activation' you can
+explicitly invoke `allout-widgets-mode' in allout buffers where
+you want allout widgets operation.
+
+See `allout-widgets-mode' for allout widgets mode features."
+ :type 'boolean
+ :group 'allout-widgets
+ :set 'allout-widgets-setup
+ )
+;; ;;;_ = allout-widgets-allow-unruly-edits
+;; (defcustom allout-widgets-allow-unruly-edits nil
+;; "*Control whether manual edits are restricted to maintain outline integrity.
+
+;; When nil, manual edits must either be within an item's body or encompass
+;; one or more items completely - eg, killing topics as entities, rather than
+;; deleting from the middle of one to the middle of another.
+
+;; If you only occasionally need to make unrestricted change, you can set this
+;; variable in the specific buffer using set-variable, or just deactivate
+;; `allout-mode' temporarily. You can customize this to always allow unruly
+;; edits, but you will be able to create outlines that are unnavigable in
+;; principle, and not just for allout's navigation and exposure mechanisms."
+;; :type 'boolean
+;; :group allout-widgets)
+;; (make-variable-buffer-local 'allout-widgets-allow-unruly-edits)
+;;;_ = allout-widgets-auto-activation - below, for eval-order dependencies
+;;;_ = allout-widgets-icons-dark-subdir
+(defcustom allout-widgets-icons-dark-subdir "icons/allout-widgets/dark-bg/"
+ "Directory on `image-load-path' holding allout icons for dark backgrounds."
+ :type 'string
+ :group 'allout-widgets)
+;;;_ = allout-widgets-icons-light-subdir
+(defcustom allout-widgets-icons-light-subdir "icons/allout-widgets/light-bg/"
+ "Directory on `image-load-path' holding allout icons for light backgrounds."
+ :type 'string
+ :group 'allout-widgets)
+;;;_ = allout-widgets-icon-types
+(defcustom allout-widgets-icon-types '(xpm png)
+ "File extensions for the icon graphic format types, in order of preference."
+ :type '(repeat symbol)
+ :group 'allout-widgets)
+
+;;;_ . Decoration format
+;;;_ = allout-widgets-theme-dark-background
+(defcustom allout-widgets-theme-dark-background "allout-dark-bg"
+ "Identify the outline's icon theme to use with a dark background."
+ :type '(string)
+ :group 'allout-widgets)
+;;;_ = allout-widgets-theme-light-background
+(defcustom allout-widgets-theme-light-background "allout-light-bg"
+ "Identify the outline's icon theme to use with a light background."
+ :type '(string)
+ :group 'allout-widgets)
+;;;_ = allout-widgets-item-image-properties-emacs
+(defcustom allout-widgets-item-image-properties-emacs
+ '(:ascent center :mask (heuristic t))
+ "*Default properties item widget images in mainline Emacs."
+ :type 'plist
+ :group 'allout-widgets)
+;;;_ = allout-widgets-item-image-properties-xemacs
+(defcustom allout-widgets-item-image-properties-xemacs
+ nil
+ "*Default properties item widget images in XEmacs."
+ :type 'plist
+ :group 'allout-widgets)
+;;;_ . Developer
+;;;_ = allout-widgets-run-unit-tests-on-load
+(defcustom allout-widgets-run-unit-tests-on-load nil
+ "*When non-nil, unit tests will be run at end of loading allout-widgets.
+
+Generally, allout widgets code developers are the only ones who'll want to
+set this.
+
+\(If set, this makes it an even better practice to exercise changes by
+doing byte-compilation with a repeat count, so the file is loaded after
+compilation.)
+
+See `allout-widgets-run-unit-tests' to see what's run."
+ :type 'boolean
+ :group 'allout-widgets-developer)
+;;;_ = allout-widgets-time-decoration-activity
+(defcustom allout-widgets-time-decoration-activity nil
+ "*Retain timing info of the last cooperative redecoration.
+
+The details are retained as the value of
+`allout-widgets-last-decoration-timing'.
+
+Generally, allout widgets code developers are the only ones who'll want to
+set this."
+ :type 'boolean
+ :group 'allout-widgets-developer)
+;;;_ = allout-widgets-hook-error-post-time 0
+(defcustom allout-widgets-hook-error-post-time 0
+ "*Amount of time to sit showing hook error messages.
+
+0 is minimal, or nil to not post to the message area.
+
+This is for debugging purposes."
+ :type 'integer
+ :group 'allout-widgets-developer)
+;;;_ = allout-widgets-maintain-tally nil
+(defcustom allout-widgets-maintain-tally nil
+ "*If non-nil, maintain a collection of widgets, `allout-widgets-tally'.
+
+This is for debugging purposes.
+
+The tally shows the total number of item widgets in the current
+buffer, and tracking increases as new widgets are added and
+decreases as obsolete widgets are garbage collected."
+ :type 'boolean
+ :group 'allout-widgets-developer)
+(defvar allout-widgets-tally nil
+ "Hash-table of existing allout widgets, for debugging.
+
+Table is maintained iff `allout-widgets-maintain-tally' is non-nil.
+
+The table contents will be out of sync if any widgets are created
+or deleted while this variable is nil.")
+(make-variable-buffer-local 'allout-widgets-tally)
+(defvar allout-widgets-mode-inhibit) ; defined below
+;;;_ > allout-widgets-tally-string
+(defun allout-widgets-tally-string ()
+ "Return a string giving the number of tracked widgets, or empty string if not tracking.
+
+The string is formed for appending to the allout-mode mode-line lighter.
+
+An empty string is also returned if tracking is inhibited or
+widgets are locally inhibited.
+
+The number varies according to the evanescence of objects on a
+ hash table with weak keys, so tracking of widget erasures is often delayed."
+ (when (and allout-widgets-maintain-tally (not allout-widgets-mode-inhibit))
+ (format ":%s" (hash-table-count allout-widgets-tally))))
+;;;_ = allout-widgets-track-decoration nil
+(defcustom allout-widgets-track-decoration nil
+ "*If non-nil, show cursor position of each item decoration.
+
+This is for debugging purposes, and generally set at need in a
+buffer rather than as a prevailing configuration \(but it's handy
+to publicize it by making it a customization variable\)."
+ :type 'boolean
+ :group 'allout-widgets-developer)
+(make-variable-buffer-local 'allout-widgets-track-decoration)
+
+;;;_ : Mode context - variables, hookup, and hooks
+;;;_ . internal mode variables
+;;;_ , Mode activation and environment
+;;;_ = allout-widgets-version
+(defvar allout-widgets-version "1.0"
+ "Version of currently loaded allout-widgets extension.")
+;;;_ > allout-widgets-version
+(defun allout-widgets-version (&optional here)
+ "Return string describing the loaded outline version."
+ (interactive "P")
+ (let ((msg (concat "Allout Outline Widgets Extension v "
+ allout-widgets-version)))
+ (if here (insert msg))
+ (message "%s" msg)
+ msg))
+;;;_ = allout-widgets-mode-inhibit
+(defvar allout-widgets-mode-inhibit nil
+ "Inhibit `allout-widgets-mode' from activating widgets.
+
+This also inhibits automatic adjustment of widgets to track allout outline
+changes.
+
+You can use this as a file local variable setting to disable
+allout widgets enhancements in selected buffers while generally
+enabling widgets by customizing `allout-widgets-auto-activation'.
+
+In addition, you can invoked `allout-widgets-mode' allout-mode
+buffers where this is set to enable and disable widget
+enhancements, directly.")
+;;;###autoload
+(put 'allout-widgets-mode-inhibit 'safe-local-variable
+ (if (fboundp 'booleanp) 'booleanp '(lambda (x) (member x '(t nil)))))
+(make-variable-buffer-local 'allout-widgets-mode-inhibit)
+;;;_ = allout-inhibit-body-modification-hook
+(defvar allout-inhibit-body-modification-hook nil
+ "Override de-escaping of text-prefixes in item bodies during specific changes.
+
+This is used by `allout-buffer-modification-handler' to signal such changes
+to `allout-body-modification-handler', and is always reset by
+`allout-post-command-business'.")
+(make-variable-buffer-local 'allout-inhibit-body-modification-hook)
+;;;_ = allout-widgets-icons-cache
+(defvar allout-widgets-icons-cache nil
+ "Cache allout icon images, as an association list.
+
+`allout-fetch-icon-image' uses this cache transparently, keying
+images with lists containing the name of the icon directory \(as
+found on the `load-path') and the icon name.
+
+Set this variable to `nil' to empty the cache, and have it replenish from the
+filesystem.")
+;;;_ = allout-widgets-unset-inhibit-read-only
+(defvar allout-widgets-unset-inhibit-read-only nil
+ "Tell `allout-widgets-post-command-business' to unset `inhibit-read-only'.
+
+Used by `allout-graphics-modification-handler'")
+;;;_ = allout-widgets-reenable-before-change-handler
+(defvar allout-widgets-reenable-before-change-handler nil
+ "Tell `allout-widgets-post-command-business' to reequip the handler.
+
+Necessary because the handler sometimes deliberately raises an
+error, causing it to be disabled.")
+;;;_ , State for hooks
+;;;_ = allout-unresolved-body-mod-workroster
+(defvar allout-unresolved-body-mod-workroster (make-hash-table :size 16)
+ "List of body-overlays that did before-change business but not after-change.
+
+See `allout-post-command-business' and `allout-body-modification-handler'.")
+;;;_ = allout-structure-unruly-deletion-message
+(defvar allout-structure-unruly-deletion-message
+ "Unruly edit prevented --
+To change the bullet character: \\[allout-rebullet-current-heading]
+To promote this item: \\[allout-shift-out]
+To demote it: \\[allout-shift-in]
+To delete it and offspring: \\[allout-kill-topic]
+See \\[describe-mode] for many more options."
+ "Informative message presented on improper editing of outline structure.
+
+The structure includes the guides lines, bullet, and bullet cue.")
+;;;_ = allout-widgets-changes-record
+(defvar allout-widgets-changes-record nil
+ "Record outline changes for processing by post-command hook.
+
+Entries on the list are lists whose first element is a symbol indicating
+the change type and subsequent elements are data specific to that change
+type. Specifically:
+
+ 'exposure `allout-exposure-from' `allout-exposure-to' `allout-exposure-flag'
+
+The changes are recorded in reverse order, with new values pushed
+onto the front.")
+(make-variable-buffer-local 'allout-widgets-changes-record)
+;;;_ = allout-widgets-undo-exposure-record
+(defvar allout-widgets-undo-exposure-record nil
+ "Record outline undo traces for processing by post-command hook.
+
+The changes are recorded in reverse order, with new values pushed
+onto the front.")
+(make-variable-buffer-local 'allout-widgets-undo-exposure-record)
+;;;_ = allout-widgets-last-hook-error
+(defvar allout-widgets-last-hook-error nil
+ "String holding last error string, for debugging purposes.")
+;;;_ = allout-widgets-adjust-message-length-threshold 100
+(defvar allout-widgets-adjust-message-length-threshold 100
+ "Display \"Adjusting widgets\" message above this number of pending changes."
+ )
+;;;_ = allout-widgets-adjust-message-size-threshold 10000
+(defvar allout-widgets-adjust-message-size-threshold 10000
+ "Display \"Adjusting widgets\" message above this size of pending changes."
+ )
+;;;_ = allout-doing-exposure-undo-processor nil
+(defvar allout-undo-exposure-in-progress nil
+ "Maintained true during `allout-widgets-exposure-undo-processor'")
+;;;_ , Widget-specific outline text format
+;;;_ = allout-escaped-prefix-regexp
+(defvar allout-escaped-prefix-regexp ""
+ "*Regular expression for body text that would look like an item prefix if
+not altered with an escape sequence.")
+(make-variable-buffer-local 'allout-escaped-prefix-regexp)
+;;;_ , Widget element formatting
+;;;_ = allout-item-icon-keymap
+(defvar allout-item-icon-keymap
+ (let ((km (make-sparse-keymap)))
+ (dolist (digit '("0" "1" "2" "3"
+ "4" "5" "6" "7" "8" "9"))
+ (define-key km digit 'digit-argument))
+ (define-key km "-" 'negative-argument)
+;; (define-key km [(return)] 'allout-tree-expand-command)
+;; (define-key km [(meta return)] 'allout-toggle-torso-command)
+;; (define-key km [(down-mouse-1)] 'allout-item-button-click)
+;; (define-key km [(down-mouse-2)] 'allout-toggle-torso-event-command)
+ ;; Override underlying mouse-1 and mouse-2 bindings in icon territory:
+ (define-key km [(mouse-1)] (lambda () (interactive) nil))
+ (define-key km [(mouse-2)] (lambda () (interactive) nil))
+
+ ;; Catchall, handles actual keybindings, dynamically doing keymap lookups:
+ (define-key km [t] 'allout-item-icon-key-handler)
+
+ km)
+ "General tree-node key bindings.")
+;;;_ = allout-item-body-keymap
+(defvar allout-item-body-keymap
+ (let ((km (make-sparse-keymap))
+ (local-map (current-local-map)))
+;; (define-key km [(control return)] 'allout-tree-expand-command)
+;; (define-key km [(meta return)] 'allout-toggle-torso-command)
+ ;; XXX We need to reset this per buffer's mode; we do so in
+ ;; allout-widgets-mode.
+ (if local-map
+ (set-keymap-parent km local-map))
+
+ km)
+ "General key bindings for the text content of outline items.")
+(make-variable-buffer-local 'allout-item-body-keymap)
+;;;_ = allout-body-span-category
+(defvar allout-body-span-category nil
+ "Symbol carrying allout body-text overlay properties.")
+;;;_ = allout-cue-span-keymap
+(defvar allout-cue-span-keymap
+ (let ((km (make-sparse-keymap)))
+ (set-keymap-parent km allout-item-icon-keymap)
+ km)
+ "Keymap used in the item cue area - the space between the icon and headline.")
+;;;_ = allout-escapes-category
+(defvar allout-escapes-category nil
+ "Symbol for category of text property used to hide escapes of prefix-like
+text in allout item bodies.")
+;;;_ = allout-guides-category
+(defvar allout-guides-category nil
+ "Symbol carrying allout icon-guides overlay properties.")
+;;;_ = allout-guides-span-category
+(defvar allout-guides-span-category nil
+ "Symbol carrying allout icon and guide lines overlay properties.")
+;;;_ = allout-icon-span-category
+(defvar allout-icon-span-category nil
+ "Symbol carrying allout icon and guide lines overlay properties.")
+;;;_ = allout-cue-span-category
+(defvar allout-cue-span-category nil
+ "Symbol carrying common properties of the space following the outline icon.
+
+\(That space is used to convey selected cues indicating body qualities,
+including things like:
+ - encryption '~'
+ - numbering '#'
+ - indirect reference '@'
+ - distinctive bullets - see `allout-distinctive-bullets-string'.\)")
+;;;_ = allout-span-to-category
+(defvar allout-span-to-category
+ '((:guides-span . allout-guides-span-category)
+ (:cue-span . allout-cue-span-category)
+ (:icon-span . allout-icon-span-category)
+ (:body-span . allout-body-span-category))
+ "Association list mapping span identifier to category identifier.")
+;;;_ = allout-trailing-category
+(defvar allout-trailing-category nil
+ "Symbol carrying common properties of an overlay's trailing newline.")
+;;;_ , Developer
+(defvar allout-widgets-last-decoration-timing nil
+ "Timing details for the last cooperative decoration action.
+
+This is maintained when `allout-widgets-time-decoration-activity' is set.
+
+The value is a list containing two elements:
+ - the elapsed time as a number of seconds
+ - the list of changes processed, a la `allout-widgets-changes-record'.
+
+When active, the value is revised each time automatic decoration activity
+happens in the buffer.")
+(make-variable-buffer-local 'allout-widgets-last-decoration-timing)
+;;;_ . mode hookup
+;;;_ > define-minor-mode allout-widgets-mode (arg)
+;;;###autoload
+(define-minor-mode allout-widgets-mode
+ "Allout-mode extension, providing graphical decoration of outline structure.
+
+This is meant to operate along with allout-mode, via `allout-mode-hook'.
+
+If optional argument ARG is greater than 0, enable.
+If optional argument ARG is less than 0, disable.
+Anything else, toggle between active and inactive.
+
+The graphics include:
+
+- guide lines connecting item bullet-icons with those of their subitems.
+
+- icons for item bullets, varying to indicate whether or not the item
+ has subitems, and if so, whether or not the item is expanded.
+
+- cue area between the bullet-icon and the start of the body headline,
+ for item numbering, encryption indicator, and distinctive bullets.
+
+The bullet-icon and guide line graphics provide keybindings and mouse
+bindings for easy outline navigation and exposure control, extending
+outline hot-spot navigation \(see `allout-mode')."
+
+ :lighter nil
+ :keymap nil
+
+ ;; define-minor-mode handles any provided argument according to emacs
+ ;; minor-mode conventions - '(elisp) Minor Mode Conventions' - and sets
+ ;; allout-widgets-mode accordingly *before* running the body code, so we
+ ;; cue on that.
+ (if allout-widgets-mode
+ ;; Activating:
+ (progn
+ (allout-add-resumptions
+ ;; XXX user may need say in line-truncation/hscrolling - an option
+ ;; that abstracts mode.
+ ;; truncate text lines to keep guide lines intact:
+ '(truncate-lines t)
+ ;; and enable autoscrolling to ease view of text
+ '(auto-hscroll-mode t)
+ '(line-move-ignore-fields t)
+ '(widget-push-button-prefix "")
+ '(widget-push-button-suffix "")
+ ;; allout-escaped-prefix-regexp depends on allout-regexp:
+ (list 'allout-escaped-prefix-regexp (concat "\\(\\\\\\)"
+ "\\(" allout-regexp "\\)")))
+ (allout-add-resumptions
+ (list 'allout-widgets-tally allout-widgets-tally)
+ (list 'allout-widgets-escapes-sanitization-regexp-pair
+ (list (concat "\\(\n\\|\\`\\)"
+ allout-escaped-prefix-regexp
+ )
+ ;; Include everything but the escape symbol.
+ "\\1\\3"))
+ )
+
+ (add-hook 'after-change-functions 'allout-widgets-after-change-handler
+ nil t)
+
+ (allout-setup-text-properties)
+ (add-to-invisibility-spec '(allout-torso . t))
+ (add-to-invisibility-spec 'allout-escapes)
+
+ (if (current-local-map)
+ (set-keymap-parent allout-item-body-keymap (current-local-map)))
+
+ (add-hook 'allout-exposure-change-hook
+ 'allout-widgets-exposure-change-recorder nil 'local)
+ (add-hook 'allout-structure-added-hook
+ 'allout-widgets-additions-recorder nil 'local)
+ (add-hook 'allout-structure-deleted-hook
+ 'allout-widgets-deletions-recorder nil 'local)
+ (add-hook 'allout-structure-shifted-hook
+ 'allout-widgets-shifts-recorder nil 'local)
+ (add-hook 'allout-after-copy-or-kill-hook
+ 'allout-widgets-after-copy-or-kill-function nil 'local)
+
+ (add-hook 'before-change-functions 'allout-widgets-before-change-handler
+ nil 'local)
+ (add-hook 'post-command-hook 'allout-widgets-post-command-business
+ nil 'local)
+ (add-hook 'pre-command-hook 'allout-widgets-pre-command-business
+ nil 'local)
+
+ ;; init the widgets tally for debugging:
+ (if (not allout-widgets-tally)
+ (setq allout-widgets-tally (make-hash-table
+ :test 'eq :weakness 'key)))
+ ;; add tally count display on minor-mode-alist just after
+ ;; allout-mode entry.
+ ;; (we use ternary condition form to keep condition simple for deletion.)
+ (let* ((mode-line-entry '(allout-widgets-mode-inhibit ""
+ (:eval (allout-widgets-tally-string))))
+ (associated (assoc (car mode-line-entry) minor-mode-alist))
+ ;; need location for it only if not already present:
+ (after (and (not associated)
+ (memq (assq 'allout-mode minor-mode-alist) minor-mode-alist))))
+ (if after
+ (rplacd after (cons mode-line-entry (cdr after)))))
+ (allout-widgets-prepopulate-buffer)
+ t)
+ ;; Deactivating:
+ (let ((inhibit-read-only t)
+ (was-modified (buffer-modified-p)))
+
+ (allout-widgets-undecorate-region (point-min)(point-max))
+ (remove-from-invisibility-spec '(allout-torso . t))
+ (remove-from-invisibility-spec 'allout-escapes)
+
+ (remove-hook 'after-change-functions
+ 'allout-widgets-after-change-handler 'local)
+ (remove-hook 'allout-exposure-change-hook
+ 'allout-widgets-exposure-change-recorder 'local)
+ (remove-hook 'allout-structure-added-hook
+ 'allout-widgets-additions-recorder 'local)
+ (remove-hook 'allout-structure-deleted-hook
+ 'allout-widgets-deletions-recorder 'local)
+ (remove-hook 'allout-structure-shifted-hook
+ 'allout-widgets-shifts-recorder 'local)
+ (remove-hook 'allout-after-copy-or-kill-hook
+ 'allout-widgets-after-copy-or-kill-function 'local)
+ (remove-hook 'before-change-functions
+ 'allout-widgets-before-change-handler 'local)
+ (remove-hook 'post-command-hook
+ 'allout-widgets-post-command-business 'local)
+ (remove-hook 'pre-command-hook
+ 'allout-widgets-pre-command-business 'local)
+ (assq-delete-all 'allout-widgets-mode-inhibit minor-mode-alist)
+ (set-buffer-modified-p was-modified))))
+;;;_ > allout-widgets-mode-off
+(defun allout-widgets-mode-off ()
+ "Explicitly disable allout-widgets-mode."
+ (allout-widgets-mode -1))
+;;;_ > allout-widgets-mode-off
+(defun allout-widgets-mode-on ()
+ "Explicitly disable allout-widgets-mode."
+ (allout-widgets-mode 1))
+;;;_ > allout-setup-text-properties ()
+(defun allout-setup-text-properties ()
+ "Configure category and literal text properties."
+
+ ;; XXX body - before-change, entry, keymap
+
+ (setplist 'allout-guides-span-category nil)
+ (put 'allout-guides-span-category
+ 'modification-hooks '(allout-graphics-modification-handler))
+ (put 'allout-guides-span-category 'local-map allout-item-icon-keymap)
+ (put 'allout-guides-span-category 'mouse-face widget-button-face)
+ (put 'allout-guides-span-category 'field 'structure)
+;; (put 'allout-guides-span-category 'face 'widget-button)
+
+ (setplist 'allout-icon-span-category
+ (allout-widgets-copy-list (symbol-plist
+ 'allout-guides-span-category)))
+ (put 'allout-icon-span-category 'field 'structure)
+
+ ;; XXX for body text we're instead going to use the buffer-wide
+ ;; resources, like before/after-change-functions hooks and the
+ ;; buffer's key map. that way we won't have to do painful provisions
+ ;; to fixup things after edits, catch outlier interstitial
+ ;; characters, like newline and empty lines after hidden subitems,
+ ;; etc.
+ (setplist 'allout-body-span-category nil)
+ (put 'allout-body-span-category 'evaporate t)
+ (put 'allout-body-span-category 'local-map allout-item-body-keymap)
+ ;;(put 'allout-body-span-category
+ ;; 'modification-hooks '(allout-body-modification-handler))
+ ;;(put 'allout-body-span-category 'field 'body)
+
+ (setplist 'allout-cue-span-category nil)
+ (put 'allout-cue-span-category 'evaporate t)
+ (put 'allout-cue-span-category
+ 'modification-hooks '(allout-body-modification-handler))
+ (put 'allout-cue-span-category 'local-map allout-cue-span-keymap)
+ (put 'allout-cue-span-category 'mouse-face widget-button-face)
+ (put 'allout-cue-span-category 'pointer 'arrow)
+ (put 'allout-cue-span-category 'field 'structure)
+
+ (setplist 'allout-trailing-category nil)
+ (put 'allout-trailing-category 'evaporate t)
+ (put 'allout-trailing-category 'local-map allout-item-body-keymap)
+
+ (setplist 'allout-escapes-category nil)
+ (put 'allout-escapes-category 'invisible 'allout-escapes)
+ (put 'allout-escapes-category 'evaporate t))
+;;;_ > allout-widgets-prepopulate-buffer ()
+(defun allout-widgets-prepopulate-buffer ()
+ "Step over the current buffers exposed items to do initial widgetizing."
+ (if (not allout-widgets-mode-inhibit)
+ (save-excursion
+ (goto-char (point-min))
+ (while (allout-next-visible-heading 1)
+ (when (not (widget-at (point)))
+ (allout-get-or-create-item-widget))))))
+;;;_ . settings context
+;;;_ = allout-container-item
+(defvar allout-container-item-widget nil
+ "A widget for the current outline's overarching container as an item.
+
+The item has settings \(of the file/connection\) and maybe a body, but no
+icon/bullet.")
+(make-variable-buffer-local 'allout-container-item-widget)
+;;;_ . Hooks and hook helpers
+;;;_ , major command-loop business:
+;;;_ > allout-widgets-pre-command-business (&optional recursing)
+(defun allout-widgets-pre-command-business (&optional recursing)
+ "Handle actions pending before allout-mode activity."
+)
+;;;_ > allout-widgets-post-command-business (&optional recursing)
+(defun allout-widgets-post-command-business (&optional recursing)
+ "Handle actions pending after any allout-mode commands.
+
+Optional RECURSING is for internal use, to limit recursion."
+ ;; - check changed text for nesting discontinuities and escape anything
+ ;; that's: (1) asterisks at bol or (2) excessively nested.
+ (condition-case failure
+
+ (when (and (boundp 'allout-mode) allout-mode)
+
+ (if allout-widgets-unset-inhibit-read-only
+ (setq inhibit-read-only nil
+ allout-widgets-unset-inhibit-read-only nil))
+
+ (when allout-widgets-reenable-before-change-handler
+ (add-hook 'before-change-functions
+ 'allout-widgets-before-change-handler
+ nil 'local)
+ (setq allout-widgets-reenable-before-change-handler nil))
+
+ (when (or allout-widgets-undo-exposure-record
+ allout-widgets-changes-record)
+ (let* ((debug-on-signal t)
+ (debug-on-error t)
+ ;; inhibit recording new undo records when processing
+ ;; effects of undo-exposure:
+ (debugger 'allout-widgets-hook-error-handler)
+ (adjusting-message " Adjusting widgets...")
+ (replaced-message (allout-widgets-adjusting-message
+ adjusting-message))
+ (start-time (current-time)))
+
+ (if allout-widgets-undo-exposure-record
+ ;; inhibit undo recording iff undoing exposure stuff.
+ ;; XXX we might need to inhibit per respective
+ ;; change-record, rather than assuming that some undo
+ ;; activity during a command is all undo activity.
+ (let ((buffer-undo-list t))
+ (allout-widgets-exposure-undo-processor)
+ (allout-widgets-changes-dispatcher))
+ (allout-widgets-exposure-undo-processor)
+ (allout-widgets-changes-dispatcher))
+
+ (if allout-widgets-time-decoration-activity
+ (setq allout-widgets-last-decoration-timing
+ (list (allout-elapsed-time-seconds (current-time)
+ start-time)
+ allout-widgets-changes-record)))
+
+ (setq allout-widgets-changes-record nil)
+
+ (if replaced-message
+ (if (stringp replaced-message)
+ (message replaced-message)
+ (message "")))))
+
+ ;; Detect undecorated items, eg during isearch into previously
+ ;; unexposed topics, and decorate "economically". Some
+ ;; undecorated stuff is often exposed, to reduce lag, but the
+ ;; item containing the cursor is decorated. We constrain
+ ;; recursion to avoid being trapped by unexpectedly undecoratable
+ ;; items.
+ (when (and (not recursing)
+ (not (allout-current-decorated-p))
+ (or (not (equal (allout-depth) 0))
+ (not allout-container-item-widget)))
+ (let ((buffer-undo-list t))
+ (allout-widgets-exposure-change-recorder
+ allout-recent-prefix-beginning allout-recent-prefix-end nil)
+ (allout-widgets-post-command-business 'recursing)))
+
+ ;; Detect and rectify fouled outline structure - decorated item
+ ;; not at beginning of line.
+ (let ((this-widget (or (widget-at (point))
+ ;; XXX we really should be checking across
+ ;; edited span, not just point and point+1
+ (and (not (eq (point) (point-max)))
+ (widget-at (1+ (point))))))
+ inserted-at)
+ (save-excursion
+ (if (and this-widget
+ (goto-char (widget-get this-widget :from))
+ (not (bolp)))
+ (if (not
+ (condition-case err
+ (yes-or-no-p
+ (concat "Misplaced item won't be recognizable "
+ " as part of outline - rectify? "))
+ (quit nil)))
+ (progn
+ (if (allout-hidden-p (max (1- (point)) 1))
+ (save-excursion
+ (goto-char (max (1- (point)) 1))
+ (allout-show-to-offshoot)))
+ (allout-widgets-undecorate-item this-widget))
+ ;; expose any hidden intervening items, so resulting
+ ;; position is clear:
+ (setq inserted-at (point))
+ (allout-unprotected (insert-before-markers "\n"))
+ (forward-char -1)
+ ;; ensure the inserted newline is visible:
+ (allout-flag-region inserted-at (1+ inserted-at) nil)
+ (allout-widgets-post-command-business 'recursing)
+ (message (concat "outline structure corrected - item"
+ " moved to beginning of new line"))
+ ;; preserve cursor position in some cases:
+ (if (and inserted-at
+ (> (point) inserted-at))
+ (forward-char -1)))))))
+
+ (error
+ ;; zero work list so we don't get stuck futily retrying.
+ ;; error recording done by allout-widgets-hook-error-handler.
+ (setq allout-widgets-changes-record nil))))
+;;;_ , major change handlers:
+;;;_ > allout-widgets-before-change-handler
+(defun allout-widgets-before-change-handler (beg end)
+ "Business to be done before changes in a widgetized allout outline."
+ ;; protect against unruly edits to structure:
+ (cond
+ (undo-in-progress (when (eq (get-text-property beg 'category)
+ 'allout-icon-span-category)
+ (save-excursion
+ (goto-char beg)
+ (let* ((item-widget (allout-get-item-widget)))
+ (if item-widget
+ (allout-widgets-exposure-undo-recorder
+ item-widget))))))
+ (inhibit-read-only t)
+ ((not (and (boundp 'allout-mode) allout-mode)) t)
+ ((equal this-command 'quoted-insert) t)
+ ((not (text-property-any beg (if (equal end beg)
+ (min (1+ beg) (point-max))
+ end)
+ 'field 'structure))
+ t)
+ ((yes-or-no-p "Unruly edit of outline structure - allow? ")
+ (setq allout-widgets-unset-inhibit-read-only (not inhibit-read-only)
+ inhibit-read-only t))
+ (t
+ ;; tell the allout-widgets-post-command-business to reestablish the hook:
+ (setq allout-widgets-reenable-before-change-handler t)
+ ;; and raise an error to prevent the edit (and disable the hook):
+ (error
+ (substitute-command-keys allout-structure-unruly-deletion-message)))))
+;;;_ > allout-widgets-after-change-handler
+(defun allout-widgets-after-change-handler (beg end prelength)
+ "Reconcile what needs to be reconciled for allout widgets after edits."
+ )
+;;;_ > allout-current-decorated-p ()
+(defun allout-current-decorated-p ()
+ "True if the current item is not decorated"
+ (save-excursion
+ (if (allout-back-to-current-heading)
+ (if (> allout-recent-depth 0)
+ (and (allout-get-item-widget) t)
+ allout-container-item-widget))))
+
+;;;_ > allout-widgets-hook-error-handler
+(defun allout-widgets-hook-error-handler (mode args)
+ "Process errors which occurred in the course of command hook operation.
+
+We store a backtrace of the error information in the variable,
+`allout-widgets-last-hook-error', unset the error handlers, and
+reraise the error, so that processing continues to the
+encompassing condition-case."
+ ;; first deconstruct special error environment so errors here propagate
+ ;; to encompassing condition-case:
+ (setq debugger 'debug
+ debug-on-error nil
+ debug-on-signal nil)
+ (let* ((bt (with-output-to-string (backtrace)))
+ (this "allout-widgets-hook-error-handler")
+ (header
+ (format "allout-widgets-last-hook-error stored, %s/%s %s %s"
+ this mode args
+ (format-time-string "%e-%b-%Y %r" (current-time)))))
+ ;; post to *Messages* then immediately replace with more compact notice:
+ (message "%s" (setq allout-widgets-last-hook-error
+ (format "%s:\n%s" header bt)))
+ (message header) (sit-for allout-widgets-hook-error-post-time)
+ ;; reraise the error, or one concerning this function if unexpected:
+ (if (equal mode 'error)
+ (apply 'signal args)
+ (error "%s: unexpected mode, %s %s" this mode args))))
+;;;_ > allout-widgets-changes-exceed-threshold-p ()
+(defun allout-widgets-adjusting-message (message)
+ "Post MESSAGE when pending are likely to make a big enough delay.
+
+If posting of the MESSAGE is warranted and there already is a
+`current-message' in the minibuffer, the MESSAGE is appended to
+the current one, and the previously pending `current-message' is
+returned for later posting on completion.
+
+If posting of the MESSAGE is warranted, but no `current-message'
+is pending, then t is returned to indicate that case.
+
+If posting of the MESSAGE is not warranted, then nil is returned.
+
+See `allout-widgets-adjust-message-length-threshold',
+`allout-widgets-adjust-message-size-threshold' for message
+posting threshold criteria."
+ (if (or (> (length allout-widgets-changes-record)
+ allout-widgets-adjust-message-length-threshold)
+ ;; for size, use distance from start of first to end of last:
+ (let ((min (point-max))
+ (max 0)
+ first second)
+ (mapc (function (lambda (entry)
+ (if (eq :undone-exposure (car entry))
+ nil
+ (setq first (cadr entry)
+ second (caddr entry))
+ (if (< (min first second) min)
+ (setq min (min first second)))
+ (if (> (max first second) max)
+ (setq max (max first second))))))
+ allout-widgets-changes-record)
+ (> (- max min) allout-widgets-adjust-message-size-threshold)))
+ (let ((prior (current-message)))
+ (message (if prior (concat prior " - " message) message))
+ (or prior t))))
+;;;_ > allout-widgets-changes-dispatcher ()
+(defun allout-widgets-changes-dispatcher ()
+ "Dispatch CHANGES-RECORD items to respective widgets change processors."
+
+ (if (not allout-widgets-mode-inhibit)
+ (let* ((changes-record allout-widgets-changes-record)
+ (changes-pending (and changes-record t))
+ entry
+ exposures
+ additions
+ deletions
+ shifts)
+
+ (when changes-pending
+ (while changes-record
+ (setq entry (pop changes-record))
+ (case (car entry)
+ (:exposed (push entry exposures))
+ (:added (push entry additions))
+ (:deleted (push entry deletions))
+ (:shifted (push entry shifts))))
+
+ (if exposures
+ (allout-widgets-exposure-change-processor exposures))
+ (if additions
+ (allout-widgets-additions-processor additions))
+ (if deletions
+ (allout-widgets-deletions-processor deletions))
+ (if shifts
+ (allout-widgets-shifts-processor shifts))))
+ (when (not (equal allout-widgets-mode-inhibit 'undecorated))
+ (allout-widgets-undecorate-region (point-min)(point-max))
+ (setq allout-widgets-mode-inhibit 'undecorated))))
+;;;_ > allout-widgets-exposure-change-recorder (from to flag)
+(defun allout-widgets-exposure-change-recorder (from to flag)
+ "Record allout exposure changes for tracking during post-command processing.
+
+Records changes in `allout-widgets-changes-record'."
+ (push (list :exposed from to flag) allout-widgets-changes-record))
+;;;_ > allout-widgets-exposure-change-processor (changes)
+(defun allout-widgets-exposure-change-processor (changes)
+ "Widgetize and adjust item widgets tracking allout outline exposure changes.
+
+Generally invoked via `allout-exposure-change-hook'."
+
+ (let ((changes (sort changes (function (lambda (this next)
+ (< (cadr this) (cadr next))))))
+ ;; have to distinguish between concealing and exposing so that, eg,
+ ;; `allout-expose-topic's mix is handled properly.
+ handled-expose
+ handled-conceal
+ covered
+ deactivate-mark)
+
+ (dolist (change changes)
+ (let (handling
+ (from (cadr change))
+ bucket got
+ (to (caddr change))
+ (flag (cadddr change))
+ parent)
+
+ ;; swap from and to:
+ (if (< to from) (setq bucket to
+ to from
+ from bucket))
+
+ ;; have we already handled exposure changes in this region?
+ (setq handling (if flag 'handled-conceal 'handled-expose)
+ got (allout-range-overlaps from to (symbol-value handling))
+ covered (car got))
+ (set handling (cadr got))
+
+ (when (not covered)
+ (save-excursion
+ (goto-char from)
+ (cond
+
+ ;; collapsing:
+ (flag
+ (allout-widgets-undecorate-region from to)
+ (allout-beginning-of-current-line)
+ (let ((widget (allout-get-item-widget)))
+ (if (not widget)
+ (allout-get-or-create-item-widget)
+ (widget-apply widget :redecorate))))
+
+ ;; expanding:
+ (t
+ (while (< (point) to)
+ (allout-beginning-of-current-line)
+ (setq parent (allout-get-item-widget))
+ (if (not parent)
+ (setq parent (allout-get-or-create-item-widget))
+ (widget-apply parent :redecorate))
+ (allout-next-visible-heading 1)
+ (if (widget-get parent :has-subitems)
+ (allout-redecorate-visible-subtree parent))
+ (if (> (point) to)
+ ;; subtree may be well beyond to - incorporate in ranges:
+ (setq handled-expose
+ (allout-range-overlaps from (point) handled-expose)
+ covered (car handled-expose)
+ handled-expose (cadr handled-expose)))
+ (allout-next-visible-heading 1))))))))))
+
+;;;_ > allout-widgets-additions-recorder (from to)
+(defun allout-widgets-additions-recorder (from to)
+ "Record allout item additions for tracking during post-command processing.
+
+Intended for use on `allout-structure-added-hook'.
+
+FROM point at the start of the first new item and TO is point at the start
+of the last one.
+
+Records changes in `allout-widgets-changes-record'."
+ (push (list :added from to) allout-widgets-changes-record))
+;;;_ > allout-widgets-additions-processor (changes)
+(defun allout-widgets-additions-processor (changes)
+ "Widgetize and adjust items tracking allout outline structure additions.
+
+Dispatched by `allout-widgets-post-command-business' in response to
+:added entries recorded by `allout-widgets-additions-recorder'."
+ (save-excursion
+ (let (handled
+ covered)
+ (dolist (change changes)
+ (let ((from (cadr change))
+ bucket
+ (to (caddr change)))
+ (if (< to from) (setq bucket to to from from bucket))
+ ;; have we already handled exposure changes in this region?
+ (setq handled (allout-range-overlaps from to handled)
+ covered (car handled)
+ handled (cadr handled))
+ (when (not covered)
+ (goto-char from)
+ ;; Prior sibling and parent can both be affected.
+ (if (allout-ascend)
+ (allout-redecorate-visible-subtree
+ (allout-get-or-create-item-widget 'redecorate)))
+ (if (< (point) from)
+ (goto-char from))
+ (while (and (< (point) to) (not (eobp)))
+ (allout-beginning-of-current-line)
+ (allout-redecorate-visible-subtree
+ (allout-get-or-create-item-widget))
+ (allout-next-visible-heading 1))
+ (if (> (point) to)
+ ;; subtree may be well beyond to - incorporate in ranges:
+ (setq handled (allout-range-overlaps from (point) handled)
+ covered (car handled)
+ handled (cadr handled)))))))))
+
+;;;_ > allout-widgets-deletions-recorder (depth from)
+(defun allout-widgets-deletions-recorder (depth from)
+ "Record allout item deletions for tracking during post-command processing.
+
+Intended for use on `allout-structure-deleted-hook'.
+
+DEPTH is the depth of the deleted subtree, and FROM is the point from which
+the subtree was deleted.
+
+Records changes in `allout-widgets-changes-record'."
+ (push (list :deleted depth from) allout-widgets-changes-record))
+;;;_ > allout-widgets-deletions-processor (changes)
+(defun allout-widgets-deletions-processor (changes)
+ "Adjust items tracking allout outline structure deletions.
+
+Dispatched by `allout-widgets-post-command-business' in response to
+:deleted entries recorded by `allout-widgets-deletions-recorder'."
+ (save-excursion
+ (dolist (change changes)
+ (let ((depth (cadr change))
+ (from (caddr change)))
+ (goto-char from)
+ (when (allout-previous-visible-heading 1)
+ (if (> depth 1)
+ (allout-ascend-to-depth (1- depth)))
+ (allout-redecorate-visible-subtree
+ (allout-get-or-create-item-widget 'redecorate)))))))
+
+;;;_ > allout-widgets-shifts-recorder (shifted-amount at)
+(defun allout-widgets-shifts-recorder (shifted-amount at)
+ "Record outline subtree shifts for tracking during post-command processing.
+
+Intended for use on `allout-structure-shifted-hook'.
+
+SHIFTED-AMOUNT is the depth change and AT is the point at the start of the
+subtree that's been shifted.
+
+Records changes in `allout-widgets-changes-record'."
+ (push (list :shifted shifted-amount at) allout-widgets-changes-record))
+;;;_ > allout-widgets-shifts-processor (changes)
+(defun allout-widgets-shifts-processor (changes)
+ "Widgetize and adjust items tracking allout outline structure additions.
+
+Dispatched by `allout-widgets-post-command-business' in response to
+:shifted entries recorded by `allout-widgets-shifts-recorder'."
+ (save-excursion
+ (dolist (change changes)
+ (goto-char (caddr change))
+ (allout-ascend)
+ (allout-redecorate-visible-subtree))))
+;;;_ > allout-widgets-after-copy-or-kill-function ()
+(defun allout-widgets-after-copy-or-kill-function ()
+ "Do allout-widgets processing of text just placed in the kill ring.
+
+Intended for use on allout-after-copy-or-kill-hook."
+ (if (car kill-ring)
+ (setcar kill-ring (allout-widgets-undecorate-text (car kill-ring)))))
+
+;;;_ > allout-widgets-exposure-undo-recorder (widget from-state)
+(defun allout-widgets-exposure-undo-recorder (widget)
+ "Record outline exposure undo for tracking during post-command processing.
+
+Intended for use by `allout-graphics-modification-handler'.
+
+WIDGET is the widget being changed.
+
+Records changes in `allout-widgets-changes-record'."
+ ;; disregard the events if we're currently processing them.
+ (if (not allout-undo-exposure-in-progress)
+ (push widget allout-widgets-undo-exposure-record)))
+;;;_ > allout-widgets-exposure-undo-processor ()
+(defun allout-widgets-exposure-undo-processor ()
+ "Adjust items tracking undo of allout outline structure exposure.
+
+Dispatched by `allout-widgets-post-command-business' in response to
+:undone-exposure entries recorded by `allout-widgets-exposure-undo-recorder'."
+ (let* ((allout-undo-exposure-in-progress t)
+ ;; inhibit undo recording while twiddling exposure to track undo:
+ (widgets allout-widgets-undo-exposure-record)
+ widget widget-start-marker widget-end-marker
+ from-state icon-start-point to-state
+ handled covered)
+ (setq allout-widgets-undo-exposure-record nil)
+ (save-excursion
+ (dolist (widget widgets)
+ (setq widget-start-marker (widget-get widget :from)
+ widget-end-marker (widget-get widget :to)
+ from-state (widget-get widget :icon-state)
+ icon-start-point (widget-apply widget :actual-position
+ :icon-start)
+ to-state (get-text-property icon-start-point
+ :icon-state))
+ (setq handled (allout-range-overlaps widget-start-marker
+ widget-end-marker
+ handled)
+ covered (car handled)
+ handled (cadr handled))
+ (when (not covered)
+ (goto-char (widget-get widget :from))
+ (when (not (allout-hidden-p))
+ ;; adjust actual exposure to that of to-state viz from-state
+ (cond ((and (eq to-state 'closed) (eq from-state 'opened))
+ (allout-hide-current-subtree)
+ (allout-decorate-item-and-context widget))
+ ((and (eq to-state 'opened) (eq from-state 'closed))
+ (save-excursion
+ (dolist
+ (expose-to (allout-chart-exposure-contour-by-icon))
+ (goto-char expose-to)
+ (allout-show-to-offshoot)))))))))))
+;;;_ > allout-chart-exposure-contour-by-icon (&optional from-depth)
+(defun allout-chart-exposure-contour-by-icon (&optional from-depth)
+ "Return points of subtree items to which exposure should be extended.
+
+The qualifying items are ones with a widget icon that is in the closed or
+empty state, or items with undecorated subitems.
+
+The resulting list of points is in reverse order.
+
+Optional FROM-DEPTH is for internal use."
+ ;; During internal recursion, we return a pair: (at-end . result)
+ ;; Otherwise we just return the result.
+ (let ((from-depth from-depth)
+ start-point
+ at-end level-depth
+ this-widget
+ got subgot)
+ (if from-depth
+ (setq level-depth (allout-depth))
+ ;; at containing item:
+ (setq start-point (point))
+ (setq from-depth (allout-depth))
+ (setq at-end (not (allout-next-heading))
+ level-depth allout-recent-depth))
+
+ ;; traverse the level, recursing on deeper levels:
+ (while (and (not at-end)
+ (> allout-recent-depth from-depth)
+ (setq this-widget (allout-get-item-widget)))
+ (if (< level-depth allout-recent-depth)
+ ;; recurse:
+ (progn
+ (setq subgot (allout-chart-exposure-contour-by-icon level-depth)
+ at-end (car subgot)
+ subgot (cdr subgot))
+ (if subgot (setq got (append subgot got))))
+ ;; progress at this level:
+ (when (memq (widget-get this-widget :icon-state) '(closed empty))
+ (push (point) got)
+ (allout-end-of-subtree))
+ (setq at-end (not (allout-next-heading)))))
+
+ ;; tailor result depending on whether or not we're a recursion:
+ (if (not start-point)
+ (cons at-end got)
+ (goto-char start-point)
+ got)))
+;;;_ > allout-range-overlaps (from to ranges)
+(defun allout-range-overlaps (from to ranges)
+ "Return a pair indicating overlap of FROM and TO subtree range in RANGES.
+
+First element of result indicates whether candadate range FROM, TO
+overlapped any of the existing ranges.
+
+Second element of result is a new version of RANGES incorporating the
+candidate range with overlaps consolidated.
+
+FROM and TO must be in increasing order, as must be the pairs in RANGES."
+ ;; to append to the end: (rplacd next-to-last-cdr (list 'f))
+ (let (new-ranges
+ entry
+ ;; the start of the range that includes the candidate from:
+ included-from
+ ;; the end of the range that includes the candidate to:
+ included-to
+ ;; the candidates were inserted:
+ done)
+ (while (and ranges (not done))
+ (setq entry (car ranges)
+ ranges (cdr ranges))
+
+ (cond
+
+ (included-from
+ ;; some entry included the candidate from.
+ (cond ((> (car entry) to)
+ ;; current entry exceeds end of candidate range - done.
+ (push (list included-from to) new-ranges)
+ (push entry new-ranges)
+ (setq included-to to
+ done t))
+ ((>= (cadr entry) to)
+ ;; current entry includes end of candidate range - done.
+ (push (list included-from (cadr entry)) new-ranges)
+ (setq included-to (cadr entry)
+ done t))
+ ;; current entry contained in candidate range - ditch, continue:
+ (t nil)))
+
+ ((> (car entry) to)
+ ;; current entry start exceeds candidate end - done, placed as new entry
+ (push (list from to) new-ranges)
+ (push entry new-ranges)
+ (setq included-to to
+ done t))
+
+ ((>= (car entry) from)
+ ;; current entry start is above candidate start, but not above
+ ;; candidate end (by prior case).
+ (setq included-from from)
+ ;; now we have to check on whether this entry contains to, or continue:
+ (when (>= (cadr entry) to)
+ ;; current entry contains only candidate end - done:
+ (push (list included-from (cadr entry)) new-ranges)
+ (setq included-to (cadr entry)
+ done t))
+ ;; otherwise, we will continue to look for placement of candidate end.
+ )
+
+ ((>= (cadr entry) to)
+ ;; current entry properly contains candidate range.
+ (push entry new-ranges)
+ (setq included-from (car entry)
+ included-to (cadr entry)
+ done t))
+
+ ((>= (cadr entry) from)
+ ;; current entry contains start of candidate range.
+ (setq included-from (car entry)))
+
+ (t
+ ;; current entry is below the candidate range.
+ (push entry new-ranges))))
+
+ (cond ((and included-from included-to)
+ ;; candidates placed.
+ nil)
+ ((not (or included-from included-to))
+ ;; candidates found no place, must be at the end:
+ (push (list from to) new-ranges))
+ (included-from
+ ;; candidate start placed but end not:
+ (push (list included-from to) new-ranges))
+ ;; might be included-to and not included-from, indicating new entry.
+ )
+ (setq new-ranges (nreverse new-ranges))
+ (if ranges (setq new-ranges (append new-ranges ranges)))
+ (list (if included-from t) new-ranges)))
+;;;_ > allout-test-range-overlaps ()
+(defun allout-test-range-overlaps ()
+ "allout-range-overlaps unit tests."
+ (let* (ranges
+ got
+ (try (lambda (from to)
+ (setq got (allout-range-overlaps from to ranges))
+ (setq ranges (cadr got))
+ got)))
+;; ;; biggie:
+;; (setq ranges nil)
+;; ;; ~ .02 to .1 seconds for just repeated listing args instead of funcall
+;; ;; ~ 13 seconds for doing repeated funcall
+;; (message "time-trial: %s, resulting size %s"
+;; (time-trial
+;; '(let ((size 10000)
+;; doing)
+;; (random t)
+;; (dotimes (count size)
+;; (setq doing (random size))
+;; (funcall try doing (+ doing (random 5)))
+;; ;;(list doing (+ doing (random 5)))
+;; )))
+;; (length ranges))
+;; (sit-for 2)
+
+ ;; fresh:
+ (setq ranges nil)
+ (assert (equal (funcall try 3 5) '(nil ((3 5)))))
+ ;; add range at end:
+ (assert (equal (funcall try 10 12) '(nil ((3 5) (10 12)))))
+ ;; add range at beginning:
+ (assert (equal (funcall try 1 2) '(nil ((1 2) (3 5) (10 12)))))
+ ;; insert range somewhere in the middle:
+ (assert (equal (funcall try 7 9) '(nil ((1 2) (3 5) (7 9) (10 12)))))
+ ;; consolidate some:
+ (assert (equal (funcall try 5 8) '(t ((1 2) (3 9) (10 12)))))
+ ;; add more:
+ (assert (equal (funcall try 15 17) '(nil ((1 2) (3 9) (10 12) (15 17)))))
+ ;; add more:
+ (assert (equal (funcall try 20 22)
+ '(nil ((1 2) (3 9) (10 12) (15 17) (20 22)))))
+ ;; encompass more:
+ (assert (equal (funcall try 4 11) '(t ((1 2) (3 12) (15 17) (20 22)))))
+ ;; encompass all:
+ (assert (equal (funcall try 2 25) '(t ((1 25)))))
+
+ ;; fresh slate:
+ (setq ranges nil)
+ (assert (equal (funcall try 20 25) '(nil ((20 25)))))
+ (assert (equal (funcall try 30 35) '(nil ((20 25) (30 35)))))
+ (assert (equal (funcall try 26 28) '(nil ((20 25) (26 28) (30 35)))))
+ (assert (equal (funcall try 15 20) '(t ((15 25) (26 28) (30 35)))))
+ (assert (equal (funcall try 10 30) '(t ((10 35)))))
+ (assert (equal (funcall try 5 6) '(nil ((5 6) (10 35)))))
+ (assert (equal (funcall try 2 100) '(t ((2 100)))))
+
+ (setq ranges nil)
+ ))
+;;;_ > allout-widgetize-buffer (&optional doing)
+(defun allout-widgetize-buffer (&optional doing)
+ "EXAMPLE FUNCTION. Widgetize items in buffer using allout-chart-subtree.
+
+We economize by just focusing on the first of local-maximum depth siblings.
+
+Optional DOING is for internal use - a chart of the current level, for
+recursive operation."
+
+ (interactive)
+ (if (not doing)
+
+ (save-excursion
+ (goto-char (point-min))
+ ;; Construct the chart by scanning the siblings:
+ (dolist (top-level-sibling (allout-chart-siblings))
+ (goto-char top-level-sibling)
+ (let ((subchart (allout-chart-subtree)))
+ (if subchart
+ (allout-widgetize-buffer subchart)))))
+
+ ;; save-excursion was done on recursion entry, not necessary here.
+ (let (have-sublists)
+ (dolist (sibling doing)
+ (when (listp sibling)
+ (setq have-sublists t)
+ (allout-widgetize-buffer sibling)))
+ (when (and (not have-sublists) (not (widget-at (car doing))))
+ (goto-char (car doing))
+ (allout-get-or-create-item-widget)))))
+
+;;;_ : Item widget and constructors
+
+;;;_ $ allout-item-widget
+(define-widget 'allout-item-widget 'default
+ "A widget presenting an allout outline item."
+
+ 'button nil
+ ;; widget-field-at respects this to get item if 'field is unused.
+ ;; we don't use field to avoid collision with end-of-line, etc, on which
+ ;; allout depends.
+ 'real-field nil
+
+ ;; data fields:
+
+
+ ;; tailor the widget for a specific item
+ :create 'allout-decorate-item-and-context
+ :value-delete 'allout-widgets-undecorate-item
+ ;; Not Yet Converted (from original, tree-widget stab)
+ :expander 'allout-tree-event-dispatcher ; get children when nil :args
+ :expander-p 'identity ; always engage the :expander
+ :action 'allout-tree-widget-action
+ ;; :notify "when item changes"
+
+ ;; force decoration of item but not context, unless already done this tick:
+ :redecorate 'allout-redecorate-item
+ :last-decorated-tick nil
+ ;; recognize the actual situation of the item's text:
+ :parse-item 'allout-parse-item-at-point
+ ;; decorate the entirety of the item, sans offspring:
+ :decorate-item-span 'allout-decorate-item-span
+ ;; decorate the various item elements:
+ :decorate-guides 'allout-decorate-item-guides
+ :decorate-icon 'allout-decorate-item-icon
+ :decorate-cue 'allout-decorate-item-cue
+ :decorate-body 'allout-decorate-item-body
+ :actual-position 'allout-item-actual-position
+
+ ;; Layout parameters:
+ :is-container nil ; is this actually the encompassing file/connection?
+
+ :from nil ; item beginning - marker
+ :to nil ; item end - marker
+ :span-overlay nil ; overlay by which actual postion is determined
+
+ ;; also serves as guide-end:
+ :icon-start nil
+ :icon-end nil
+ :distinctive-start nil
+ ;; also serves as cue-start:
+ :distinctive-end nil
+ ;; also serves as cue-end:
+ :body-start nil
+ :body-end nil
+ :depth nil
+ :has-subitems nil
+ :was-has-subitems 'init
+ :expanded nil
+ :was-expanded 'init
+ :brief nil
+ :was-brief 'init
+
+ :does-encrypt nil ; pending encryption when :is-encrypted false.
+ :is-encrypted nil
+
+ ;; the actual location of the item text:
+ :location 'allout-item-location
+
+ :button-keymap allout-item-icon-keymap ; XEmacs
+ :keymap allout-item-icon-keymap ; Emacs
+
+ ;; Element regions:
+ :guides-span nil
+ :icon-span nil
+ :cue-span nil
+ :bullet nil
+ :was-bullet nil
+ :body-span nil
+
+ :body-brevity-p 'allout-body-brevity-p
+
+ ;; :guide-column-flags indicate (in reverse order) whether or not the
+ ;; item's ancestor at the depth corresponding to the column has a
+ ;; subsequent sibling - ie, whether or not the corresponding column needs
+ ;; a descender line to connect that ancestor with its sibling.
+ :guide-column-flags nil
+ :was-guide-column-flags 'init
+
+ ;; ie, has subitems:
+ :populous-p 'allout-item-populous-p
+ :help-echo 'allout-tree-widget-help-echo
+ )
+;;;_ > allout-new-item-widget ()
+(defsubst allout-new-item-widget ()
+ "create a new item widget, not yet situated anywhere."
+ (if allout-widgets-maintain-tally
+ ;; all the extra overhead is incurred only when doing the
+ ;; maintenance, except the condition, which can't be avoided.
+ (let ((widget (widget-convert 'allout-item-widget)))
+ (puthash widget nil allout-widgets-tally)
+ widget)
+ (widget-convert 'allout-item-widget)))
+;;;_ : Item decoration
+;;;_ > allout-decorate-item-and-context (item-widget &optional redecorate
+;;; blank-container parent)
+(defun allout-decorate-item-and-context (item-widget &optional redecorate
+ blank-container parent)
+ "Create or adjust widget decorations for ITEM-WIDGET and neighbors at point.
+
+The neighbors include its siblings and parent.
+
+ITEM-WIDGET can be a created or converted allout-item-widget.
+
+If you're only trying to get or create a widget for an item, use
+`allout-get-or-create-item-widget'. If you have the item-widget, applying
+:redecorate will do the right thing.
+
+Optional BLANK-CONTAINER is for internal use. It is used to fabricate a
+container widget for an empty-bodied container, in the course of decorating
+a proper \(non-container\) item which starts at the beginning of the file.
+
+Optional REDECORATE causes redecoration of the item-widget and
+its siblings, even if already decorated in this cycle of the command loop.
+
+Optional PARENT, when provided, bypasses some navigation and computation
+necessary to obtain the parent of the items being processed.
+
+We return the item-widget corresponding to the item at point."
+
+ (when (or redecorate
+ (not (equal (widget-get item-widget :last-decorated-tick)
+ allout-command-counter)))
+ (let* ((allout-inhibit-body-modification-hook t)
+ (was-modified (buffer-modified-p))
+ (was-point (point))
+ prefix-start
+ (is-container (or blank-container
+ (not (setq prefix-start (allout-goto-prefix)))
+ (< was-point prefix-start)))
+ ;; steady-point (set in two steps) is reliable across parent
+ ;; widget-creation.
+ (steady-point (progn (if is-container (goto-char 1))
+ (point-marker)))
+ (steady-point (progn (set-marker-insertion-type steady-point t)
+ steady-point))
+ (parent (and (not is-container)
+ (allout-get-or-create-parent-widget)))
+ parent-flags parent-depth
+ successor-sibling
+ body
+ doing-item
+ sub-item-widget
+ depth
+ reverse-siblings-chart
+ (buffer-undo-list t))
+
+ ;; At this point the parent is decorated and parent-flags indicate
+ ;; its guide lines. We will iterate over the siblings according to a
+ ;; chart we create at the start, and going from last to first so we
+ ;; don't have to worry about text displacement caused by widgetizing.
+
+ (if is-container
+ (progn (widget-put item-widget :is-container t)
+ (setq reverse-siblings-chart (list 1)))
+ (goto-char (widget-apply parent :actual-position :from))
+ (if (widget-get parent :is-container)
+ ;; `allout-goto-prefix' will go to first non-container item:
+ (allout-goto-prefix)
+ (allout-next-heading))
+ (setq depth (allout-recent-depth))
+ (setq reverse-siblings-chart (list allout-recent-prefix-beginning))
+ (while (allout-next-sibling)
+ (push allout-recent-prefix-beginning reverse-siblings-chart)))
+
+ (dolist (doing-at reverse-siblings-chart)
+ (goto-char doing-at)
+ (when allout-widgets-track-decoration
+ (sit-for 0))
+
+ (setq doing-item (if (= doing-at steady-point)
+ item-widget
+ (or (allout-get-item-widget)
+ (allout-new-item-widget))))
+
+ (when (or redecorate (not (equal (widget-get doing-item
+ :last-decorated-tick)
+ allout-command-counter)))
+ (widget-apply doing-item :parse-item t blank-container)
+ (widget-apply doing-item :decorate-item-span)
+
+ (widget-apply doing-item :decorate-guides
+ parent (and successor-sibling t))
+ (widget-apply doing-item :decorate-icon)
+ (widget-apply doing-item :decorate-cue)
+ (widget-apply doing-item :decorate-body)
+
+ (widget-put doing-item :last-decorated-tick allout-command-counter))
+
+ (setq successor-sibling doing-at))
+
+ (set-buffer-modified-p was-modified)
+ (goto-char steady-point)
+ ;; must null the marker or the buffer gets clogged with impedence:
+ (set-marker steady-point nil)
+
+ item-widget)))
+;;;_ > allout-redecorate-item (item)
+(defun allout-redecorate-item (item-widget)
+ "Resituate ITEM-WIDGET decorations, disregarding context.
+
+Use this to redecorate only the item, when you know that it's
+situation with respect to siblings, parent, and offspring is
+unchanged from its last decoration. Use
+`allout-decorate-item-and-context' instead to reassess and adjust
+relevent context, when suitable."
+ (if (not (equal (widget-get item-widget :last-decorated-tick)
+ allout-command-counter))
+ (let ((was-modified (buffer-modified-p))
+ (buffer-undo-list t))
+ (widget-apply item-widget :parse-item)
+ (widget-apply item-widget :decorate-guides)
+ (widget-apply item-widget :decorate-icon)
+ (widget-apply item-widget :decorate-cue)
+ (widget-apply item-widget :decorate-body)
+ (set-buffer-modified-p was-modified))))
+;;;_ > allout-redecorate-visible-subtree (&optional parent-widget
+;;; depth chart)
+(defun allout-redecorate-visible-subtree (&optional parent-widget depth chart)
+ "Redecorate all visible items in subtree at point.
+
+Optional PARENT-WIDGET is for optimization, when the parent
+widget is already available.
+
+Optional DEPTH restricts the excursion depth of covered.
+
+Optional CHART is for internal recursion, to carry a chart of the
+target items.
+
+Point is left at the last sibling in the visible subtree."
+ ;; using a treatment that takes care of all the siblings on a level, we
+ ;; only need apply it to the first sibling on the level, and we can
+ ;; collect and pass the parent of the lower levels to recursive calls as
+ ;; we go.
+ (let ((parent-widget
+ (if (and parent-widget (widget-apply parent-widget
+ :actual-position :from))
+ (progn (goto-char (widget-apply parent-widget
+ :actual-position :from))
+ parent-widget)
+ (let ((got (allout-get-item-widget)))
+ (if got
+ (allout-decorate-item-and-context got 'redecorate)
+ (allout-get-or-create-item-widget 'redecorate)))))
+ (pending-chart (or chart (allout-chart-subtree nil 'visible)))
+ item-widget
+ previous-sibling-point
+ previous-sibling
+ recent-sibling-point)
+ (setq pending-chart (nreverse pending-chart))
+ (dolist (sibling-point pending-chart)
+ (cond ((integerp sibling-point)
+ (when (not previous-sibling-point)
+ (goto-char sibling-point)
+ (if (setq item-widget (allout-get-item-widget nil))
+ (allout-decorate-item-and-context item-widget 'redecorate
+ nil parent-widget)
+ (allout-get-or-create-item-widget)))
+ (setq previous-sibling-point sibling-point
+ recent-sibling-point sibling-point))
+ ((listp sibling-point)
+ (if (or (not depth)
+ (> depth 1))
+ (allout-redecorate-visible-subtree
+ (if (not previous-sibling-point)
+ ;; containment discontinuity - sigh
+ parent-widget
+ (allout-get-or-create-item-widget 'redecorate))
+ (if depth (1- depth))
+ sibling-point)))))
+ (if (and recent-sibling-point (< (point) recent-sibling-point))
+ (goto-char recent-sibling-point))))
+;;;_ > allout-parse-item-at-point (item-widget &optional at-beginning
+;;; blank-container)
+(defun allout-parse-item-at-point (item-widget &optional at-beginning
+ blank-container)
+ "Set widget ITEM-WIDGET layout parameters per item-at-point's actual layout.
+
+If optional AT-BEGINNING is t, then point is assumed to be at the start of
+the item prefix.
+
+If optional BLANK-CONTAINER is true, then the parameters of a container
+which has an empty body are set. \(Though the body is blank, the object
+may have subitems.\)"
+
+ ;; Uncomment this sit-for to notice where decoration is happening:
+;; (sit-for .1)
+ (let* ((depth (allout-depth))
+ (depth (if blank-container 0 depth))
+ (is-container (or blank-container (zerop depth)))
+
+ (does-encrypt (and (not is-container)
+ (allout-encrypted-type-prefix)))
+ (is-encrypted (and does-encrypt (allout-encrypted-topic-p)))
+ (icon-end allout-recent-prefix-end)
+ (icon-start (1- icon-end))
+ body-start
+ body-end
+ bullet
+ has-subitems
+ (contents-depth (1+ depth))
+ )
+ (widget-put item-widget :depth depth)
+ (if is-container
+
+ (progn
+ (widget-put item-widget :from (allout-set-boundary-marker
+ :from (point-min)
+ (widget-get item-widget :from)))
+ (widget-put item-widget :icon-end nil)
+ (widget-put item-widget :icon-start nil)
+ (setq body-start (widget-put item-widget :body-start 1)))
+
+ ;; not container:
+
+ (widget-put item-widget :from (allout-set-boundary-marker
+ :from (if at-beginning
+ (point)
+ allout-recent-prefix-beginning)
+ (widget-get item-widget :from)))
+ (widget-put item-widget :icon-start icon-start)
+ (widget-put item-widget :icon-end icon-end)
+ (when does-encrypt
+ (widget-put item-widget :does-encrypt t)
+ (widget-put item-widget :is-encrypted is-encrypted))
+
+ ;; cue area:
+ (setq body-start icon-end)
+ (widget-put item-widget :bullet (setq bullet (allout-get-bullet)))
+ (if (equal (char-after body-start) ? )
+ (setq body-start (1+ body-start)))
+ (widget-put item-widget :body-start body-start)
+ )
+
+ ;; Both container and regular items:
+
+ ;; :body-end (doesn't include a trailing blank line, if any) -
+ (widget-put item-widget :body-end (setq body-end
+ (if blank-container
+ 1
+ (allout-end-of-entry))))
+
+ (widget-put item-widget :to (allout-set-boundary-marker
+ :to (if blank-container
+ (point-min)
+ (or (allout-pre-next-prefix)
+ (goto-char (point-max))))
+ (widget-get item-widget :to)))
+ (widget-put item-widget :has-subitems
+ (setq has-subitems
+ (and
+ ;; has a subsequent item:
+ (not (= body-end (point-max)))
+ ;; subsequent item is deeper:
+ (< depth (setq contents-depth (allout-recent-depth))))))
+ ;; note :expanded - true if widget item's content is currently visible?
+ (widget-put item-widget :expanded
+ (and has-subitems
+ ;; subsequent item is or isn't visible:
+ (save-excursion
+ (goto-char allout-recent-prefix-beginning)
+ (not (allout-hidden-p)))))))
+;;;_ > allout-set-boundary-marker (boundary position &optional current-marker)
+(defun allout-set-boundary-marker (boundary position &optional current-marker)
+ "Set or create item widget BOUNDARY type marker at POSITION.
+
+Optional CURRENT-MARKER is the marker currently being used for
+the boundary, if any.
+
+BOUNDARY type is either :from or :to, determining the marker insertion type."
+ (if (not position) (setq position (point)))
+ (if current-marker
+ (set-marker current-marker position)
+ (let ((marker (make-marker)))
+ ;; XXX dang - would like for :from boundary to advance after inserted
+ ;; text, but that would omit new header prefixes when allout
+ ;; relevels, etc. this competes with ad-hoc edits, which would
+ ;; better be omitted
+ (set-marker-insertion-type marker nil)
+ (set-marker marker position))))
+;;;_ > allout-decorate-item-span (item-widget)
+(defun allout-decorate-item-span (item-widget)
+ "Equip the item with a span, as an entirety.
+
+This span is implemented so it can be used to detect displacement
+of the widget in absolute terms, and provides an offset bias for
+the various element spans."
+
+ (if (and (widget-get item-widget :is-container)
+ ;; the only case where the span could be empty.
+ (eq (widget-get item-widget :from)
+ (widget-get item-widget :to)))
+ nil
+ (allout-item-span item-widget
+ (widget-get item-widget :from)
+ (widget-get item-widget :to))))
+;;;_ > allout-decorate-item-guides (item-widget
+;;; &optional parent-widget has-successor)
+(defun allout-decorate-item-guides (item-widget
+ &optional parent-widget has-successor)
+ "Add ITEM-WIDGET guide icon-prefix descender and connector text properties.
+
+Optional arguments provide context for deriving the guides. In
+their absence, the current guide column flags are used.
+
+Optional PARENT-WIDGET is the widget for the item's parent item.
+
+Optional HAS-SUCCESSOR is true iff the item is followed by a sibling.
+
+We also hide the header-prefix string.
+
+Guides are established according to the item-widget's :guide-column-flags,
+when different than :was-guide-column-flags. Changing that property and
+reapplying this method will rectify the glyphs."
+
+ (when (not (widget-get item-widget :is-container))
+ (let* ((depth (widget-get item-widget :depth))
+ (parent-depth (and parent-widget
+ (widget-get parent-widget :depth)))
+ (parent-flags (and parent-widget
+ (widget-get parent-widget :guide-column-flags)))
+ (parent-flags-depth (length parent-flags))
+ (extender-length (- depth (+ parent-flags-depth 2)))
+ (flags (or (and (> depth 1)
+ parent-widget
+ (widget-put item-widget :guide-column-flags
+ (append (list has-successor)
+ (if (< 0 extender-length)
+ (make-list extender-length
+ '-))
+ parent-flags)))
+ (widget-get item-widget :guide-column-flags)))
+ (was-flags (widget-get item-widget :was-guide-column-flags))
+ (guides-start (widget-get item-widget :from))
+ (guides-end (widget-get item-widget :icon-start))
+ (position guides-start)
+ (increment (length allout-header-prefix))
+ reverse-flags
+ guide-name
+ extenders paint-extenders
+ (inhibit-read-only t))
+
+ (when (not (equal was-flags flags))
+
+ (setq reverse-flags (reverse flags))
+ (while reverse-flags
+ (setq guide-name
+ (cond ((null (cdr reverse-flags))
+ (if (car reverse-flags)
+ 'mid-connector
+ 'end-connector))
+ ((eq (car reverse-flags) '-)
+ ;; accumulate extenders tally, to be painted on next
+ ;; non-extender flag, according to the flag type.
+ (setq extenders (1+ (or extenders 0)))
+ nil)
+ ((car reverse-flags)
+ 'through-descender)
+ (t 'skip-descender)))
+ (when guide-name
+ (put-text-property position (setq position (+ position increment))
+ 'display (allout-fetch-icon-image guide-name))
+ (if (> increment 1) (setq increment 1))
+ (when extenders
+ ;; paint extenders after a connector, else leave spaces.
+ (dotimes (i extenders)
+ (put-text-property
+ position (setq position (1+ position))
+ 'display (allout-fetch-icon-image
+ (if (memq guide-name '(mid-connector end-connector))
+ 'extender-connector
+ 'skip-descender))))
+ (setq extenders nil)))
+ (setq reverse-flags (cdr reverse-flags)))
+ (widget-put item-widget :was-guide-column-flags flags))
+
+ (allout-item-element-span-is item-widget :guides-span
+ guides-start guides-end))))
+;;;_ > allout-decorate-item-icon (item-widget)
+(defun allout-decorate-item-icon (item-widget)
+ "Add item icon glyph and distinctive bullet text properties to ITEM-WIDGET."
+
+ (when (not (widget-get item-widget :is-container))
+ (let* ((icon-start (widget-get item-widget :icon-start))
+ (icon-end (widget-get item-widget :icon-end))
+ (bullet (widget-get item-widget :bullet))
+ (use-bullet bullet)
+ (was-bullet (widget-get item-widget :was-bullet))
+ (distinctive (allout-distinctive-bullet bullet))
+ (distinctive-start (widget-get item-widget :distinctive-start))
+ (distinctive-end (widget-get item-widget :distinctive-end))
+ (does-encrypt (widget-get item-widget :does-encrypt))
+ (is-encrypted (and does-encrypt (widget-get item-widget
+ :is-encrypted)))
+ (expanded (widget-get item-widget :expanded))
+ (has-subitems (widget-get item-widget :has-subitems))
+ (inhibit-read-only t)
+ icon-state)
+
+ (when (not (and (equal (widget-get item-widget :was-expanded) expanded)
+ (equal (widget-get item-widget :was-has-subitems)
+ has-subitems)
+ (equal (widget-get item-widget :was-does-encrypt)
+ does-encrypt)
+ (equal (widget-get item-widget :was-is-encrypted)
+ is-encrypted)))
+
+ (setq icon-state
+ (cond (does-encrypt (if is-encrypted
+ 'locked-encrypted
+ 'unlocked-encrypted))
+ (expanded 'opened)
+ (has-subitems 'closed)
+ (t 'empty)))
+ (put-text-property icon-start (1+ icon-start)
+ 'display (allout-fetch-icon-image icon-state))
+ (widget-put item-widget :was-expanded expanded)
+ (widget-put item-widget :was-has-subitems has-subitems)
+ (widget-put item-widget :was-does-encrypt does-encrypt)
+ (widget-put item-widget :was-is-encrypted is-encrypted)
+ ;; preserve as a widget property to track last known:
+ (widget-put item-widget :icon-state icon-state)
+ ;; preserve as a text property to track undo:
+ (put-text-property icon-start icon-end :icon-state icon-state))
+ (allout-item-element-span-is item-widget :icon-span
+ icon-start icon-end)
+ (when (not (string= was-bullet bullet))
+ (cond ((not distinctive)
+ ;; XXX we strip the prior properties without even checking if
+ ;; the prior bullet was distinctive, because the widget
+ ;; provisions to convey that info is disappearing, sigh.
+ (remove-text-properties icon-end (1+ icon-end) '(display))
+ (setq distinctive-start icon-end distinctive-end icon-end)
+ (widget-put item-widget :distinctive-start distinctive-start)
+ (widget-put item-widget :distinctive-end distinctive-end))
+
+ ((not (string= bullet allout-numbered-bullet))
+ (setq distinctive-start icon-end distinctive-end (+ icon-end 1)))
+
+ (does-encrypt
+ (setq distinctive-start icon-end distinctive-end (+ icon-end 1)))
+
+ (t
+ (goto-char icon-end)
+ (looking-at "[0-9]+")
+ (setq use-bullet (buffer-substring icon-end (match-end 0)))
+ (setq distinctive-start icon-end
+ distinctive-end (match-end 0))))
+ (put-text-property distinctive-start distinctive-end 'display
+ use-bullet)
+ (widget-put item-widget :was-bullet bullet)
+ (widget-put item-widget :distinctive-start distinctive-start)
+ (widget-put item-widget :distinctive-end distinctive-end)))))
+;;;_ > allout-decorate-item-cue (item-widget)
+(defun allout-decorate-item-cue (item-widget)
+ "Incorporate space between bullet icon and body to the ITEM-WIDGET."
+ ;; NOTE: most of the cue-area
+
+ (when (not (widget-get item-widget :is-container))
+ (let* ((cue-start (or (widget-get item-widget :distinctive-end)
+ (widget-get item-widget :icon-end)))
+ (body-start (widget-get item-widget :body-start))
+ (expanded (widget-get item-widget :expanded))
+ (has-subitems (widget-get item-widget :has-subitems))
+ (inhibit-read-only t))
+
+ (allout-item-element-span-is item-widget :cue-span cue-start body-start)
+ (put-text-property (1- body-start) body-start 'rear-nonsticky t))))
+;;;_ > allout-decorate-item-body (item-widget &optional force)
+(defun allout-decorate-item-body (item-widget &optional force)
+ "Incorporate item body text as part the ITEM-WIDGET.
+
+Optional FORCE means force reassignment of the region property."
+
+ (let* ((allout-inhibit-body-modification-hook t)
+ (body-start (widget-get item-widget :body-start))
+ (body-end (widget-get item-widget :body-end))
+ (body-text-end body-end)
+ (inhibit-read-only t))
+
+ (allout-item-element-span-is item-widget :body-span
+ body-start (min (1+ body-end) (point-max))
+ force)))
+;;;_ > allout-item-actual-position (item-widget field)
+(defun allout-item-actual-position (item-widget field)
+ "Return ITEM-WIDGET FIELD position taking item displacement into account."
+
+ ;; The item's sub-element positions (:icon-end, :body-start, etc) are
+ ;; accurate when the item is parsed, but some offsets from the start
+ ;; drift with text added in the body.
+ ;;
+ ;; Rather than reparse an item with every change (inefficient), or derive
+ ;; every position from a distinct field marker/overlay (prohibitive as
+ ;; the number of items grows), we use the displacement tracking of the
+ ;; :span-overlay's markers, against the registered :from or :body-end
+ ;; (depending on whether the requested field value is before or after the
+ ;; item body), to bias the registered values.
+ ;;
+ ;; This is not necessary/useful when the item is being decorated, because
+ ;; that always must be preceded by a fresh item parse.
+
+ (if (not (eq field :body-end))
+ (widget-get item-widget :from)
+
+ (let* ((span-overlay (widget-get item-widget :span-overlay))
+ (body-end-position (widget-get item-widget :body-end))
+ (ref-marker-position (and span-overlay
+ (overlay-end span-overlay)))
+ (offset (and body-end-position span-overlay
+ (- (or ref-marker-position 0)
+ body-end-position))))
+ (+ (widget-get item-widget field) (or offset 0)))))
+;;;_ : Item undecoration
+;;;_ > allout-widgets-undecorate-region (start end)
+(defun allout-widgets-undecorate-region (start end)
+ "Eliminate widgets and decorations for all items in region from START to END."
+ (let ((next start)
+ widget)
+ (save-excursion
+ (goto-char start)
+ (while (< (setq next (next-single-char-property-change next
+ 'display
+ (current-buffer)
+ end))
+ end)
+ (goto-char next)
+ (when (setq widget (allout-get-item-widget))
+ ;; if the next-property/overly progression got us to a widget:
+ (allout-widgets-undecorate-item widget t))))))
+;;;_ > allout-widgets-undecorate-text (text)
+(defun allout-widgets-undecorate-text (text)
+ "Eliminate widgets and decorations for all items in TEXT."
+ (remove-text-properties 0 (length text)
+ '(display nil :icon-state nil rear-nonsticky nil
+ category nil button nil field nil)
+ text)
+ text)
+;;;_ > allout-widgets-undecorate-item (item-widget &optional no-expose)
+(defun allout-widgets-undecorate-item (item-widget &optional no-expose)
+ "Remove widget decorations from ITEM-WIDGET.
+
+Any concealed content head lines and item body is exposed, unless
+optional NO-EXPOSE is non-nil."
+ (let ((from (widget-get item-widget :from))
+ (to (widget-get item-widget :to))
+ (text-properties-to-remove '(display nil
+ :icon-state nil
+ rear-nonsticky nil
+ category nil
+ button nil
+ field nil))
+ (span-overlay (widget-get item-widget :span-overlay))
+ (button-overlay (widget-get item-widget :button))
+ (was-modified (buffer-modified-p))
+ (buffer-undo-list t)
+ (inhibit-read-only t))
+ (if (not no-expose)
+ (allout-flag-region from to nil))
+ (allout-unprotected
+ (remove-text-properties from to text-properties-to-remove))
+ (when span-overlay
+ (delete-overlay span-overlay) (widget-put item-widget :span-overlay nil))
+ (when button-overlay
+ (delete-overlay button-overlay) (widget-put item-widget :button nil))
+ (set-marker from nil)
+ (set-marker to nil)
+ (if (not was-modified)
+ (set-buffer-modified-p nil))))
+
+;;;_ : Item decoration support
+;;;_ > allout-item-span (item-widget &optional start end)
+(defun allout-item-span (item-widget &optional start end)
+ "Return or register the location of an ITEM-WIDGET's actual START and END.
+
+If START and END are not passed in, return either a dotted pair
+of the current span, if established, or nil if not yet set.
+
+When the START and END are passed, return the distance that the
+start of the item moved. We return 0 if the span was not
+previously established or is not moved."
+ (let ((overlay (widget-get item-widget :span-overlay))
+ was-start was-end
+ changed)
+ (cond ((not overlay) (when start
+ (setq overlay (make-overlay start end nil t nil))
+ (overlay-put overlay 'button item-widget)
+ (overlay-put overlay 'evaporate t)
+ (widget-put item-widget :span-overlay overlay)
+ t))
+ ;; report:
+ ((not start) (cons (overlay-start overlay) (overlay-end overlay)))
+ ;; move:
+ ((or (not (equal (overlay-start overlay) start))
+ (not (equal (overlay-end overlay) end)))
+ (move-overlay overlay start end)
+ t)
+ ;; specified span already set:
+ (t nil))))
+;;;_ > allout-item-element-span-is (item-widget element
+;;; &optional start end force)
+(defun allout-item-element-span-is (item-widget element
+ &optional start end force)
+ "Return or register the location of the indicated ITEM-WIDGET ELEMENT.
+
+ELEMENT is one of :guides-span, :icon-span, :cue-span, or :body-span.
+
+When optional START is specified, optional END must also be.
+
+START and END are the actual bounds of the region, if provided.
+
+If START and END are not passed in, we return either a dotted
+pair of the current span, if established, or nil if not yet set.
+
+When the START and END are passed, we return t if the region
+changed or nil if not.
+
+Optional FORCE means force assignment of the region's text
+property, even if it's already set."
+ (let ((span (widget-get item-widget element)))
+ (cond ((or (not span) force)
+ (when start
+ (widget-put item-widget element (cons start end))
+ (put-text-property start end 'category
+ (cdr (assoc element
+ allout-span-to-category)))
+ t))
+ ;; report:
+ ((not start) span)
+ ;; move if necessary:
+ ((not (and (eq (car span) start)
+ (eq (cdr span) end)))
+ (widget-put item-widget element span)
+ t)
+ ;; specified span already set:
+ (t nil))))
+;;;_ : Item widget retrieval (/ high-level creation):
+;;;_ > allout-get-item-widget (&optional container)
+(defun allout-get-item-widget (&optional container)
+ "Return the widget for the item at point, or nil if no widget yet exists.
+
+Point must be situated *before* the start of the target item's
+body, so we don't get an existing containing item when we're in
+the process of creating an item in the middle of another.
+
+Optional CONTAINER is used to obtain the container item."
+ (if (or container (zerop (allout-depth)))
+ allout-container-item-widget
+ ;; allout-recent-* are calibrated by (allout-depth) if we got here.
+ (let ((got (widget-at allout-recent-prefix-beginning)))
+ (if (and got (listp got))
+ (if (marker-position (widget-get got :from))
+ (and
+ (>= (point) (widget-apply got :actual-position :from))
+ (<= (point) (widget-apply got :actual-position :body-start))
+ got)
+ ;; a wacky residual item - undecorate and disregard:
+ (allout-widgets-undecorate-item got)
+ nil)))))
+;;;_ > allout-get-or-create-item-widget (&optional redecorate blank-container)
+(defun allout-get-or-create-item-widget (&optional redecorate blank-container)
+ "Return a widget for the item at point, creating the widget if necessary.
+
+When creating a widget, we assume there has been a context change
+and decorate its siblings and parent, as well.
+
+Optional BLANK-CONTAINER is for internal use, to fabricate a
+meta-container item with an empty body when the first proper
+\(non-container\) item starts at the beginning of the file.
+
+Optional REDECORATE, if non-nil, means to redecorate the widget
+if it already exists."
+ (let ((widget (allout-get-item-widget blank-container))
+ (buffer-undo-list t))
+ (cond (widget (if redecorate
+ (allout-redecorate-item widget))
+ widget)
+ ((or blank-container (zerop (allout-depth)))
+ (or allout-container-item-widget
+ (setq allout-container-item-widget
+ (allout-decorate-item-and-context
+ (widget-convert 'allout-item-widget)
+ nil blank-container))))
+ ;; create a widget for a regular/non-container item:
+ (t (allout-decorate-item-and-context (widget-convert
+ 'allout-item-widget))))))
+;;;_ > allout-get-or-create-parent-widget (&optional redecorate)
+(defun allout-get-or-create-parent-widget (&optional redecorate)
+ "Return widget for parent of item at point, decorating it if necessary.
+
+We return the container widget if we're above the first proper item in the
+file.
+
+Optional REDECORATE, if non-nil, means to redecorate the widget if it
+already exists.
+
+Point will wind up positioned on the beginning of the parent or beginning
+of the buffer."
+ ;; use existing widget, if there, else establish it
+ (if (or (bobp) (and (not (allout-ascend))
+ (looking-at allout-regexp)))
+ (allout-get-or-create-item-widget redecorate 'blank-container)
+ (allout-get-or-create-item-widget redecorate)))
+;;;_ : X- Item ancillaries
+;;;_ >X allout-body-modification-handler (beg end)
+(defun allout-body-modification-handler (beg end)
+ "Do routine processing of body text before and after modification.
+
+Operation is inhibited by `allout-inhibit-body-modification-handler'."
+
+;; The primary duties are:
+;;
+;; - marking of escaped prefix-like text for delayed cleanup of escapes
+;; - removal and replacement of the settings
+;; - maintenance of beginning-of-line guide lines
+;;
+;; ?? Escapes removal \(before changes\) is not done when edits span multiple
+;; items, recognizing that item structure is being preserved, including
+;; escaping of item-prefix-like text within bodies. See
+;; `allout-before-modification-handler' and
+;; `allout-inhibit-body-modification-handler'.
+;;
+;; Adds the overlay to the `allout-unresolved-body-mod-workhash' during
+;; before-change operation, and removes from that list during after-change
+;; operation.
+ (cond (allout-inhibit-body-modification-hook nil)))
+;;;_ >X allout-graphics-modification-handler (beg end)
+(defun allout-graphics-modification-handler (beg end)
+ "Protect against incoherent deletion of decoration graphics.
+
+Deletes allowed only when inhibit-read-only is t."
+ (cond
+ (undo-in-progress (when (eq (get-text-property beg 'category)
+ 'allout-icon-span-category)
+ (save-excursion
+ (goto-char beg)
+ (let* ((item-widget (allout-get-item-widget)))
+ (if item-widget
+ (allout-widgets-exposure-undo-recorder
+ item-widget))))))
+ (inhibit-read-only t)
+ ((not (and (boundp 'allout-mode) allout-mode)) t)
+ ((equal this-command 'quoted-insert) t)
+ ((yes-or-no-p "Unruly edit of outline structure - allow? ")
+ (setq allout-widgets-unset-inhibit-read-only (not inhibit-read-only)
+ inhibit-read-only t))
+ (t (error
+ (substitute-command-keys allout-structure-unruly-deletion-message)))))
+;;;_ > allout-item-icon-key-handler ()
+(defun allout-item-icon-key-handler ()
+ "Catchall handling of key bindings in item icon/cue hot-spots.
+
+Applies `allout-hotspot-key-handler' and calls the result, if any, as an
+interactive command."
+
+ (interactive)
+ (let* ((mapped-binding (allout-hotspot-key-handler)))
+ (when mapped-binding
+ (call-interactively mapped-binding))))
+
+;;;_ : Status
+;;;_ . allout-item-location (item-widget)
+(defun allout-item-location (item-widget)
+ "Location of the start of the item's text."
+ (overlay-start (widget-get item-widget :span-overlay)))
+
+;;;_ : Icon management
+;;;_ > allout-fetch-icon-image (name)
+(defun allout-fetch-icon-image (name)
+ "Fetch allout icon for symbol NAME.
+
+We use a caching strategy, so the caller doesn't need to do so."
+ (let* ((types allout-widgets-icon-types)
+ (use-dir (if (equal (allout-frame-property nil 'background-mode)
+ 'light)
+ allout-widgets-icons-light-subdir
+ allout-widgets-icons-dark-subdir))
+ (key (list name use-dir))
+ (got (assoc key allout-widgets-icons-cache)))
+ (if got
+ ;; display system shows only first of subsequent adjacent
+ ;; `eq'-identical repeats - use copies to avoid this problem.
+ (allout-widgets-copy-list (cadr got))
+ (while (and types (not got))
+ (setq got
+ (allout-find-image
+ (list (append (list :type (car types)
+ :file (concat use-dir
+ (symbol-name name)
+ "." (symbol-name
+ (car types))))
+ (if (featurep 'xemacs)
+ allout-widgets-item-image-properties-xemacs
+ allout-widgets-item-image-properties-emacs)
+ ))))
+ (setq types (cdr types)))
+ (if got
+ (push (list key got) allout-widgets-icons-cache))
+ got)))
+
+;;;_ : Miscellaneous
+;;;_ > allout-elapsed-time-seconds (triple)
+(defun allout-elapsed-time-seconds (end start)
+ "Return seconds between `current-time' style time START/END triples."
+ (let ((elapsed (time-subtract end start)))
+ (+ (* (car elapsed) (expt 2.0 16))
+ (cadr elapsed)
+ (/ (caddr elapsed) (expt 10.0 6)))))
+;;;_ > allout-frame-property (frame property)
+(defalias 'allout-frame-property
+ (cond ((fboundp 'frame-parameter)
+ 'frame-parameter)
+ ((fboundp 'frame-property)
+ 'frame-property)
+ (t nil)))
+;;;_ > allout-find-image (specs)
+(defalias 'allout-find-image
+ (if (fboundp 'find-image)
+ 'find-image
+ nil) ; aka, not-yet-implemented for xemacs.
+)
+;;;_ > allout-widgets-copy-list (list)
+(defun allout-widgets-copy-list (list)
+ ;; duplicated from cl.el 'copy-list' as of 2008-08-17
+ "Return a copy of LIST, which may be a dotted list.
+The elements of LIST are not copied, just the list structure itself."
+ (if (consp list)
+ (let ((res nil))
+ (while (consp list) (push (pop list) res))
+ (prog1 (nreverse res) (setcdr res list)))
+ (car list)))
+;;;_ . allout-widgets-count-buttons-in-region (start end)
+(defun allout-widgets-count-buttons-in-region (start end)
+ "Debugging/diagnostic tool - count overlays with 'button' property in region."
+ (interactive "r")
+ (setq start (or start (point-min))
+ end (or end (point-max)))
+ (if (> start end) (let ((interim start)) (setq start end end interim)))
+ (let ((button-overlays (delq nil
+ (mapcar (function (lambda (o)
+ (if (overlay-get o 'button)
+ o)))
+ (overlays-in start end)))))
+ (length button-overlays)))
+
+;;;_ : Run unit tests:
+(defun allout-widgets-run-unit-tests ()
+ (message "Running allout-widget tests...")
+
+ (allout-test-range-overlaps)
+
+ (message "Running allout-widget tests... Done.")
+ (sit-for .5))
+
+(when allout-widgets-run-unit-tests-on-load
+ (allout-widgets-run-unit-tests))
+
+;;;_ : provide
+(provide 'allout-widgets)
+
+;;;_. Local emacs vars.
+;;;_ , Local variables:
+;;;_ , allout-layout: (-1 : 0)
+;;;_ , End:
diff --git a/lisp/allout.el b/lisp/allout.el
index d3867f0b64f..736ec42718b 100644
--- a/lisp/allout.el
+++ b/lisp/allout.el
@@ -1,13 +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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992-1994, 2001-2011 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
-;; Keywords: outlines wp languages
+;; Version: 2.3
+;; Keywords: outlines, wp, languages, PGP, GnuPG
;; Website: http://myriadicity.net/Sundry/EmacsAllout
;; This file is part of GNU Emacs.
@@ -40,12 +39,9 @@
;; emacs local file variables need to be enabled when the
;; file was visited -- see `enable-local-variables'.)
;; - Configurable per-file initial exposure settings
-;; - Symmetric-key and key-pair topic encryption, plus symmetric passphrase
-;; mnemonic support, with verification against an established passphrase
-;; (using a stashed encrypted dummy string) and user-supplied hint
-;; maintenance. (See allout-toggle-current-subtree-encryption docstring.
-;; Currently only GnuPG encryption is supported, and integration
-;; with gpg-agent is not yet implemented.)
+;; - Symmetric-key and key-pair topic encryption. Encryption is via the
+;; Emacs 'epg' library. See allout-toggle-current-subtree-encryption
+;; docstring.
;; - Automatic topic-number maintenance
;; - "Hot-spot" operation, for single-keystroke maneuvering and
;; exposure control (see the allout-mode docstring)
@@ -61,34 +57,30 @@
;; See the `allout-mode' function's docstring for an introduction to the
;; mode.
;;
-;; The latest development version and helpful notes are available at
-;; http://myriadicity.net/Sundry/EmacsAllout .
+;; Directions to the latest development version and helpful notes are
+;; available at http://myriadicity.net/Sundry/EmacsAllout .
;;
-;; The outline menubar additions provide quick reference to many of
-;; the features, and see the docstring of the variable `allout-init'
-;; for instructions on priming your Emacs session for automatic
-;; activation of allout-mode.
-;;
-;; See the docstring of the variables `allout-layout' and
+;; The outline menubar additions provide quick reference to many of the
+;; features. See the docstring of the variables `allout-layout' and
;; `allout-auto-activation' for details on automatic activation of
-;; `allout-mode' as a minor mode. (It has changed since allout
-;; 3.x, for those of you that depend on the old method.)
+;; `allout-mode' as a minor mode. (`allout-init' is deprecated in favor of
+;; a purely customization-based method.)
;;
;; Note -- the lines beginning with `;;;_' are outline topic headers.
-;; Just `ESC-x eval-buffer' to give it a whirl.
+;; Customize `allout-auto-activation' to enable, then revisit this
+;; buffer to give it a whirl.
;; ken manheimer (ken dot manheimer at gmail dot com)
;;; Code:
-;;;_* Dependency autoloads
+;;;_* Dependency loads
(require 'overlay)
(eval-when-compile
- ;; Most of the requires here are for stuff covered by autoloads.
- ;; Since just byte-compiling doesn't trigger autoloads, so that
- ;; "function not found" warnings would occur without these requires.
- (require 'pgg)
- (require 'pgg-gpg)
+ ;; Most of the requires here are for stuff covered by autoloads, which
+ ;; byte-compiling doesn't trigger.
+ (require 'epg)
+ (require 'epa)
(require 'overlay)
;; `cl' is required for `assert'. `assert' is not covered by a standard
;; autoload, but it is a macro, so that eval-when-compile is sufficient
@@ -98,102 +90,233 @@
;;;_* USER CUSTOMIZATION VARIABLES:
-;;;_ > defgroup allout
+;;;_ > defgroup allout, allout-keybindings
(defgroup allout nil
- "Extensive outline mode for use alone and with other modes."
+ "Extensive outline minor-mode, for use stand-alone and with other modes.
+
+See Allout Auto Activation for automatic activation."
: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
+
+;;;_ > allout-keybindings incidentals:
+;;;_ : internal key binding stuff - in this section for load-order.
+;;;_ = allout-mode-map
+(defvar allout-mode-map 'allout-mode-map
+ "Keybindings place-holder for (allout) outline minor mode.
+
+Do NOT set the value of this variable. Instead, customize
+`allout-command-prefix', `allout-prefixed-keybindings', and
+`allout-unprefixed-keybindings'.")
+;;;_ = allout-mode-map-value
+(defvar allout-mode-map-value nil
+ "Keymap for allout outline minor mode.
+
+Do NOT set the value of this variable. Instead, customize
+`allout-command-prefix', `allout-prefixed-keybindings', and
+`allout-unprefixed-keybindings'.")
+;;;_ = make allout-mode-map-value an alias for allout-mode-map:
+;; this needs to be revised when the value is changed, sigh.
+(defalias 'allout-mode-map allout-mode-map-value)
+;;;_ > allout-compose-and-institute-keymap (&optional varname value)
+(defun allout-compose-and-institute-keymap (&optional varname value)
+ "Create the allout keymap according to the keybinding specs, and set it.
+
+Useful standalone or to effect customizations of 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)))
+ (when (boundp 'allout-prefixed-keybindings)
+ ;; tolerate first definitions of the variables:
+ (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))))
+ (substitute-key-definition 'beginning-of-line 'allout-beginning-of-line
+ map global-map)
+ (substitute-key-definition 'move-beginning-of-line 'allout-beginning-of-line
+ map global-map)
+ (substitute-key-definition 'end-of-line 'allout-end-of-line
+ map global-map)
+ (substitute-key-definition 'move-end-of-line 'allout-end-of-line
+ map global-map)
+ (allout-institute-keymap map)))
+;;;_ > allout-institute-keymap (map)
+(defun allout-institute-keymap (map)
+ "Associate allout-mode bindings with allout as a minor mode."
+ ;; Architecture:
+ ;; allout-mode-map var is a keymap by virtue of being a defalias for
+ ;; allout-mode-map-value, which has the actual keymap value.
+ ;; allout-mode-map's symbol value is just 'allout-mode-map, so it can be
+ ;; used in minor-mode-map-alist to indirect to the actual
+ ;; allout-mode-map-var value, which can be adjusted and reassigned.
+
+ ;; allout-mode-map-value for keymap reference in various places:
+ (setq allout-mode-map-value map)
+ ;; the function value keymap of allout-mode-map is used in
+ ;; minor-mode-map-alist - update it:
+ (fset allout-mode-map allout-mode-map-value))
+;;;_ * intialize the mode map:
+;; ensure that allout-mode-map has some setting even if allout-mode hasn't
+;; been invoked:
+(allout-compose-and-institute-keymap)
+;;;_ = 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)
+ :group 'allout-keybindings
+ :set 'allout-compose-and-institute-keymap)
+;;;_ = 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 ?s)]" allout-show-current-subtree)
+ ("[(control ?t)]" allout-toggle-current-subtree-exposure)
+;; Let user customize if they want to preempt describe-prefix-bindings ^h use.
+;; ("[(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)
+ ("[(meta ?k)]" 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 modifiers, 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-compose-and-institute-keymap
+ )
+;;;_ = 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
+preceding 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 modifiers, eg: [(control ?a)]
+See the existing keys for examples."
+ :type 'allout-keybindings-binding
+ :group 'allout-keybindings
+ :set 'allout-compose-and-institute-keymap
+ )
+
+;;;_ > allout-auto-activation-helper (var value)
+;;;###autoload
+(defun allout-auto-activation-helper (var value)
+ "Institute `allout-auto-activation'.
+
+Intended to be used as the `allout-auto-activation' :set function."
+ (set-default var value)
+ (allout-setup))
+;;;_ > allout-setup ()
+;;;###autoload
+(defun allout-setup ()
+ "Do fundamental emacs session for allout auto-activation.
-;;;_ = allout-keybindings-list
-;;; You have to reactivate allout-mode -- `(allout-mode t)' -- to
-;;; institute changes to this var.
-(defvar allout-keybindings-list ()
- "*List of `allout-mode' key / function bindings, for `allout-mode-map'.
-String or vector key will be prefaced with `allout-command-prefix',
-unless optional third, non-nil element is present.")
-(setq allout-keybindings-list
- '(
- ; Motion commands:
- ("\C-n" allout-next-visible-heading)
- ("\C-p" allout-previous-visible-heading)
- ("\C-u" allout-up-current-level)
- ("\C-f" allout-forward-current-level)
- ("\C-b" allout-backward-current-level)
- ("\C-a" allout-beginning-of-current-entry)
- ("\C-e" allout-end-of-entry)
- ; Exposure commands:
- ("\C-i" allout-show-children)
- ("\C-s" allout-show-current-subtree)
- ("\C-h" allout-hide-current-subtree)
- ("\C-t" allout-toggle-current-subtree-exposure)
- ("h" allout-hide-current-subtree)
- ("\C-o" allout-show-current-entry)
- ("!" allout-show-all)
- ("x" allout-toggle-current-subtree-encryption)
- ; Alteration commands:
- (" " allout-open-sibtopic)
- ("." allout-open-subtopic)
- ("," allout-open-supertopic)
- ("'" allout-shift-in)
- (">" allout-shift-in)
- ("<" allout-shift-out)
- ("\C-m" allout-rebullet-topic)
- ("*" allout-rebullet-current-heading)
- ("#" allout-number-siblings)
- ("\C-k" allout-kill-line t)
- ([?\M-k] allout-copy-line-as-kill t)
- ("\C-y" allout-yank t)
- ([?\M-y] allout-yank-pop t)
- ("\C-k" allout-kill-topic)
- ([?\M-k] allout-copy-topic-as-kill)
- ; Miscellaneous commands:
- ;([?\C-\ ] allout-mark-topic)
- ("@" 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)))
+Establishes allout processing as part of visiting a file if
+`allout-auto-activation' is non-nil, or removes it otherwise.
+The proper way to use this is through customizing the setting of
+`allout-auto-activation'."
+ (if (not allout-auto-activation)
+ (remove-hook 'find-file-hook 'allout-find-file-hook)
+ (add-hook 'find-file-hook 'allout-find-file-hook)))
;;;_ = allout-auto-activation
+;;;###autoload
(defcustom allout-auto-activation nil
- "Regulates auto-activation modality of allout outlines -- see `allout-init'.
+ "Configure allout outline mode auto-activation.
-Setq-default by `allout-init' to regulate whether or not allout
-outline mode is automatically activated when the buffer-specific
-variable `allout-layout' is non-nil, and whether or not the layout
-dictated by `allout-layout' should be imposed on mode activation.
+Control whether and how allout outline mode is automatically
+activated when files are visited with non-nil buffer-specific
+file variable `allout-layout'.
-With value t, auto-mode-activation and auto-layout are enabled.
-\(This also depends on `allout-find-file-hook' being installed in
-`find-file-hook', which is also done by `allout-init'.)
+When allout-auto-activation is \"On\" \(t), allout mode is
+activated in buffers with non-nil `allout-layout', and the
+specified layout is applied.
-With value `ask', auto-mode-activation is enabled, and endorsement for
+With value \"ask\", auto-mode-activation is enabled, and endorsement for
performing auto-layout is asked of the user each time.
-With value `activate', only auto-mode-activation is enabled,
-auto-layout is not.
-
-With value nil, neither auto-mode-activation nor auto-layout are
-enabled.
+With value \"activate\", only auto-mode-activation is enabled.
+Auto-layout is not.
-See the docstring for `allout-init' for the proper interface to
-this variable."
+With value nil, inhibit any automatic allout-mode activation."
+ :set 'allout-auto-activation-helper
+ ;; FIXME: Using strings here is unusual and less efficient than symbols.
:type '(choice (const :tag "On" t)
(const :tag "Ask about layout" "ask")
(const :tag "Mode only" "activate")
(const :tag "Off" nil))
:group 'allout)
+(allout-setup)
;;;_ = allout-default-layout
(defcustom allout-default-layout '(-2 : 0)
"Default allout outline layout specification.
@@ -205,7 +328,7 @@ layout specifications.
A list value specifies a default layout for the current buffer,
to be applied upon activation of `allout-mode'. Any non-nil
value will automatically trigger `allout-mode', provided
-`allout-init' has been called to enable this behavior.
+`allout-auto-activation' has been customized to enable it.
The types of elements in the layout specification are:
@@ -444,7 +567,7 @@ themselves:
`!' - exclamation point/bang -- emphatic
`[' - open square bracket -- meta-note, about item instead of item's subject
`\"' - double quote -- a quotation or other citation
- `=' - equal sign -- an assignement, equating a name with some connotation
+ `=' - equal sign -- an assignment, some kind of definition
`^' - carat -- relates to something above
Some are more elusive, but their rationale may be recognizable:
@@ -628,8 +751,10 @@ Set this var to the bullet you want to use for file cross-references."
;;;###autoload
(put 'allout-presentation-padding 'safe-local-variable 'integerp)
-;;;_ = allout-abbreviate-flattened-numbering
-(defcustom allout-abbreviate-flattened-numbering nil
+;;;_ = allout-flattened-numbering-abbreviation
+(define-obsolete-variable-alias 'allout-abbreviate-flattened-numbering
+ 'allout-flattened-numbering-abbreviation "24.1")
+(defcustom allout-flattened-numbering-abbreviation nil
"If non-nil, `allout-flatten-exposed-to-buffer' abbreviates topic
numbers to minimal amount with some context. Otherwise, entire
numbers are always used."
@@ -690,32 +815,6 @@ formatted copy."
:type '(choice (const nil) string)
:version "22.1"
:group 'allout-encryption)
-;;;_ = allout-passphrase-verifier-handling
-(defcustom allout-passphrase-verifier-handling t
- "Enable use of symmetric encryption passphrase verifier if non-nil.
-
-See the docstring for the `allout-enable-file-variable-adjustment'
-variable for details about allout ajustment of file variables."
- :type 'boolean
- :version "22.1"
- :group 'allout-encryption)
-(make-variable-buffer-local 'allout-passphrase-verifier-handling)
-;;;_ = allout-passphrase-hint-handling
-(defcustom allout-passphrase-hint-handling 'always
- "Dictate outline encryption passphrase reminder handling:
-
- always -- always show reminder when prompting
- needed -- show reminder on passphrase entry failure
- disabled -- never present or adjust reminder
-
-See the docstring for the `allout-enable-file-variable-adjustment'
-variable for details about allout ajustment of file variables."
- :type '(choice (const always)
- (const needed)
- (const disabled))
- :version "22.1"
- :group 'allout-encryption)
-(make-variable-buffer-local 'allout-passphrase-hint-handling)
;;;_ = allout-encrypt-unencrypted-on-saves
(defcustom allout-encrypt-unencrypted-on-saves t
"When saving, should topics pending encryption be encrypted?
@@ -753,7 +852,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 +891,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.3"
"Version of currently loaded outline package. (allout.el)")
;;;_ > allout-version
(defun allout-version (&optional here)
@@ -810,10 +909,10 @@ For details, see `allout-toggle-current-subtree-encryption's docstring."
(defvar allout-layout nil ; LEAVE GLOBAL VALUE NIL -- see docstring.
"Buffer-specific setting for allout layout.
-In buffers where this is non-nil (and if `allout-init' has been run, to
-enable this behavior), `allout-mode' will be automatically activated. The
-layout dictated by the value will be used to set the initial exposure when
-`allout-mode' is activated.
+In buffers where this is non-nil \(and if `allout-auto-activation'
+has been customized to enable this behavior), `allout-mode' will be
+automatically activated. The layout dictated by the value will be used to
+set the initial exposure when `allout-mode' is activated.
\*You should not setq-default this variable non-nil unless you want every
visited file to be treated as an allout file.*
@@ -826,9 +925,9 @@ example, the following lines at the bottom of an Emacs Lisp file:
;;;End:
dictate activation of `allout-mode' mode when the file is visited
-\(presuming allout-init was already run), followed by the
-equivalent of `(allout-expose-topic 0 : -1 -1 0)'. (This is
-the layout used for the allout.el source file.)
+\(presuming proper `allout-auto-activation' customization),
+followed by the equivalent of `(allout-expose-topic 0 : -1 -1 0)'.
+\(This is the layout used for the allout.el source file.)
`allout-default-layout' describes the specification format.
`allout-layout' can additionally have the value `t', in which
@@ -1140,29 +1239,6 @@ Also refresh various data structures that hinge on the regexp."
"[^" allout-primary-bullet "]"))
"\\)"
))))
-;;;_ : Key bindings
-;;;_ = allout-mode-map
-(defvar allout-mode-map nil "Keybindings for (allout) outline minor mode.")
-;;;_ > produce-allout-mode-map (keymap-alist &optional base-map)
-(defun produce-allout-mode-map (keymap-list &optional base-map)
- "Produce keymap for use as `allout-mode-map', from KEYMAP-LIST.
-
-Built on top of optional BASE-MAP, or empty sparse map if none specified.
-See doc string for `allout-keybindings-list' for format of binding list."
- (let ((map (or base-map (make-sparse-keymap)))
- (pref (list allout-command-prefix)))
- (mapc (function
- (lambda (cell)
- (let ((add-pref (null (cdr (cdr cell))))
- (key-suff (list (car cell))))
- (apply 'define-key
- (list map
- (apply 'vconcat (if add-pref
- (append pref key-suff)
- key-suff))
- (car (cdr cell)))))))
- keymap-list)
- map))
;;;_ : Menu bar
(defvar allout-mode-exposure-menu)
(defvar allout-mode-editing-menu)
@@ -1171,7 +1247,7 @@ See doc string for `allout-keybindings-list' for format of binding list."
(defun produce-allout-mode-menubar-entries ()
(require 'easymenu)
(easy-menu-define allout-mode-exposure-menu
- allout-mode-map
+ allout-mode-map-value
"Allout outline exposure menu."
'("Exposure"
["Show Entry" allout-show-current-entry t]
@@ -1182,7 +1258,7 @@ See doc string for `allout-keybindings-list' for format of binding list."
"----"
["Show All" allout-show-all t]))
(easy-menu-define allout-mode-editing-menu
- allout-mode-map
+ allout-mode-map-value
"Allout outline editing menu."
'("Headings"
["Open Sibling" allout-open-sibtopic t]
@@ -1199,7 +1275,7 @@ See doc string for `allout-keybindings-list' for format of binding list."
allout-toggle-current-subtree-encryption
(> (allout-current-depth) 1)]))
(easy-menu-define allout-mode-navigation-menu
- allout-mode-map
+ allout-mode-map-value
"Allout outline navigation menu."
'("Navigation"
["Next Visible Heading" allout-next-visible-heading t]
@@ -1216,7 +1292,7 @@ See doc string for `allout-keybindings-list' for format of binding list."
["End of Entry" allout-end-of-entry t]
["End of Subtree" allout-end-of-current-subtree t]))
(easy-menu-define allout-mode-misc-menu
- allout-mode-map
+ allout-mode-map-value
"Allout outlines miscellaneous bindings."
'("Misc"
["Version" allout-version t]
@@ -1278,7 +1354,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
@@ -1326,17 +1402,11 @@ their settings before allout-mode was started."
;;;_ = allout-mode-deactivate-hook
(defvar allout-mode-deactivate-hook nil
"*Hook that's run when allout mode ends.")
+(define-obsolete-variable-alias 'allout-mode-deactivate-hook
+ 'allout-mode-off-hook "24.1")
;;;_ = allout-exposure-category
(defvar allout-exposure-category nil
"Symbol for use as allout invisible-text overlay category.")
-;;;_ x allout-view-change-hook
-(defvar allout-view-change-hook nil
- "*(Deprecated) A hook run after allout outline exposure changes.
-
-Switch to using `allout-exposure-change-hook' instead. Both hooks are
-currently respected, but the other conveys the details of the exposure
-change via explicit parameters, and this one will eventually be disabled in
-a subsequent allout version.")
;;;_ = allout-exposure-change-hook
(defvar allout-exposure-change-hook nil
"*Hook that's run after allout outline subtree exposure changes.
@@ -1349,10 +1419,7 @@ Functions on the hook must take three arguments:
- TO -- integer indicating the point of the end of the change.
- FLAG -- change mode: nil for exposure, otherwise concealment.
-This hook might be invoked multiple times by a single command.
-
-This hook is replacing `allout-view-change-hook', which is being deprecated
-and eventually will not be invoked.")
+This hook might be invoked multiple times by a single command.")
;;;_ = allout-structure-added-hook
(defvar allout-structure-added-hook nil
"*Hook that's run after addition of items to the outline.
@@ -1362,9 +1429,6 @@ Functions on the hook should take two arguments:
- NEW-START -- integer indicating position of start of the first new item.
- NEW-END -- integer indicating position of end of the last new item.
-Some edits that introduce new items may missed by this hook:
-specifically edits that native allout routines do not control.
-
This hook might be invoked multiple times by a single command.")
;;;_ = allout-structure-deleted-hook
(defvar allout-structure-deleted-hook nil
@@ -1392,6 +1456,11 @@ Some edits that shift items can be missed by this hook: specifically edits
that native allout routines do not control.
This hook might be invoked multiple times by a single command.")
+;;;_ = allout-after-copy-or-kill-hook
+(defvar allout-after-copy-or-kill-hook nil
+ "*Hook that's run after copying outline text.
+
+Functions on the hook should not take any arguments.")
;;;_ = allout-outside-normal-auto-fill-function
(defvar allout-outside-normal-auto-fill-function nil
"Value of normal-auto-fill-function outside of allout mode.
@@ -1399,11 +1468,8 @@ This hook might be invoked multiple times by a single command.")
Used by allout-auto-fill to do the mandated normal-auto-fill-function
wrapped within allout's automatic fill-prefix setting.")
(make-variable-buffer-local 'allout-outside-normal-auto-fill-function)
-;;;_ = file-var-bug hack
-(defvar allout-v18/19-file-var-hack nil
- "Horrible hack used to prevent invalid multiple triggering of outline
-mode from prop-line file-var activation. Used by `allout-mode' function
-to track repeats.")
+;;;_ = prevent redundant activation by desktop mode:
+(add-to-list 'desktop-minor-mode-handlers '(allout-mode . nil))
;;;_ = allout-passphrase-verifier-string
(defvar allout-passphrase-verifier-string nil
"Setting used to test solicited encryption passphrases against the one
@@ -1419,6 +1485,8 @@ The verifier string is retained as an Emacs file variable, as well as in
the Emacs buffer state, if file variable adjustments are enabled. See
`allout-enable-file-variable-adjustment' for details about that.")
(make-variable-buffer-local 'allout-passphrase-verifier-string)
+(make-obsolete 'allout-passphrase-verifier-string
+ 'allout-passphrase-verifier-string "23.3")
;;;###autoload
(put 'allout-passphrase-verifier-string 'safe-local-variable 'stringp)
;;;_ = allout-passphrase-hint-string
@@ -1433,6 +1501,8 @@ state, if file variable adjustments are enabled. See
`allout-enable-file-variable-adjustment' for details about that.")
(make-variable-buffer-local 'allout-passphrase-hint-string)
(setq-default allout-passphrase-hint-string "")
+(make-obsolete 'allout-passphrase-hint-string
+ 'allout-passphrase-hint-string "23.3")
;;;###autoload
(put 'allout-passphrase-hint-string 'safe-local-variable 'stringp)
;;;_ = allout-after-save-decrypt
@@ -1464,15 +1534,15 @@ substition is used against the regexp matches, a la `replace-match'.")
(defvar allout-encryption-ciphertext-rejection-regexps nil
"Variable for regexps matching plaintext to remove before encryption.
-This is for the sake of redoing encryption in cases where the ciphertext
-incidentally contains strings that would disrupt mode operation --
-for example, a line that happens to look like an allout-mode topic prefix.
+This is used to detect strings in encryption results that would
+register as allout mode structural elements, for exmple, as a
+topic prefix.
Entries must be symbols that are bound to the desired regexp values.
-The encryption will be retried up to
-`allout-encryption-ciphertext-rejection-limit' times, after which an error
-is raised.")
+Encryptions that result in matches will be retried, up to
+`allout-encryption-ciphertext-rejection-limit' times, after which
+an error is raised.")
(make-variable-buffer-local 'allout-encryption-ciphertext-rejection-regexps)
;;;_ = allout-encryption-ciphertext-rejection-ceiling
@@ -1484,6 +1554,7 @@ See `allout-encryption-ciphertext-rejection-regexps' for rejection reasons.")
;;;_ > allout-mode-p ()
;; Must define this macro above any uses, or byte compilation will lack
;; proper def, if file isn't loaded -- eg, during emacs build!
+;;;###autoload
(defmacro allout-mode-p ()
"Return t if `allout-mode' is active in current buffer."
'allout-mode)
@@ -1541,6 +1612,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,90 +1633,25 @@ 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.
So `allout-post-command-business' should not reactivate it...")
(make-variable-buffer-local 'allout-explicitly-deactivated)
-;;;_ > allout-init (&optional mode)
-(defun allout-init (&optional mode)
- "Prime `allout-mode' to enable/disable auto-activation, wrt `allout-layout'.
-
-MODE is one of the following symbols:
-
- - nil (or no argument) deactivate auto-activation/layout;
- - `activate', enable auto-activation only;
- - `ask', enable auto-activation, and enable auto-layout but with
- confirmation for layout operation solicited from user each time;
- - `report', just report and return the current auto-activation state;
- - anything else (eg, t) for auto-activation and auto-layout, without
- any confirmation check.
-
-Use this function to setup your Emacs session for automatic activation
-of allout outline mode, contingent to the buffer-specific setting of
-the `allout-layout' variable. (See `allout-layout' and
-`allout-expose-topic' docstrings for more details on auto layout).
-
-`allout-init' works by setting up (or removing) the `allout-mode'
-find-file-hook, and giving `allout-auto-activation' a suitable
-setting.
-
-To prime your Emacs session for full auto-outline operation, include
-the following two lines in your Emacs init file:
-
-\(require 'allout)
-\(allout-init t)"
-
- (interactive)
- (if (called-interactively-p 'interactive)
- (progn
- (setq mode
- (completing-read
- (concat "Select outline auto setup mode "
- "(empty for report, ? for options) ")
- '(("nil")("full")("activate")("deactivate")
- ("ask") ("report") (""))
- nil
- t))
- (if (string= mode "")
- (setq mode 'report)
- (setq mode (intern-soft mode)))))
- (let
- ;; convenience aliases, for consistent ref to respective vars:
- ((hook 'allout-find-file-hook)
- (find-file-hook-var-name (if (boundp 'find-file-hook)
- 'find-file-hook
- 'find-file-hooks))
- (curr-mode 'allout-auto-activation))
-
- (cond ((not mode)
- (set find-file-hook-var-name
- (delq hook (symbol-value find-file-hook-var-name)))
- (if (called-interactively-p 'interactive)
- (message "Allout outline mode auto-activation inhibited.")))
- ((eq mode 'report)
- (if (not (memq hook (symbol-value find-file-hook-var-name)))
- (allout-init nil)
- ;; Just punt and use the reports from each of the modes:
- (allout-init (symbol-value curr-mode))))
- (t (add-hook find-file-hook-var-name hook)
- (set curr-mode ; `set', not `setq'!
- (cond ((eq mode 'activate)
- (message
- "Outline mode auto-activation enabled.")
- 'activate)
- ((eq mode 'report)
- ;; Return the current mode setting:
- (allout-init mode))
- ((eq mode 'ask)
- (message
- (concat "Outline mode auto-activation and "
- "-layout (upon confirmation) enabled."))
- 'ask)
- ((message
- "Outline mode auto-activation and -layout enabled.")
- 'full)))))))
+;;;_ > allout-init (mode)
+(defun allout-init (mode)
+ "DEPRECATED - configure allout activation by customizing
+`allout-auto-activation'. This function remains around, limited
+from what it did before, for backwards compatibility.
+
+MODE is the activation mode - see `allout-auto-activation' for
+valid values."
+
+ (custom-set-variables (list 'allout-auto-activation (format "%s" mode)))
+ (format "%s" mode))
+(make-obsolete 'allout-init
+ "customize 'allout-auto-activation' instead." "23.3")
;;;_ > allout-setup-menubar ()
(defun allout-setup-menubar ()
"Populate the current buffer's menubar with `allout-mode' stuff."
@@ -1656,7 +1670,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
@@ -1670,24 +1684,22 @@ the following two lines in your Emacs init file:
'(allout-overlay-insert-in-front-handler)))
(put 'allout-exposure-category 'modification-hooks
'(allout-overlay-interior-modification-handler)))
-;;;_ > allout-mode (&optional toggle)
+;;;_ > define-minor-mode allout-mode
;;;_ : Defun:
;;;###autoload
-(defun allout-mode (&optional toggle)
+(define-minor-mode allout-mode
;;;_ . Doc string:
"Toggle minor mode for controlling exposure and editing of text outlines.
-\\<allout-mode-map>
+\\<allout-mode-map-value>
-Optional prefix argument TOGGLE forces the mode to re-initialize
-if it is positive, otherwise it turns the mode off. Allout
-outline mode always runs as a minor mode.
+Allout outline mode always runs as a minor mode.
-Allout outline mode provides extensive outline oriented formatting and
-manipulation. It enables structural editing of outlines, as well as
-navigation and exposure. It also is specifically aimed at
-accommodating syntax-sensitive text like programming languages. (For
-an example, see the allout code itself, which is organized as an allout
-outline.)
+Allout outline mode provides extensive outline oriented
+formatting and manipulation. It enables structural editing of
+outlines, as well as navigation and exposure. It also is
+specifically aimed at accommodating syntax-sensitive text like
+programming languages. \(For example, see the allout code itself,
+which is organized as an allout outline.)
In addition to typical outline navigation and exposure, allout includes:
@@ -1695,27 +1707,29 @@ In addition to typical outline navigation and exposure, allout includes:
repositioning, promotion/demotion, cut, and paste
- incremental search with dynamic exposure and reconcealment of hidden text
- adjustable format, so programming code can be developed in outline-structure
- - easy topic encryption and decryption
+ - easy topic encryption and decryption, symmetric or key-pair
- \"Hot-spot\" operation, for single-keystroke maneuvering and exposure control
- integral outline layout, for automatic initial exposure when visiting a file
- independent extensibility, using comprehensive exposure and authoring hooks
and many other features.
-Below is a description of the key bindings, and then explanation of
-special `allout-mode' features and terminology. See also the outline
-menubar additions for quick reference to many of the features, and see
-the docstring of the function `allout-init' for instructions on
-priming your emacs session for automatic activation of `allout-mode'.
-
-The bindings are dictated by the customizable `allout-keybindings-list'
-variable. We recommend customizing `allout-command-prefix' to use just
-`\\C-c' as the command prefix, if the allout bindings don't conflict with
-any personal bindings you have on \\C-c. In any case, outline structure
-navigation and authoring is simplified by positioning the cursor on an
-item's bullet character, the \"hot-spot\" -- then you can invoke allout
-commands with just the un-prefixed, un-control-shifted command letters.
-This is described further in the HOT-SPOT Operation section.
+Below is a description of the key bindings, and then description
+of special `allout-mode' features and terminology. See also the
+outline menubar additions for quick reference to many of the
+features. Customize `allout-auto-activation' to prepare your
+emacs session for automatic activation of `allout-mode'.
+
+The bindings are those listed in `allout-prefixed-keybindings'
+and `allout-unprefixed-keybindings'. We recommend customizing
+`allout-command-prefix' to use just `\\C-c' as the command
+prefix, if the allout bindings don't conflict with any personal
+bindings you have on \\C-c. In any case, outline structure
+navigation and authoring is simplified by positioning the cursor
+on an item's bullet character, the \"hot-spot\" -- then you can
+invoke allout commands with just the un-prefixed,
+un-control-shifted command letters. This is described further in
+the HOT-SPOT Operation section.
Exposure Control:
----------------
@@ -1788,25 +1802,29 @@ M-x outlineify-sticky Activate outline mode for current buffer,
Like above 'copy-exposed', but convert topic
prefixes to section.subsection... numeric
format.
-\\[eval-expression] (allout-init t) Setup Emacs session for outline mode
+\\[customize-variable] allout-auto-activation
+ Prepare Emacs session for allout outline mode
auto-activation.
Topic Encryption
Outline mode supports gpg encryption of topics, with support for
-symmetric and key-pair modes, passphrase timeout, passphrase
-consistency checking, user-provided hinting for symmetric key
-mode, and auto-encryption of topics pending encryption on save.
+symmetric and key-pair modes, and auto-encryption of topics
+pending encryption on save.
Topics pending encryption are, by default, automatically
-encrypted during file saves. If the contents of the topic
-containing the cursor was encrypted for a save, it is
-automatically decrypted for continued editing.
-
-The aim of these measures is reliable topic privacy while
-preventing accidents like neglected encryption before saves,
-forgetting which passphrase was used, and other practical
-pitfalls.
+encrypted during file saves, including checkpoint saves, to avoid
+exposing the plain text of encrypted topics in the file system.
+If the content of the topic containing the cursor was encrypted
+for a save, it is automatically decrypted for continued editing.
+
+NOTE: A few GnuPG v2 versions improperly preserve incorrect
+symmetric decryption keys, preventing entry of the correct key on
+subsequent decryption attempts until the cache times-out. That
+can take several minutes. \(Decryption of other entries is not
+affected.) Upgrade your EasyPG version, if you can, and you can
+deliberately clear your gpg-agent's cache by sending it a '-HUP'
+signal.
See `allout-toggle-current-subtree-encryption' function docstring
and `allout-encrypt-unencrypted-on-saves' customization variable
@@ -1844,11 +1862,13 @@ hooks, by which independent code can cooperate with allout
without changes to the allout core. Here are key ones:
`allout-mode-hook'
-`allout-mode-deactivate-hook'
+`allout-mode-deactivate-hook' \(deprecated)
+`allout-mode-off-hook'
`allout-exposure-change-hook'
`allout-structure-added-hook'
`allout-structure-deleted-hook'
`allout-structure-shifted-hook'
+`allout-after-copy-or-kill-hook'
Terminology
@@ -1931,76 +1951,41 @@ CONCEALED:
CLOSED: A TOPIC whose immediate OFFSPRING and body-text is CONCEALED.
OPEN: A TOPIC that is not CLOSED, though its OFFSPRING or BODY may be."
;;;_ . Code
- (interactive "P")
-
- (let* ((active (and (not (equal major-mode 'outline))
- (allout-mode-p)))
- ; Massage universal-arg `toggle' val:
- (toggle (and toggle
- (or (and (listp toggle)(car toggle))
- toggle)))
- ; Activation specifically demanded?
- (explicit-activation (and toggle
- (or (symbolp toggle)
- (and (wholenump toggle)
- (not (zerop toggle))))))
- ;; allout-mode already called once during this complex command?
- (same-complex-command (eq allout-v18/19-file-var-hack
- (car command-history)))
- (write-file-hook-var-name (cond ((boundp 'write-file-functions)
- 'write-file-functions)
- ((boundp 'write-file-hooks)
- 'write-file-hooks)
- (t 'local-write-file-hooks)))
- do-layout
- )
-
- ; See comments below re v19.18,.19 bug.
- (setq allout-v18/19-file-var-hack (car command-history))
-
- (cond
-
- ;; Provision for v19.18, 19.19 bug --
- ;; Emacs v 19.18, 19.19 file-var code invokes prop-line-designated
- ;; modes twice when file is visited. We have to avoid toggling mode
- ;; off on second invocation, so we detect it as best we can, and
- ;; skip everything.
- ((and same-complex-command ; Still in same complex command
- ; as last time `allout-mode' invoked.
- active ; Already activated.
- (not explicit-activation) ; Prop-line file-vars don't have args.
- (string-match "^19.1[89]" ; Bug only known to be in v19.18 and
- emacs-version)); 19.19.
- t)
-
- ;; Deactivation:
- ((and (not explicit-activation)
- (or active toggle))
- ; Activation not explicitly
- ; requested, and either in
- ; active state or *de*activation
- ; specifically requested:
- (setq allout-explicitly-deactivated t)
-
- (allout-do-resumptions)
-
- (remove-from-invisibility-spec '(allout . t))
- (remove-hook 'pre-command-hook 'allout-pre-command-business t)
- (remove-hook 'post-command-hook 'allout-post-command-business t)
- (remove-hook 'before-change-functions 'allout-before-change-handler t)
- (remove-hook 'isearch-mode-end-hook 'allout-isearch-end-handler t)
- (remove-hook write-file-hook-var-name 'allout-write-file-hook-handler t)
- (remove-hook 'auto-save-hook 'allout-auto-save-hook-handler t)
-
- (remove-overlays (point-min) (point-max)
- 'category 'allout-exposure-category)
-
- (setq allout-mode nil)
- (run-hooks 'allout-mode-deactivate-hook))
-
- ;; Activation:
- ((not active)
- (setq allout-explicitly-deactivated nil)
+ :lighter " Allout"
+ :keymap 'allout-mode-map
+
+ (let ((write-file-hook-var-name (cond ((boundp 'write-file-functions)
+ 'write-file-functions)
+ ((boundp 'write-file-hooks)
+ 'write-file-hooks)
+ (t 'local-write-file-hooks)))
+ (use-layout (if (listp allout-layout)
+ allout-layout
+ allout-default-layout)))
+
+ (if (not (allout-mode-p))
+ (progn
+ ;; Deactivation:
+
+ ; Activation not explicitly
+ ; requested, and either in
+ ; active state or *de*activation
+ ; specifically requested:
+ (allout-do-resumptions)
+
+ (remove-from-invisibility-spec '(allout . t))
+ (remove-hook 'pre-command-hook 'allout-pre-command-business t)
+ (remove-hook 'post-command-hook 'allout-post-command-business t)
+ (remove-hook 'before-change-functions 'allout-before-change-handler t)
+ (remove-hook 'isearch-mode-end-hook 'allout-isearch-end-handler t)
+ (remove-hook write-file-hook-var-name
+ 'allout-write-file-hook-handler t)
+ (remove-hook 'auto-save-hook 'allout-auto-save-hook-handler t)
+
+ (remove-overlays (point-min) (point-max)
+ 'category 'allout-exposure-category))
+
+ ;; Activating:
(if allout-old-style-prefixes
;; Inhibit all the fancy formatting:
(allout-add-resumptions '(allout-primary-bullet "*")))
@@ -2011,45 +1996,31 @@ OPEN: A TOPIC that is not CLOSED, though its OFFSPRING or BODY may be."
(allout-infer-body-reindent)
(set-allout-regexp)
- (allout-add-resumptions
- '(allout-encryption-ciphertext-rejection-regexps
- allout-line-boundary-regexp
- extend)
- '(allout-encryption-ciphertext-rejection-regexps
- allout-bob-regexp
- extend))
-
- ;; Produce map from current version of allout-keybindings-list:
- (allout-setup-mode-map)
+ (allout-add-resumptions '(allout-encryption-ciphertext-rejection-regexps
+ allout-line-boundary-regexp
+ extend)
+ '(allout-encryption-ciphertext-rejection-regexps
+ allout-bob-regexp
+ extend))
+
+ (allout-compose-and-institute-keymap)
(produce-allout-mode-menubar-entries)
- ;; Include on minor-mode-map-alist, if not already there:
- (if (not (member '(allout-mode . allout-mode-map)
- minor-mode-map-alist))
- (setq minor-mode-map-alist
- (cons '(allout-mode . allout-mode-map)
- minor-mode-map-alist)))
-
(add-to-invisibility-spec '(allout . t))
(allout-add-resumptions '(line-move-ignore-invisible t))
(add-hook 'pre-command-hook 'allout-pre-command-business nil t)
(add-hook 'post-command-hook 'allout-post-command-business nil t)
- (add-hook 'before-change-functions 'allout-before-change-handler
- nil t)
+ (add-hook 'before-change-functions 'allout-before-change-handler nil t)
(add-hook 'isearch-mode-end-hook 'allout-isearch-end-handler nil t)
(add-hook write-file-hook-var-name 'allout-write-file-hook-handler
nil t)
- (add-hook 'auto-save-hook 'allout-auto-save-hook-handler
- nil t)
+ (add-hook 'auto-save-hook 'allout-auto-save-hook-handler nil t)
;; Stash auto-fill settings and adjust so custom allout auto-fill
;; func will be used if auto-fill is active or activated. (The
;; custom func respects topic headline, maintains hanging-indents,
;; etc.)
- (if (and auto-fill-function (not allout-inhibit-auto-fill))
- ;; allout-auto-fill will use the stashed values and so forth.
- (allout-add-resumptions '(auto-fill-function allout-auto-fill)))
(allout-add-resumptions (list 'allout-former-auto-filler
auto-fill-function)
;; Register allout-auto-fill to be used if
@@ -2064,96 +2035,58 @@ OPEN: A TOPIC that is not CLOSED, though its OFFSPRING or BODY may be."
(list 'paragraph-separate
(concat paragraph-separate "\\|^\\("
allout-regexp "\\)")))
- (or (assq 'allout-mode minor-mode-alist)
- (setq minor-mode-alist
- (cons '(allout-mode " Allout") minor-mode-alist)))
+ (if (and auto-fill-function (not allout-inhibit-auto-fill))
+ ;; allout-auto-fill will use the stashed values and so forth.
+ (allout-add-resumptions '(auto-fill-function allout-auto-fill)))
(allout-setup-menubar)
- (if allout-layout
- (setq do-layout t))
-
- (setq allout-mode t)
- (run-hooks 'allout-mode-hook))
-
- ;; Reactivation:
- ((setq do-layout t)
- (allout-infer-body-reindent))
- ) ;; end of activation-mode cases.
-
- ;; Do auto layout if warranted:
- (let ((use-layout (if (listp allout-layout)
- allout-layout
- allout-default-layout)))
- (if (and do-layout
- allout-auto-activation
- use-layout
- (and (not (eq allout-auto-activation 'activate))
- (if (eq allout-auto-activation 'ask)
- (if (y-or-n-p (format "Expose %s with layout '%s'? "
- (buffer-name)
- use-layout))
- t
- (message "Skipped %s layout." (buffer-name))
- nil)
- t)))
- (save-excursion
- (message "Adjusting '%s' exposure..." (buffer-name))
- (goto-char 0)
- (allout-this-or-next-heading)
- (condition-case err
- (progn
- (apply 'allout-expose-topic (list use-layout))
- (message "Adjusting '%s' exposure... done." (buffer-name)))
- ;; Problem applying exposure -- notify user, but don't
- ;; interrupt, eg, file visit:
- (error (message "%s" (car (cdr err)))
- (sit-for 1))))))
- allout-mode
- ) ; let*
- ) ; defun
-
-(defun allout-setup-mode-map ()
- "Establish allout-mode bindings."
- (setq-default allout-mode-map
- (produce-allout-mode-map allout-keybindings-list))
- (setq allout-mode-map
- (produce-allout-mode-map allout-keybindings-list))
- (substitute-key-definition 'beginning-of-line
- 'allout-beginning-of-line
- allout-mode-map global-map)
- (substitute-key-definition 'move-beginning-of-line
- 'allout-beginning-of-line
- allout-mode-map global-map)
- (substitute-key-definition 'end-of-line
- 'allout-end-of-line
- allout-mode-map global-map)
- (substitute-key-definition 'move-end-of-line
- 'allout-end-of-line
- allout-mode-map global-map)
- (fset 'allout-mode-map allout-mode-map))
-
-;; ensure that allout-mode-map has some setting even if allout-mode hasn't
-;; been invoked:
-(allout-setup-mode-map)
-
-;;;_ > allout-minor-mode
+ ;; Do auto layout if warranted:
+ (when (and allout-layout
+ allout-auto-activation
+ use-layout
+ (and (not (string= allout-auto-activation "activate"))
+ (if (string= allout-auto-activation "ask")
+ (if (y-or-n-p (format "Expose %s with layout '%s'? "
+ (buffer-name)
+ use-layout))
+ t
+ (message "Skipped %s layout." (buffer-name))
+ nil)
+ t)))
+ (save-excursion
+ (message "Adjusting '%s' exposure..." (buffer-name))
+ (goto-char 0)
+ (allout-this-or-next-heading)
+ (condition-case err
+ (progn
+ (apply 'allout-expose-topic (list use-layout))
+ (message "Adjusting '%s' exposure... done."
+ (buffer-name)))
+ ;; Problem applying exposure -- notify user, but don't
+ ;; interrupt, eg, file visit:
+ (error (message "%s" (car (cdr err)))
+ (sit-for 1))))
+ ) ; when allout-layout
+ ) ; if (allout-mode-p)
+ ) ; let (())
+ ) ; define-minor-mode
+;;;_ > allout-minor-mode alias
(defalias 'allout-minor-mode 'allout-mode)
-
;;;_ > allout-unload-function
(defun allout-unload-function ()
"Unload the allout outline library."
(save-current-buffer
(dolist (buffer (buffer-list))
(set-buffer buffer)
- (when allout-mode (allout-mode -1))))
+ (when (allout-mode-p) (allout-mode))))
;; continue standard unloading
nil)
;;;_ - 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 +2095,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)
@@ -2215,8 +2148,8 @@ internal functions use this feature cohesively bunch changes."
See `allout-overlay-interior-modification-handler' for details."
- (if (and (allout-mode-p) undo-in-progress (allout-hidden-p))
- (allout-show-to-offshoot))
+ (when (and (allout-mode-p) undo-in-progress (allout-hidden-p))
+ (allout-show-children))
;; allout-overlay-interior-modification-handler on an overlay handles
;; this in other emacs, via `allout-exposure-category's 'modification-hooks.
@@ -2225,8 +2158,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 +2173,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 +2442,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 +2461,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 +2507,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 +2833,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,15 +2842,23 @@ 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)
+ (when (allout-goto-prefix-doublechecked)
+ (if (<= (point) bol-point)
+ (progn
+ (setq bol-point (point))
+ (allout-beginning-of-current-line)
+ (if (not (= bol-point (point)))
+ (if (looking-at allout-regexp)
+ (allout-prefix-data)))
+ (if interactive
(allout-end-of-prefix)
- (point))
- (goto-char (point-min))
- nil))))
+ (point)))
+ (goto-char (point-min))
+ nil))))
;;;_ > allout-back-to-heading ()
(defalias 'allout-back-to-heading 'allout-back-to-current-heading)
;;;_ > allout-pre-next-prefix ()
@@ -2955,20 +2908,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 +2971,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 +2999,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 +3027,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 +3172,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.
@@ -3230,6 +3183,7 @@ Move to buffer limit in indicated direction if headings are exhausted."
(let* ((inhibit-field-text-motion t)
(backward (if (< arg 0) (setq arg (* -1 arg))))
(step (if backward -1 1))
+ (progress (allout-current-bullet-pos))
prev got)
(while (> arg 0)
@@ -3239,7 +3193,17 @@ Move to buffer limit in indicated direction if headings are exhausted."
;; Move, skipping over all concealed lines in one fell swoop:
(prog1 (condition-case nil (or (line-move step) t)
(error nil))
- (allout-beginning-of-current-line))
+ (allout-beginning-of-current-line)
+ ;; line-move can wind up on the same line if long.
+ ;; when moving forward, that would yield no-progress
+ (when (and (not backward)
+ (<= (point) progress))
+ ;; ensure progress by doing line-move from end-of-line:
+ (end-of-line)
+ (condition-case nil (or (line-move step) t)
+ (error nil))
+ (allout-beginning-of-current-line)
+ (setq progress (point))))
;; Deal with apparent header line:
(save-match-data
(if (not (looking-at allout-regexp))
@@ -3272,7 +3236,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 +3257,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 +3270,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))))
@@ -3322,7 +3286,7 @@ When set, tells post-processing to reposition on topic bullet, and
then unset it. Set by `allout-pre-command-business' when implementing
hot-spot operation, where literal characters typed over a topic bullet
are mapped to the command of the corresponding control-key on the
-`allout-mode-map'.")
+`allout-mode-map-value'.")
(make-variable-buffer-local 'allout-post-goto-bullet)
;;;_ = allout-command-counter
(defvar allout-command-counter 0
@@ -3361,11 +3325,12 @@ coordinating with allout activity.")
Among other things, implements special behavior when the cursor is on the
topic bullet character.
-When the cursor is on the bullet character, self-insert characters are
-reinterpreted as the corresponding control-character in the
-`allout-mode-map'. The `allout-mode' `post-command-hook' insures that
-the cursor which has moved as a result of such reinterpretation is
-positioned on the bullet character of the destination topic.
+When the cursor is on the bullet character, self-insert
+characters are reinterpreted as the corresponding
+control-character in the `allout-mode-map-value'. The
+`allout-mode' `post-command-hook' insures that the cursor which
+has moved as a result of such reinterpretation is positioned on
+the bullet character of the destination topic.
The upshot is that you can get easy, single (ie, unmodified) key
outline maneuvering operations by positioning the cursor on the bullet
@@ -3391,8 +3356,7 @@ 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-num (cond ((numberp last-command-event) last-command-event)
;; for XEmacs character type:
((and (fboundp 'characterp)
@@ -3406,39 +3370,42 @@ 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)
- ;; translate literal membership on list:
- (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)))
- t))))
+ (or
+ ;; try control-modified versions of keys:
+ (key-binding (vconcat allout-command-prefix
+ (vector
+ (if (and (<= 97 key-num) ; "a"
+ (>= 122 key-num)) ; "z"
+ (- key-num 96) key-num)))
+ t)
+ ;; try non-modified versions of keys:
+ (key-binding (vconcat allout-command-prefix
+ (vector 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 ()
"Activate `allout-mode' on non-nil `allout-auto-activation', `allout-layout'.
-See `allout-init' for setup instructions."
+See `allout-auto-activation' for setup instructions."
(if (and allout-auto-activation
(not (allout-mode-p))
allout-layout)
- (allout-mode t)))
+ (allout-mode)))
;;;_ - Topic Format Assessment
;;;_ > allout-solicit-alternate-bullet (depth &optional current-bullet)
@@ -3457,7 +3424,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 "")
@@ -3499,13 +3466,13 @@ Offer one suitable for current depth DEPTH as default."
(defun allout-make-topic-prefix (&optional prior-bullet
new
depth
- solicit
+ instead
number-control
index)
;; Depth null means use current depth, non-null means we're either
;; opening a new topic after current topic, lower or higher, or we're
;; changing level of current topic.
- ;; Solicit dominates specified bullet-char.
+ ;; Instead dominates specified bullet-char.
;;;_ . Doc string:
"Generate a topic prefix suitable for optional arg DEPTH, or current depth.
@@ -3526,15 +3493,18 @@ bullet or previous sibling.
Third arg DEPTH forces the topic prefix to that depth, regardless of
the current topics' depth.
-If SOLICIT is non-nil, then the choice of bullet is solicited from
-user. If it's a character, then that character is offered as the
-default, otherwise the one suited to the context (according to
-distinction or depth) is offered. (This overrides other options,
-including, eg, a distinctive PRIOR-BULLET.) If non-nil, then the
-context-specific bullet is used.
+If INSTEAD is:
+
+- nil, then the bullet char for the context is used, per distinction or depth
+- a \(numeric) character, then character's string representation is used
+- a string, then the user is asked for bullet with the first char as default
+- anything else, the user is solicited with bullet char per context as default
+
+\(INSTEAD overrides other options, including, eg, a distinctive
+PRIOR-BULLET.)
Fifth arg, NUMBER-CONTROL, matters only if `allout-numbered-bullet'
-is non-nil *and* soliciting was not explicitly invoked. Then
+is non-nil *and* no specific INSTEAD was specified. Then
NUMBER-CONTROL non-nil forces prefix to either numbered or
denumbered format, depending on the value of the sixth arg, INDEX.
@@ -3583,8 +3553,13 @@ index for each successive sibling)."
;; Solicitation overrides numbering and other cases:
((progn (setq body (make-string (- depth 2) ?\ ))
;; The actual condition:
- solicit)
- (let* ((got (allout-solicit-alternate-bullet depth solicit)))
+ instead)
+ (let ((got (cond ((stringp instead)
+ (if (> (length instead) 0)
+ (allout-solicit-alternate-bullet
+ depth (substring instead 0 1))))
+ ((characterp instead) (char-to-string instead))
+ (t (allout-solicit-alternate-bullet depth)))))
;; Gotta check whether we're numbering and got a numbered bullet:
(setq numbering (and allout-numbered-bullet
(not (and number-control (not index)))
@@ -3885,9 +3860,13 @@ Maintains outline hanging topic indentation if
(make-string (progn (allout-end-of-prefix)
(current-column))
?\ ))))))
- (use-auto-fill-function (or allout-outside-normal-auto-fill-function
- auto-fill-function
- 'do-auto-fill)))
+ (use-auto-fill-function
+ (if (and (eq allout-outside-normal-auto-fill-function
+ 'allout-auto-fill)
+ (eq auto-fill-function 'allout-auto-fill))
+ 'do-auto-fill
+ (or allout-outside-normal-auto-fill-function
+ auto-fill-function))))
(if (or allout-former-auto-filler allout-use-hanging-indents)
(funcall use-auto-fill-function)))))
;;;_ > allout-reindent-body (old-depth new-depth &optional number)
@@ -3943,7 +3922,7 @@ Note that refill of indented paragraphs is not done."
(allout-end-of-prefix)
(setq from allout-recent-prefix-beginning
to allout-recent-prefix-end)
- (allout-rebullet-heading t ;;; solicit
+ (allout-rebullet-heading t ;;; instead
nil ;;; depth
nil ;;; number-control
nil ;;; index
@@ -3961,8 +3940,8 @@ Note that refill of indented paragraphs is not done."
(message "Done.")
(cond (on-bullet (goto-char (allout-current-bullet-pos)))
(initial-col (move-to-column initial-col)))))
-;;;_ > allout-rebullet-heading (&optional solicit ...)
-(defun allout-rebullet-heading (&optional solicit
+;;;_ > allout-rebullet-heading (&optional instead ...)
+(defun allout-rebullet-heading (&optional instead
new-depth
number-control
index
@@ -3972,11 +3951,11 @@ Note that refill of indented paragraphs is not done."
All args are optional.
-If SOLICIT is non-nil, then the choice of bullet is solicited from
-user. If it's a character, then that character is offered as the
-default, otherwise the one suited to the context (according to
-distinction or depth) is offered. If non-nil, then the
-context-specific bullet is just used.
+If INSTEAD is:
+- nil, then the bullet char for the context is used, per distinction or depth
+- a \(numeric) character, then character's string representation is used
+- a string, then the user is asked for bullet with the first char as default
+- anything else, the user is solicited with bullet char per context as default
Second arg DEPTH forces the topic prefix to that depth, regardless
of the topic's current depth.
@@ -4011,7 +3990,7 @@ this function."
(new-prefix (allout-make-topic-prefix current-bullet
nil
new-depth
- solicit
+ instead
number-control
index)))
@@ -4058,7 +4037,7 @@ this function."
(cond ((numberp index) (1+ index))
((not number-control) (allout-sibling-index))))
(if (allout-numbered-type-prefix)
- (allout-rebullet-heading nil ;;; solicit
+ (allout-rebullet-heading nil ;;; instead
new-depth ;;; new-depth
number-control;;; number-control
index ;;; index
@@ -4175,7 +4154,7 @@ a topic and its immediate offspring is greater than one.)"
(when (< relative-depth 0)
(save-excursion
(goto-char local-point)
- (allout-rebullet-heading nil ;;; solicit
+ (allout-rebullet-heading nil ;;; instead
(+ starting-depth relative-depth)
nil ;;; number
starting-index
@@ -4233,7 +4212,7 @@ Returns final depth."
; Prime ascender for ascension:
(setq ascender (1- allout-recent-depth))
(if (>= allout-recent-depth depth)
- (allout-rebullet-heading nil ;;; solicit
+ (allout-rebullet-heading nil ;;; instead
nil ;;; depth
nil ;;; number-control
nil ;;; index
@@ -4260,7 +4239,7 @@ rebulleting each topic at this level."
(use-bullet (equal '(16) denumber))
(more t))
(while more
- (allout-rebullet-heading use-bullet ;;; solicit
+ (allout-rebullet-heading use-bullet ;;; instead
depth ;;; depth
t ;;; number-control
index ;;; index
@@ -4372,17 +4351,19 @@ subtopics into siblings of the item."
(depth (allout-depth)))
(allout-annotate-hidden beg end)
- (if (and (not beg-hidden) (not end-hidden))
- (allout-unprotected (kill-line arg))
- (kill-line arg))
- (allout-deannotate-hidden beg end)
-
- (if allout-numbered-bullet
- (save-excursion ; Renumber subsequent topics if needed:
- (if (not (save-match-data (looking-at allout-regexp)))
- (allout-next-heading))
- (allout-renumber-to-depth depth)))
- (run-hook-with-args 'allout-structure-deleted-hook depth (point)))))
+ (unwind-protect
+ (if (and (not beg-hidden) (not end-hidden))
+ (allout-unprotected (kill-line arg))
+ (kill-line arg))
+ (run-hooks 'allout-after-copy-or-kill-hook)
+ (allout-deannotate-hidden beg end)
+
+ (if allout-numbered-bullet
+ (save-excursion ; Renumber subsequent topics if needed:
+ (if (not (save-match-data (looking-at allout-regexp)))
+ (allout-next-heading))
+ (allout-renumber-to-depth depth)))
+ (run-hook-with-args 'allout-structure-deleted-hook depth (point))))))
;;;_ > allout-copy-line-as-kill ()
(defun allout-copy-line-as-kill ()
"Like allout-kill-topic, but save to kill ring instead of deleting."
@@ -4423,15 +4404,14 @@ Topic exposure is marked with text-properties, to be used by
(forward-char 1)))
(allout-annotate-hidden beg (setq end (point)))
- (unwind-protect
+ (unwind-protect ; for possible barf-if-buffer-read-only.
(allout-unprotected (kill-region beg end))
- (if buffer-read-only
- ;; eg, during copy-as-kill.
- (allout-deannotate-hidden beg end)))
+ (allout-deannotate-hidden beg end)
+ (run-hooks 'allout-after-copy-or-kill-hook)
- (save-excursion
- (allout-renumber-to-depth depth))
- (run-hook-with-args 'allout-structure-deleted-hook depth (point))))
+ (save-excursion
+ (allout-renumber-to-depth depth))
+ (run-hook-with-args 'allout-structure-deleted-hook depth (point)))))
;;;_ > allout-copy-topic-as-kill ()
(defun allout-copy-topic-as-kill ()
"Like `allout-kill-topic', but save to kill ring instead of deleting."
@@ -4455,9 +4435,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)
@@ -4484,8 +4464,8 @@ Topic exposure is marked with text-properties, to be used by
(allout-unprotected
(let ((inhibit-read-only t)
(buffer-undo-list t))
- ;(remove-text-properties begin end '(allout-was-hidden t))
- )))
+ (remove-text-properties begin (min end (point-max))
+ '(allout-was-hidden t)))))
;;;_ > allout-hide-by-annotation (begin end)
(defun allout-hide-by-annotation (begin end)
"Translate text properties indicating exposure status into actual exposure."
@@ -4496,9 +4476,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,11 +4487,11 @@ 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))
- (overlay-put (make-overlay prev next nil 'front-advance)
- 'category 'allout-exposure-category)
+ (setq next (allout-next-single-char-property-change
+ (point) 'allout-was-hidden nil end))
+ (let ((o (make-overlay prev next nil 'front-advance)))
+ (overlay-put o 'category 'allout-exposure-category)
+ (overlay-put o 'evaporate t))
(allout-deannotate-hidden prev next)
(setq prev next)
(if next (goto-char next)))))
@@ -4608,32 +4587,20 @@ however, are left exactly like normal, non-allout-specific yanks."
(progn (widen)
(forward-char -1)
(narrow-to-region subj-beg (point))))))
- ;; Preserve new bullet if it's a distinctive one, otherwise
- ;; use old one:
- (if (string-match (regexp-quote prefix-bullet)
- allout-distinctive-bullets-string)
- ; Delete from bullet of old to
- ; before bullet of new:
- (progn
- (beginning-of-line)
- (allout-unprotected
- (delete-region (point) subj-beg))
- (set-marker (allout-mark-marker t) subj-end)
- (goto-char subj-beg)
- (allout-end-of-prefix))
- ; Delete base subj prefix,
- ; leaving old one:
- (allout-unprotected
- (progn
- (delete-region (point) (+ (point)
- prefix-len
- (- adjust-to-depth
- subj-depth)))
+ ;; Remove new heading prefix:
+ (allout-unprotected
+ (progn
+ (delete-region (point) (+ (point)
+ prefix-len
+ (- adjust-to-depth
+ subj-depth)))
; and delete residual subj
; prefix digits and space:
- (while (looking-at "[0-9]") (delete-char 1))
- (if (looking-at " ")
- (delete-char 1))))))
+ (while (looking-at "[0-9]") (delete-char 1))
+ (if (looking-at " ")
+ (delete-char 1))))
+ ;; Assert new topic's bullet - minimal effort if unchanged:
+ (allout-rebullet-heading (string-to-char prefix-bullet)))
(exchange-point-and-mark))))
(if rectify-numbering
(progn
@@ -4644,7 +4611,7 @@ however, are left exactly like normal, non-allout-specific yanks."
(goto-char subj-beg)
(if (allout-goto-prefix-doublechecked)
(allout-unprotected
- (allout-rebullet-heading nil ;;; solicit
+ (allout-rebullet-heading nil ;;; instead
(allout-depth) ;;; depth
nil ;;; number-control
nil ;;; index
@@ -4725,7 +4692,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)
@@ -4754,9 +4721,7 @@ by pops to non-distinctive yanks. Bug..."
"Conceal text between FROM and TO if FLAG is non-nil, else reveal it.
Exposure-change hook `allout-exposure-change-hook' is run with the same
-arguments as this function, after the exposure changes are made. (The old
-`allout-view-change-hook' is being deprecated, and eventually will not be
-invoked.)"
+arguments as this function, after the exposure changes are made."
;; We use outline invisibility spec.
(remove-overlays from to 'category 'allout-exposure-category)
@@ -4766,8 +4731,10 @@ invoked.)"
(when (featurep 'xemacs)
(let ((props (symbol-plist 'allout-exposure-category)))
(while props
- (overlay-put o (pop props) (pop props)))))))
- (run-hooks 'allout-view-change-hook)
+ (condition-case nil
+ ;; as of 2008-02-27, xemacs lacks modification-hooks
+ (overlay-put o (pop props) (pop props))
+ (error nil)))))))
(run-hook-with-args 'allout-exposure-change-hook from to flag))
;;;_ > allout-flag-current-subtree (flag)
(defun allout-flag-current-subtree (flag)
@@ -4845,7 +4812,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))
@@ -4969,7 +4936,8 @@ default, they are treated as being uncollapsed."
(and
;; Is the topic all on one line (allowing for trailing blank line)?
(>= (progn (allout-back-to-current-heading)
- (move-end-of-line 1)
+ (let ((inhibit-field-text-motion t))
+ (move-end-of-line 1))
(point))
(allout-end-of-current-subtree (not (looking-at "\n\n"))))
@@ -5397,8 +5365,10 @@ header and body. The elements of that list are:
;; Goto initial topic, and register preceding stuff, if any:
(if (> (allout-goto-prefix-doublechecked) start)
;; First topic follows beginning point -- register preliminary stuff:
- (setq result (list (list 0 "" nil
- (buffer-substring start (1- (point)))))))
+ (setq result
+ (list (list 0 "" nil
+ (buffer-substring-no-properties start
+ (1- (point)))))))
(while (and (not done)
(not (eobp)) ; Loop until we've covered the region.
(not (> (point) end)))
@@ -5417,7 +5387,7 @@ header and body. The elements of that list are:
(setq strings nil)
(while (> next (point)) ; Get all the exposed text in
(setq strings
- (cons (buffer-substring
+ (cons (buffer-substring-no-properties
beg
;To hidden text or end of line:
(progn
@@ -5439,7 +5409,7 @@ header and body. The elements of that list are:
bullet)))
(cond ((listp format)
(list depth
- (if allout-abbreviate-flattened-numbering
+ (if allout-flattened-numbering-abbreviation
(allout-stringify-flat-index format
gone-out)
(allout-stringify-flat-index-plain
@@ -5672,8 +5642,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 "\\\\"
;;"\\\\\\|\\{\\|\\}\\|\\_\\|\\$\\|\\\"\\|\\&\\|\\^\\|\\-\\|\\*\\|#"
@@ -5837,31 +5806,39 @@ With repeat count, copy the exposed portions of entire buffer."
(goto-char start-pt)))
;;;_ #8 Encryption
-;;;_ > allout-toggle-current-subtree-encryption (&optional fetch-pass)
-(defun allout-toggle-current-subtree-encryption (&optional fetch-pass)
- "Encrypt clear or decrypt encoded text of visibly-containing topic's contents.
-
-Optional FETCH-PASS universal argument provokes key-pair encryption with
-single universal argument. With doubled universal argument (value = 16),
-it forces prompting for the passphrase regardless of availability from the
-passphrase cache. With no universal argument, the appropriate passphrase
-is obtained from the cache, if available, else from the user.
-
-Only GnuPG encryption is supported.
-
-\*NOTE WELL* that the encrypted text must be ascii-armored. For gnupg
-encryption, include the option ``armor'' in your ~/.gnupg/gpg.conf file.
-
-Both symmetric-key and key-pair encryption is implemented. Symmetric is
-the default, use a single (x4) universal argument for keypair mode.
-
-Encrypted topic's bullet is set to a `~' to signal that the contents of the
-topic (body and subtopics, but not heading) is pending encryption or
-encrypted. `*' asterisk immediately after the bullet signals that the body
-is encrypted, its' absence means the topic is meant to be encrypted but is
-not. When a file with topics pending encryption is saved, topics pending
-encryption are encrypted. See allout-encrypt-unencrypted-on-saves for
-auto-encryption specifics.
+;;;_ > allout-toggle-current-subtree-encryption (&optional keymode-cue)
+(defun allout-toggle-current-subtree-encryption (&optional keymode-cue)
+ "Encrypt clear or decrypt encoded topic text.
+
+Allout uses emacs 'epg' libary to perform encryption. Symmetric
+and keypair encryption are supported. All encryption is ascii
+armored.
+
+Entry encryption defaults to symmetric key mode unless keypair
+recipients are associated with the file \(see
+`epa-file-encrypt-to') or the function is invoked with a
+\(KEYMODE-CUE) universal argument greater than 1.
+
+When encrypting, KEYMODE-CUE universal argument greater than 1
+causes prompting for recipients for public-key keypair
+encryption. Selecting no recipients results in symmetric key
+encryption.
+
+Further, encrypting with a KEYMODE-CUE universal argument greater
+than 4 - eg, preceded by a doubled Ctrl-U - causes association of
+the specified recipients with the file, replacing those currently
+associated with it. This can be used to deassociate any
+recipients with the file, by selecting no recipients in the
+dialog.
+
+Encrypted topic's bullets are set to a `~' to signal that the
+contents of the topic (body and subtopics, but not heading) is
+pending encryption or encrypted. `*' asterisk immediately after
+the bullet signals that the body is encrypted, its absence means
+the topic is meant to be encrypted but is not currently. When a
+file with topics pending encryption is saved, topics pending
+encryption are encrypted. See allout-encrypt-unencrypted-on-saves
+for auto-encryption specifics.
\*NOTE WELL* that automatic encryption that happens during saves will
default to symmetric encryption -- you must deliberately (re)encrypt key-pair
@@ -5869,59 +5846,35 @@ encrypted topics if you want them to continue to use the key-pair cipher.
Level-one topics, with prefix consisting solely of an `*' asterisk, cannot be
encrypted. If you want to encrypt the contents of a top-level topic, use
-\\[allout-shift-in] to increase its depth.
-
- Passphrase Caching
-
-The encryption passphrase is solicited if not currently available in the
-passphrase cache from a recent encryption action.
-
-The solicited passphrase is retained for reuse in a cache, if enabled. See
-`pgg-cache-passphrase' and `pgg-passphrase-cache-expiry' for details.
-
- Symmetric Passphrase Hinting and Verification
-
-If the file previously had no associated passphrase, or had a different
-passphrase than specified, the user is prompted to repeat the new one for
-corroboration. A random string encrypted by the new passphrase is set on
-the buffer-specific variable `allout-passphrase-verifier-string', for
-confirmation of the passphrase when next obtained, before encrypting or
-decrypting anything with it. This helps avoid mistakenly shifting between
-keys.
-
-If allout customization var `allout-passphrase-verifier-handling' is
-non-nil, an entry for `allout-passphrase-verifier-string' and its value is
-added to an Emacs 'local variables' section at the end of the file, which
-is created if necessary. That setting is for retention of the passphrase
-verifier across Emacs sessions.
-
-Similarly, `allout-passphrase-hint-string' stores a user-provided reminder
-about their passphrase, and `allout-passphrase-hint-handling' specifies
-when the hint is presented, or if passphrase hints are disabled. If
-enabled (see the `allout-passphrase-hint-handling' docstring for details),
-the hint string is stored in the local-variables section of the file, and
-solicited whenever the passphrase is changed."
+\\[allout-shift-in] to increase its depth."
(interactive "P")
(save-excursion
(allout-back-to-current-heading)
- (allout-toggle-subtree-encryption fetch-pass)
- )
- )
-;;;_ > allout-toggle-subtree-encryption (&optional fetch-pass)
-(defun allout-toggle-subtree-encryption (&optional fetch-pass)
+ (allout-toggle-subtree-encryption keymode-cue)))
+;;;_ > allout-toggle-subtree-encryption (&optional keymode-cue)
+(defun allout-toggle-subtree-encryption (&optional keymode-cue)
"Encrypt clear text or decrypt encoded topic contents (body and subtopics.)
-Optional FETCH-PASS universal argument provokes key-pair encryption with
-single universal argument. With doubled universal argument (value = 16),
-it forces prompting for the passphrase regardless of availability from the
-passphrase cache. With no universal argument, the appropriate passphrase
-is obtained from the cache, if available, else from the user.
+Entry encryption defaults to symmetric key mode unless keypair
+recipients are associated with the file \(see
+`epa-file-encrypt-to') or the function is invoked with a
+\(KEYMODE-CUE) universal argument greater than 1.
+
+When encrypting, KEYMODE-CUE universal argument greater than 1
+causes prompting for recipients for public-key keypair
+encryption. Selecting no recipients results in symmetric key
+encryption.
-Currently only GnuPG encryption is supported, and integration
-with gpg-agent is not yet implemented.
+Further, encrypting with a KEYMODE-CUE universal argument greater
+than 4 - eg, preceded by a doubled Ctrl-U - causes association of
+the specified recipients with the file, replacing those currently
+associated with it. This can be used to deassociate any
+recipients with the file, by selecting no recipients in the
+dialog.
-\**NOTE WELL** that the encrypted text must be ascii-armored. For gnupg
-encryption, include the option ``armor'' in your ~/.gnupg/gpg.conf file.
+Encryption and decryption uses the emacs epg library.
+
+Encrypted text will be ascii-armored.
See `allout-toggle-current-subtree-encryption' for more details."
@@ -5959,16 +5912,6 @@ See `allout-toggle-current-subtree-encryption' for more details."
(if was-encrypted "de" "en"))
nil))
;; Assess key parameters:
- (key-info (or
- ;; detect the type by which it is already encrypted
- (and was-encrypted
- (allout-encrypted-key-info subject-text))
- (and (member fetch-pass '(4 (4)))
- '(keypair nil))
- '(symmetric nil)))
- (for-key-type (car key-info))
- (for-key-identity (cadr key-info))
- (fetch-pass (and fetch-pass (member fetch-pass '(16 (16)))))
(was-coding-system buffer-file-coding-system))
(when (not was-encrypted)
@@ -5976,7 +5919,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
@@ -5994,8 +5937,7 @@ See `allout-toggle-current-subtree-encryption' for more details."
(setq result-text
(allout-encrypt-string subject-text was-encrypted
- (current-buffer)
- for-key-type for-key-identity fetch-pass))
+ (current-buffer) keymode-cue))
;; Replace the subtree with the processed product.
(allout-unprotected
@@ -6026,335 +5968,178 @@ See `allout-toggle-current-subtree-encryption' for more details."
(insert "*"))))
(run-hook-with-args 'allout-structure-added-hook
bullet-pos subtree-end))))
-;;;_ > allout-encrypt-string (text decrypt allout-buffer key-type for-key
-;;; fetch-pass &optional retried verifying
-;;; passphrase)
-(defun allout-encrypt-string (text decrypt allout-buffer key-type for-key
- fetch-pass &optional retried rejected
- verifying passphrase)
+;;;_ > allout-encrypt-string (text decrypt allout-buffer keymode-cue
+;;; &optional rejected)
+(defun allout-encrypt-string (text decrypt allout-buffer keymode-cue
+ &optional rejected)
"Encrypt or decrypt message TEXT.
-If DECRYPT is true (default false), then decrypt instead of encrypt.
+Returns the resulting string, or nil if the transformation fails.
-FETCH-PASS (default false) forces fresh prompting for the passphrase.
+If DECRYPT is true (default false), then decrypt instead of encrypt.
-KEY-TYPE, either `symmetric' or `keypair', specifies which type
-of cypher to use.
+ALLOUT-BUFFER identifies the buffer containing the text.
-FOR-KEY is human readable identification of the first of the user's
-eligible secret keys a keypair decryption targets, or else nil.
+Entry encryption defaults to symmetric key mode unless keypair
+recipients are associated with the file \(see
+`epa-file-encrypt-to') or the function is invoked with a
+\(KEYMODE-CUE) universal argument greater than 1.
-Optional RETRIED is for internal use -- conveys the number of failed keys
-that have been solicited in sequence leading to this current call.
+When encrypting, KEYMODE-CUE universal argument greater than 1
+causes prompting for recipients for public-key keypair
+encryption. Selecting no recipients results in symmetric key
+encryption.
-Optional PASSPHRASE enables explicit delivery of the decryption passphrase,
-for verification purposes.
+Further, encrypting with a KEYMODE-CUE universal argument greater
+than 4 - eg, preceded by a doubled Ctrl-U - causes association of
+the specified recipients with the file, replacing those currently
+associated with it. This can be used to deassociate any
+recipients with the file, by selecting no recipients in the
+dialog.
-Optional REJECTED is for internal use -- conveys the number of
+Optional REJECTED is for internal use, to convey the number of
rejections due to matches against
`allout-encryption-ciphertext-rejection-regexps', as limited by
`allout-encryption-ciphertext-rejection-ceiling'.
-Returns the resulting string, or nil if the transformation fails."
-
- (require 'pgg)
-
- (if (not (fboundp 'pgg-encrypt-symmetric))
- (error "Allout encryption depends on a newer version of pgg"))
-
- (let* ((scheme (upcase
- (format "%s" (or pgg-scheme pgg-default-scheme "GPG"))))
- (for-key (and (equal key-type 'keypair)
- (or for-key
- (split-string (read-string
- (format "%s message recipients: "
- scheme))
- "[ \t,]+"))))
- (target-prompt-id (if (equal key-type 'keypair)
- (if (= (length for-key) 1)
- (car for-key) for-key)
- (buffer-name allout-buffer)))
- (target-cache-id (format "%s-%s"
- key-type
- (if (equal key-type 'keypair)
- target-prompt-id
- (or (buffer-file-name allout-buffer)
- target-prompt-id))))
+NOTE: A few GnuPG v2 versions improperly preserve incorrect
+symmetric decryption keys, preventing entry of the correct key on
+subsequent decryption attempts until the cache times-out. That
+can take several minutes. \(Decryption of other entries is not
+affected.) Upgrade your EasyPG version, if you can, and you can
+deliberately clear your gpg-agent's cache by sending it a '-HUP'
+signal."
+
+ (require 'epg)
+ (require 'epa)
+
+ (let* ((epg-context (let* ((context (epg-make-context nil t)))
+ (epg-context-set-passphrase-callback
+ context #'epa-passphrase-callback-function)
+ context))
(encoding (with-current-buffer allout-buffer
buffer-file-coding-system))
(multibyte (with-current-buffer allout-buffer
- enable-multibyte-characters))
- (strip-plaintext-regexps
- (if (not decrypt)
- (allout-get-configvar-values
- 'allout-encryption-plaintext-sanitization-regexps)))
- (reject-ciphertext-regexps
- (if (not decrypt)
- (allout-get-configvar-values
- 'allout-encryption-ciphertext-rejection-regexps)))
+ enable-multibyte-characters))
+ ;; "sanitization" avoids encryption results that are outline structure.
+ (sani-regexps 'allout-encryption-plaintext-sanitization-regexps)
+ (strip-plaintext-regexps (if (not decrypt)
+ (allout-get-configvar-values
+ sani-regexps)))
+ (rejection-regexps 'allout-encryption-ciphertext-rejection-regexps)
+ (reject-ciphertext-regexps (if (not decrypt)
+ (allout-get-configvar-values
+ rejection-regexps)))
(rejected (or rejected 0))
(rejections-left (- allout-encryption-ciphertext-rejection-ceiling
rejected))
- result-text status
+ (keypair-mode (cond (decrypt 'decrypting)
+ ((<= (prefix-numeric-value keymode-cue) 1)
+ 'default)
+ ((<= (prefix-numeric-value keymode-cue) 4)
+ 'prompt)
+ ((> (prefix-numeric-value keymode-cue) 4)
+ 'prompt-save)))
+ (keypair-message (concat "Select encryption recipients.\n"
+ "Symmetric encryption is done if no"
+ " recipients are selected. "))
+ (encrypt-to (and (boundp 'epa-file-encrypt-to) epa-file-encrypt-to))
+ recipients
+ massaged-text
+ result-text
)
- (if (and fetch-pass (not passphrase))
- ;; Force later fetch by evicting passphrase from the cache.
- (pgg-remove-passphrase-from-cache target-cache-id t))
-
- (catch 'encryption-failed
-
- ;; We handle only symmetric-key passphrase caching.
- (if (and (not passphrase)
- (not (equal key-type 'keypair)))
- (setq passphrase (allout-obtain-passphrase for-key
- target-cache-id
- target-prompt-id
- key-type
- allout-buffer
- retried fetch-pass)))
-
- (with-temp-buffer
-
- (insert text)
-
- ;; convey the text characteristics of the original buffer:
- (set-buffer-multibyte multibyte)
- (when encoding
- (set-buffer-file-coding-system encoding)
- (if (not decrypt)
- (encode-coding-region (point-min) (point-max) encoding)))
-
- (when (and strip-plaintext-regexps (not decrypt))
- (dolist (re strip-plaintext-regexps)
- (let ((re (if (listp re) (car re) re))
- (replacement (if (listp re) (cadr re) "")))
- (goto-char (point-min))
- (save-match-data
- (while (re-search-forward re nil t)
- (replace-match replacement nil nil))))))
-
- (cond
-
- ;; symmetric:
- ((equal key-type 'symmetric)
- (setq status
- (if decrypt
-
- (pgg-decrypt (point-min) (point-max) passphrase)
-
- (pgg-encrypt-symmetric (point-min) (point-max)
- passphrase)))
-
- (if status
- (pgg-situate-output (point-min) (point-max))
- ;; failed -- handle passphrase caching
- (if verifying
- (throw 'encryption-failed nil)
- (pgg-remove-passphrase-from-cache target-cache-id t)
- (error "Symmetric-cipher %scryption failed -- %s"
- (if decrypt "de" "en")
- "try again with different passphrase"))))
-
- ;; encrypt `keypair':
- ((not decrypt)
-
- (setq status
-
- (pgg-encrypt for-key
- nil (point-min) (point-max) passphrase))
-
- (if status
- (pgg-situate-output (point-min) (point-max))
- (error (pgg-remove-passphrase-from-cache target-cache-id t)
- (error "encryption failed"))))
-
- ;; decrypt `keypair':
- (t
-
- (setq status
- (pgg-decrypt (point-min) (point-max) passphrase))
-
- (if status
- (pgg-situate-output (point-min) (point-max))
- (error (pgg-remove-passphrase-from-cache target-cache-id t)
- (error "decryption failed")))))
-
- (setq result-text
- (buffer-substring-no-properties
- 1 (- (point-max) (if decrypt 0 1))))
- )
-
- ;; validate result -- non-empty
- (cond ((not result-text)
- (if verifying
- nil
- ;; transform was fruitless, retry w/new passphrase.
- (pgg-remove-passphrase-from-cache target-cache-id t)
- (allout-encrypt-string text decrypt allout-buffer
- key-type for-key nil
- (if retried (1+ retried) 1)
- rejected verifying nil)))
-
- ;; Retry (within limit) if ciphertext contains rejections:
- ((and (not decrypt)
- ;; Check for disqualification of this ciphertext:
- (let ((regexps reject-ciphertext-regexps)
- reject-it)
- (while (and regexps (not reject-it))
- (setq reject-it (string-match (car regexps)
- result-text))
- (pop regexps))
- reject-it))
- (setq rejections-left (1- rejections-left))
- (if (<= rejections-left 0)
- (error (concat "Ciphertext rejected too many times"
- " (%s), per `%s'")
- allout-encryption-ciphertext-rejection-ceiling
- 'allout-encryption-ciphertext-rejection-regexps)
- (allout-encrypt-string text decrypt allout-buffer
- key-type for-key nil
- retried (1+ rejected)
- verifying passphrase)))
- ;; Barf if encryption yields extraordinary control chars:
- ((and (not decrypt)
- (string-match "[\C-a\C-k\C-o-\C-z\C-@]"
- result-text))
- (error (concat "Encryption produced non-armored text, which"
- "conflicts with allout mode -- reconfigure!")))
-
- ;; valid result and just verifying or non-symmetric:
- ((or verifying (not (equal key-type 'symmetric)))
- (if (or verifying decrypt)
- (pgg-add-passphrase-to-cache target-cache-id
- passphrase t))
- result-text)
-
- ;; valid result and regular symmetric -- "register"
- ;; passphrase with mnemonic aids/cache.
- (t
- (set-buffer allout-buffer)
- (if passphrase
- (pgg-add-passphrase-to-cache target-cache-id
- passphrase t))
- (allout-update-passphrase-mnemonic-aids for-key passphrase
- allout-buffer)
- result-text)
- )
- )
- )
- )
-;;;_ > allout-obtain-passphrase (for-key cache-id prompt-id key-type
-;;; allout-buffer retried fetch-pass)
-(defun allout-obtain-passphrase (for-key cache-id prompt-id key-type
- allout-buffer retried fetch-pass)
- "Obtain passphrase for a key from the cache or else from the user.
-
-When obtaining from the user, symmetric-cipher passphrases are verified
-against either, if available and enabled, a random string that was
-encrypted against the passphrase, or else against repeated entry by the
-user for corroboration.
-
-FOR-KEY is the key for which the passphrase is being obtained.
-
-CACHE-ID is the cache id of the key for the passphrase.
-
-PROMPT-ID is the id for use when prompting the user.
-
-KEY-TYPE is either `symmetric' or `keypair'.
-
-ALLOUT-BUFFER is the buffer containing the entry being en/decrypted.
-
-RETRIED is the number of this attempt to obtain this passphrase.
-
-FETCH-PASS causes the passphrase to be solicited from the user, regardless
-of the availability of a cached copy."
-
- (if (not (equal key-type 'symmetric))
- ;; do regular passphrase read on non-symmetric passphrase:
- (pgg-read-passphrase (format "%s passphrase%s: "
- (upcase (format "%s" (or pgg-scheme
- pgg-default-scheme
- "GPG")))
- (if prompt-id
- (format " for %s" prompt-id)
- ""))
- cache-id t)
-
- ;; Symmetric hereon:
-
- (with-current-buffer allout-buffer
- (let* ((hint (if (and (not (string= allout-passphrase-hint-string ""))
- (or (equal allout-passphrase-hint-handling 'always)
- (and (equal allout-passphrase-hint-handling
- 'needed)
- retried)))
- (format " [%s]" allout-passphrase-hint-string)
- ""))
- (retry-message (if retried (format " (%s retry)" retried) ""))
- (prompt-sans-hint (format "'%s' symmetric passphrase%s: "
- prompt-id retry-message))
- (full-prompt (format "'%s' symmetric passphrase%s%s: "
- prompt-id hint retry-message))
- (prompt full-prompt)
- (verifier-string (allout-get-encryption-passphrase-verifier))
-
- (cached (and (not fetch-pass)
- (pgg-read-passphrase-from-cache cache-id t)))
- (got-pass (or cached
- (pgg-read-passphrase full-prompt cache-id t)))
- confirmation)
-
- (if (not got-pass)
- nil
+ ;; Massage the subject text for encoding and filtering.
+ (with-temp-buffer
+ (insert text)
+ ;; convey the text characteristics of the original buffer:
+ (set-buffer-multibyte multibyte)
+ (when encoding
+ (set-buffer-file-coding-system encoding)
+ (if (not decrypt)
+ (encode-coding-region (point-min) (point-max) encoding)))
+
+ ;; remove sanitization regexps matches before encrypting:
+ (when (and strip-plaintext-regexps (not decrypt))
+ (dolist (re strip-plaintext-regexps)
+ (let ((re (if (listp re) (car re) re))
+ (replacement (if (listp re) (cadr re) "")))
+ (goto-char (point-min))
+ (save-match-data
+ (while (re-search-forward re nil t)
+ (replace-match replacement nil nil))))))
+ (setq massaged-text (buffer-substring-no-properties (point-min)
+ (point-max))))
+ ;; determine key mode and, if keypair, recipients:
+ (setq recipients
+ (case keypair-mode
+
+ (decrypting nil)
+
+ (default (if encrypt-to (epg-list-keys epg-context encrypt-to)))
+
+ ((prompt prompt-save)
+ (save-window-excursion
+ (epa-select-keys epg-context keypair-message)))))
+
+ (setq result-text
+ (if decrypt
+ (condition-case err
+ (epg-decrypt-string epg-context
+ (encode-coding-string massaged-text
+ (or encoding 'utf-8)))
+ (epg-error
+ (signal 'egp-error
+ (cons (concat (cadr err) " - gpg version problem?")
+ (cddr err)))))
+ (replace-regexp-in-string "\n$" ""
+ (epg-encrypt-string epg-context
+ (encode-coding-string massaged-text
+ (or encoding 'utf-8))
+ recipients))))
+
+ ;; validate result -- non-empty
+ (if (not result-text)
+ (error "%scryption failed." (if decrypt "De" "En")))
+
+
+ (when (eq keypair-mode 'prompt-save)
+ ;; set epa-file-encrypt-to in the buffer:
+ (setq epa-file-encrypt-to (mapcar (lambda (key)
+ (epg-user-id-string
+ (car (epg-key-user-id-list key))))
+ recipients))
+ ;; change the file variable:
+ (allout-adjust-file-variable "epa-file-encrypt-to" epa-file-encrypt-to))
- ;; Duplicate our handle on the passphrase so it's not clobbered by
- ;; deactivate-passwd memory clearing:
- (setq got-pass (copy-sequence got-pass))
-
- (cond (verifier-string
- (save-window-excursion
- (if (allout-encrypt-string verifier-string 'decrypt
- allout-buffer 'symmetric
- for-key nil 0 0 'verifying
- (copy-sequence got-pass))
- (setq confirmation (format "%s" got-pass))))
-
- (if (and (not confirmation)
- (if (yes-or-no-p
- (concat "Passphrase differs from established"
- " -- use new one instead? "))
- ;; deactivate password for subsequent
- ;; confirmation:
- (progn
- (pgg-remove-passphrase-from-cache cache-id t)
- (setq prompt prompt-sans-hint)
- nil)
- t))
- (progn (pgg-remove-passphrase-from-cache cache-id t)
- (error "Wrong passphrase"))))
- ;; No verifier string -- force confirmation by repetition of
- ;; (new) passphrase:
- ((or fetch-pass (not cached))
- (pgg-remove-passphrase-from-cache cache-id t))))
- ;; confirmation vs new input -- doing pgg-read-passphrase will do the
- ;; right thing, in either case:
- (if (not confirmation)
- (setq confirmation
- (pgg-read-passphrase (concat prompt
- " ... confirm spelling: ")
- cache-id t)))
- (prog1
- (if (equal got-pass confirmation)
- confirmation
- (if (yes-or-no-p (concat "spelling of original and"
- " confirmation differ -- retry? "))
- (progn (setq retried (if retried (1+ retried) 1))
- (pgg-remove-passphrase-from-cache cache-id t)
- ;; recurse to this routine:
- (pgg-read-passphrase prompt-sans-hint cache-id t))
- (pgg-remove-passphrase-from-cache cache-id t)
- (error "Confirmation failed"))))))))
+ (cond
+ ;; Retry (within limit) if ciphertext contains rejections:
+ ((and (not decrypt)
+ ;; Check for disqualification of this ciphertext:
+ (let ((regexps reject-ciphertext-regexps)
+ reject-it)
+ (while (and regexps (not reject-it))
+ (setq reject-it (string-match (car regexps) result-text))
+ (pop regexps))
+ reject-it))
+ (setq rejections-left (1- rejections-left))
+ (if (<= rejections-left 0)
+ (error (concat "Ciphertext rejected too many times"
+ " (%s), per `%s'")
+ allout-encryption-ciphertext-rejection-ceiling
+ 'allout-encryption-ciphertext-rejection-regexps)
+ ;; try again (gpg-agent may have the key cached):
+ (allout-encrypt-string text decrypt allout-buffer keypair-mode
+ (1+ rejected))))
+
+ ;; Barf if encryption yields extraordinary control chars:
+ ((and (not decrypt)
+ (string-match "[\C-a\C-k\C-o-\C-z\C-@]"
+ result-text))
+ (error (concat "Encryption produced non-armored text, which"
+ "conflicts with allout mode -- reconfigure!")))
+
+ (t result-text))))
;;;_ > allout-encrypted-topic-p ()
(defun allout-encrypted-topic-p ()
"True if the current topic is encryptable and encrypted."
@@ -6365,128 +6150,6 @@ of the availability of a cached copy."
(save-match-data (looking-at "\\*")))
)
)
-;;;_ > allout-encrypted-key-info (text)
-;; XXX gpg-specific, alas
-(defun allout-encrypted-key-info (text)
- "Return a pair of the key type and identity of a recipient's secret key.
-
-The key type is one of `symmetric' or `keypair'.
-
-If `keypair', and some of the user's secret keys are among those for which
-the message was encoded, return the identity of the first. Otherwise,
-return nil for the second item of the pair.
-
-An error is raised if the text is not encrypted."
- (require 'pgg-parse)
- (save-excursion
- (with-temp-buffer
- (insert text)
- (let* ((parsed-armor (pgg-parse-armor-region (point-min) (point-max)))
- (type (if (pgg-gpg-symmetric-key-p parsed-armor)
- 'symmetric
- 'keypair))
- secret-keys first-secret-key for-key-owner)
- (if (equal type 'keypair)
- (setq secret-keys (pgg-gpg-lookup-all-secret-keys)
- first-secret-key (pgg-gpg-select-matching-key parsed-armor
- secret-keys)
- for-key-owner (and first-secret-key
- (pgg-gpg-lookup-key-owner
- first-secret-key))))
- (list type (pgg-gpg-key-id-from-key-owner for-key-owner))
- )
- )
- )
- )
-;;;_ > allout-create-encryption-passphrase-verifier (passphrase)
-(defun allout-create-encryption-passphrase-verifier (passphrase)
- "Encrypt random message for later validation of symmetric key's passphrase."
- ;; use 20 random ascii characters, across the entire ascii range.
- (random t)
- (let ((spew (make-string 20 ?\0)))
- (dotimes (i (length spew))
- (aset spew i (1+ (random 254))))
- (allout-encrypt-string spew nil (current-buffer) 'symmetric
- nil nil 0 0 passphrase))
- )
-;;;_ > allout-update-passphrase-mnemonic-aids (for-key passphrase
-;;; outline-buffer)
-(defun allout-update-passphrase-mnemonic-aids (for-key passphrase
- outline-buffer)
- "Update passphrase verifier and hint strings if necessary.
-
-See `allout-passphrase-verifier-string' and `allout-passphrase-hint-string'
-settings.
-
-PASSPHRASE is the passphrase being mnemonicized.
-
-OUTLINE-BUFFER is the buffer of the outline being adjusted.
-
-These are used to help the user keep track of the passphrase they use for
-symmetric encryption in the file.
-
-Behavior is governed by `allout-passphrase-verifier-handling',
-`allout-passphrase-hint-handling', and also, controlling whether the values
-are preserved on Emacs local file variables,
-`allout-enable-file-variable-adjustment'."
-
- ;; If passphrase doesn't agree with current verifier:
- ;; - adjust the verifier
- ;; - if passphrase hint handling is enabled, adjust the passphrase hint
- ;; - if file var settings are enabled, adjust the file vars
-
- (let* ((new-verifier-needed (not (allout-verify-passphrase
- for-key passphrase outline-buffer)))
- (new-verifier-string
- (if new-verifier-needed
- ;; Collapse to a single line and enclose in string quotes:
- (subst-char-in-string
- ?\n ?\C-a (allout-create-encryption-passphrase-verifier
- passphrase))))
- new-hint)
- (when new-verifier-string
- ;; do the passphrase hint first, since it's interactive
- (when (and allout-passphrase-hint-handling
- (not (equal allout-passphrase-hint-handling 'disabled)))
- (setq new-hint
- (read-from-minibuffer "Passphrase hint to jog your memory: "
- allout-passphrase-hint-string))
- (when (not (string= new-hint allout-passphrase-hint-string))
- (setq allout-passphrase-hint-string new-hint)
- (allout-adjust-file-variable "allout-passphrase-hint-string"
- allout-passphrase-hint-string)))
- (when allout-passphrase-verifier-handling
- (setq allout-passphrase-verifier-string new-verifier-string)
- (allout-adjust-file-variable "allout-passphrase-verifier-string"
- allout-passphrase-verifier-string))
- )
- )
- )
-;;;_ > allout-get-encryption-passphrase-verifier ()
-(defun allout-get-encryption-passphrase-verifier ()
- "Return text of the encrypt passphrase verifier, unmassaged, or nil if none.
-
-Derived from value of `allout-passphrase-verifier-string'."
-
- (let ((verifier-string (and (boundp 'allout-passphrase-verifier-string)
- allout-passphrase-verifier-string)))
- (if verifier-string
- ;; Return it uncollapsed
- (subst-char-in-string ?\C-a ?\n verifier-string))
- )
- )
-;;;_ > allout-verify-passphrase (key passphrase allout-buffer)
-(defun allout-verify-passphrase (key passphrase allout-buffer)
- "True if passphrase successfully decrypts verifier, nil otherwise.
-
-\"Otherwise\" includes absence of passphrase verifier."
- (with-current-buffer allout-buffer
- (and (boundp 'allout-passphrase-verifier-string)
- allout-passphrase-verifier-string
- (allout-encrypt-string (allout-get-encryption-passphrase-verifier)
- 'decrypt allout-buffer 'symmetric
- key nil 0 0 'verifying passphrase)
- t)))
;;;_ > allout-next-topic-pending-encryption (&optional except-mark)
(defun allout-next-topic-pending-encryption (&optional except-mark)
"Return the point of the next topic pending encryption, or nil if none.
@@ -6605,12 +6268,13 @@ save. See `allout-encrypt-unencrypted-on-saves' for more info."
(defun outlineify-sticky (&optional arg)
"Activate outline mode and establish file var so it is started subsequently.
-See doc-string for `allout-layout' and `allout-init' for details on
-setup for auto-startup."
+See `allout-layout' and customization of `allout-auto-activation'
+for details on preparing emacs for automatic allout activation."
(interactive "P")
- (allout-mode t)
+ (if (allout-mode-p) (allout-mode)) ; deactivate so we can re-activate...
+ (allout-mode)
(save-excursion
(goto-char (point-min))
@@ -6831,6 +6495,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 +6613,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 +6663,34 @@ 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-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 +6722,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 +6741,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 +6755,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 +6770,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 +6798,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 +6851,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 023f61c879d..ff7edf40dcb 100644
--- a/lisp/ansi-color.el
+++ b/lisp/ansi-color.el
@@ -1,7 +1,6 @@
;;; ansi-color.el --- translate ANSI escape sequences into faces
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Alex Schroeder <alex@gnu.org>
;; Maintainer: Alex Schroeder <alex@gnu.org>
@@ -133,8 +132,18 @@ Parameter Color
37 47 white
This vector is used by `ansi-color-make-color-map' to create a color
-map. This color map is stored in the variable `ansi-color-map'."
- :type '(vector string string string string string string string string)
+map. This color map is stored in the variable `ansi-color-map'.
+
+Each element may also be a cons cell where the car and cdr specify the
+foreground and background colors, respectively."
+ :type '(vector (choice color (cons color color))
+ (choice color (cons color color))
+ (choice color (cons color color))
+ (choice color (cons color color))
+ (choice color (cons color color))
+ (choice color (cons color color))
+ (choice color (cons color color))
+ (choice color (cons color color)))
:set 'ansi-color-map-update
:initialize 'custom-initialize-default
:group 'ansi-colors)
@@ -215,48 +224,10 @@ This is a good function to put in `comint-output-filter-functions'."
(add-hook 'comint-output-filter-functions
'ansi-color-process-output)
-
-;; Alternative font-lock-unfontify-region-function for Emacs only
-
-(defun ansi-color-unfontify-region (beg end &rest xemacs-stuff)
- "Replacement function for `font-lock-default-unfontify-region'.
-
-As text properties are implemented using extents in XEmacs, this
-function is probably not needed. In Emacs, however, things are a bit
-different: When font-lock is active in a buffer, you cannot simply add
-face text properties to the buffer. Font-lock will remove the face
-text property using `font-lock-unfontify-region-function'. If you want
-to insert the strings returned by `ansi-color-apply' into such buffers,
-you must set `font-lock-unfontify-region-function' to
-`ansi-color-unfontify-region'. This function will not remove all face
-text properties unconditionally. It will keep the face text properties
-if the property `ansi-color' is set.
-
-The region from BEG to END is unfontified. XEMACS-STUFF is ignored.
-
-A possible way to install this would be:
-
-\(add-hook 'font-lock-mode-hook
- \(function (lambda ()
- \(setq font-lock-unfontify-region-function
- 'ansi-color-unfontify-region))))"
- ;; Simplified now that font-lock-unfontify-region uses save-buffer-state.
- (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
- ;; positions with the ansi-color property set, and remove the
- ;; remaining face test-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)
- (let ((end-face (or (text-property-any beg end 'face nil)
- end)))
- (remove-text-properties beg end-face '(face nil))
- (setq beg end-face)))))
+(defalias 'ansi-color-unfontify-region 'font-lock-default-unfontify-region)
+(make-obsolete 'ansi-color-unfontify-region "not needed any more" "24.1")
;; Working with strings
-
(defvar ansi-color-context nil
"Context saved between two calls to `ansi-color-apply'.
This is a list of the form (FACES FRAGMENT) or nil. FACES is a list of
@@ -290,9 +261,7 @@ This function can be added to `comint-preoutput-filter-functions'."
(setq fragment (substring string pos)
result (concat result (substring string start pos))))
(setq result (concat result (substring string start))))
- (if fragment
- (setq ansi-color-context (list nil fragment))
- (setq ansi-color-context nil)))
+ (setq ansi-color-context (if fragment (list nil fragment))))
result))
(defun ansi-color-apply (string)
@@ -309,10 +278,7 @@ Every call to this function will set and use the buffer-local variable
This information will be used for the next call to `ansi-color-apply'.
Set `ansi-color-context' to nil if you don't want this.
-This function can be added to `comint-preoutput-filter-functions'.
-
-You cannot insert the strings returned into buffers using font-lock.
-See `ansi-color-unfontify-region' for a way around this."
+This function can be added to `comint-preoutput-filter-functions'."
(let ((face (car ansi-color-context))
(start 0) end escape-sequence result
colorized-substring)
@@ -325,8 +291,7 @@ See `ansi-color-unfontify-region' for a way around this."
(setq escape-sequence (match-string 1 string))
;; Colorize the old block from start to end using old face.
(when face
- (put-text-property start end 'ansi-color t string)
- (put-text-property start end 'face face string))
+ (put-text-property start end 'font-lock-face face string))
(setq colorized-substring (substring string start end)
start (match-end 0))
;; Eliminate unrecognized ANSI sequences.
@@ -338,8 +303,7 @@ See `ansi-color-unfontify-region' for a way around this."
(setq face (ansi-color-apply-sequence escape-sequence face)))
;; if the rest of the string should have a face, put it there
(when face
- (put-text-property start (length string) 'ansi-color t string)
- (put-text-property start (length string) 'face face string))
+ (put-text-property start (length string) 'font-lock-face face string))
;; save context, add the remainder of the string to the result
(let (fragment)
(if (string-match "\033" string start)
@@ -347,9 +311,7 @@ See `ansi-color-unfontify-region' for a way around this."
(setq fragment (substring string pos))
(push (substring string start pos) result))
(push (substring string start) result))
- (if (or face fragment)
- (setq ansi-color-context (list face fragment))
- (setq ansi-color-context nil)))
+ (setq ansi-color-context (if (or face fragment) (list face fragment))))
(apply 'concat (nreverse result))))
;; Working with regions
@@ -576,7 +538,8 @@ The face definitions are based upon the variables
(mapc
(function (lambda (e)
(aset ansi-color-map index
- (ansi-color-make-face 'foreground e))
+ (ansi-color-make-face 'foreground
+ (if (consp e) (car e) e)))
(setq index (1+ index)) ))
ansi-color-names-vector)
;; background attributes
@@ -584,7 +547,8 @@ The face definitions are based upon the variables
(mapc
(function (lambda (e)
(aset ansi-color-map index
- (ansi-color-make-face 'background e))
+ (ansi-color-make-face 'background
+ (if (consp e) (cdr e) e)))
(setq index (1+ index)) ))
ansi-color-names-vector)
ansi-color-map))
@@ -641,5 +605,4 @@ ESCAPE-SEQ is a SGR control sequences such as \\033[34m. The parameter
(provide 'ansi-color)
-;; arch-tag: 00726118-9432-44fd-b72d-d2af7591c99c
;;; ansi-color.el ends here
diff --git a/lisp/apropos.el b/lisp/apropos.el
index 82d656f9f62..d3d66f2a070 100644
--- a/lisp/apropos.el
+++ b/lisp/apropos.el
@@ -1,11 +1,11 @@
;;; apropos.el --- apropos commands for users and programmers
-;; Copyright (C) 1989, 1994, 1995, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1989, 1994-1995, 2001-2011 Free Software Foundation, Inc.
;; Author: Joe Wells <jbw@bigbird.bu.edu>
;; Daniel Pfeiffer <occitan@esperanto.org> (rewrite)
;; Keywords: help
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -83,7 +83,7 @@ Slows them down more or less. Set this non-nil if you have a fast machine."
:group 'apropos
:type 'face)
-(defcustom apropos-label-face '(italic variable-pitch)
+(defcustom apropos-label-face '(italic)
"Face for label (`Command', `Variable' ...) in Apropos output.
A value of nil means don't use any special font for them, and also
turns off mouse highlighting."
@@ -121,15 +121,12 @@ If value is `verbose', the computed score is shown for each match."
(const :tag "show scores" verbose)))
(defvar apropos-mode-map
- (let ((map (make-sparse-keymap)))
- (set-keymap-parent map button-buffer-map)
+ (let ((map (copy-keymap button-buffer-map)))
+ (set-keymap-parent map special-mode-map)
;; Use `apropos-follow' instead of just using the button
;; definition of RET, so that users can use it anywhere in an
;; apropos item, not just on top of a button.
(define-key map "\C-m" 'apropos-follow)
- (define-key map " " 'scroll-up)
- (define-key map "\177" 'scroll-down)
- (define-key map "q" 'quit-window)
map)
"Keymap used in Apropos mode.")
@@ -158,7 +155,17 @@ If value is `verbose', the computed score is shown for each match."
"List of elc files already scanned in current run of `apropos-documentation'.")
(defvar apropos-accumulator ()
- "Alist of symbols already found in current apropos run.")
+ "Alist of symbols already found in current apropos run.
+Each element has the form
+
+ (SYMBOL SCORE FUN-DOC VAR-DOC PLIST WIDGET-DOC FACE-DOC CUS-GROUP-DOC)
+
+where SYMBOL is the symbol name, SCORE is its relevance score (a
+number), FUN-DOC is the function docstring, VAR-DOC is the
+variable docstring, PLIST is the list of the symbols names in the
+property list, WIDGET-DOC is the widget docstring, FACE-DOC is
+the face docstring, and CUS-GROUP-DOC is the custom group
+docstring. Each docstring is either nil or a string.")
(defvar apropos-item ()
"Current item in or for `apropos-accumulator'.")
@@ -190,6 +197,7 @@ term, and the rest of the words are alternative terms.")
(define-button-type 'apropos-function
'apropos-label "Function"
'apropos-short-label "f"
+ 'face '(font-lock-function-name-face button)
'help-echo "mouse-2, RET: Display more help on this function"
'follow-link t
'action (lambda (button)
@@ -198,6 +206,7 @@ term, and the rest of the words are alternative terms.")
(define-button-type 'apropos-macro
'apropos-label "Macro"
'apropos-short-label "m"
+ 'face '(font-lock-function-name-face button)
'help-echo "mouse-2, RET: Display more help on this macro"
'follow-link t
'action (lambda (button)
@@ -206,6 +215,7 @@ term, and the rest of the words are alternative terms.")
(define-button-type 'apropos-command
'apropos-label "Command"
'apropos-short-label "c"
+ 'face '(font-lock-function-name-face button)
'help-echo "mouse-2, RET: Display more help on this command"
'follow-link t
'action (lambda (button)
@@ -219,6 +229,7 @@ term, and the rest of the words are alternative terms.")
(define-button-type 'apropos-variable
'apropos-label "Variable"
'apropos-short-label "v"
+ 'face '(font-lock-variable-name-face button)
'help-echo "mouse-2, RET: Display more help on this variable"
'follow-link t
'action (lambda (button)
@@ -227,6 +238,7 @@ term, and the rest of the words are alternative terms.")
(define-button-type 'apropos-face
'apropos-label "Face"
'apropos-short-label "F"
+ 'face '(font-lock-variable-name-face button)
'help-echo "mouse-2, RET: Display more help on this face"
'follow-link t
'action (lambda (button)
@@ -235,6 +247,7 @@ term, and the rest of the words are alternative terms.")
(define-button-type 'apropos-group
'apropos-label "Group"
'apropos-short-label "g"
+ 'face '(font-lock-builtin-face button)
'help-echo "mouse-2, RET: Display more help on this group"
'follow-link t
'action (lambda (button)
@@ -244,14 +257,16 @@ term, and the rest of the words are alternative terms.")
(define-button-type 'apropos-widget
'apropos-label "Widget"
'apropos-short-label "w"
+ 'face '(font-lock-builtin-face button)
'help-echo "mouse-2, RET: Display more help on this widget"
'follow-link t
'action (lambda (button)
(widget-browse-other-window (button-get button 'apropos-symbol))))
(define-button-type 'apropos-plist
- 'apropos-label "Plist"
+ 'apropos-label "Properties"
'apropos-short-label "p"
+ 'face '(font-lock-keyword-face button)
'help-echo "mouse-2, RET: Display more help on this plist"
'follow-link t
'action (lambda (button)
@@ -374,8 +389,8 @@ Value is a list of offsets of the words into the string."
"Return apropos score for documentation string DOC."
(let ((l (length doc)))
(if (> l 0)
- (let ((score 0) i)
- (when (setq i (string-match apropos-pattern-quoted doc))
+ (let ((score 0))
+ (when (string-match apropos-pattern-quoted doc)
(setq score 10000))
(dolist (s (apropos-calc-scores doc apropos-all-words) score)
(setq score (+ score 50 (/ (* (- l s) 50) l)))))
@@ -410,7 +425,7 @@ This requires that at least 2 keywords (unless only one was given)."
"Return t if DOC is really matched by the current keywords."
(apropos-true-hit doc apropos-all-words))
-(define-derived-mode apropos-mode fundamental-mode "Apropos"
+(define-derived-mode apropos-mode special-mode "Apropos"
"Major mode for following hyperlinks in output of apropos commands.
\\{apropos-mode-map}")
@@ -639,15 +654,15 @@ thus be found in `load-history'."
"(not documented)"))
(when (boundp symbol)
(apropos-documentation-property
- symbol 'variable-documentation t))
- (when (setq properties (symbol-plist symbol))
- (setq doc (list (car properties)))
- (while (setq properties (cdr (cdr properties)))
- (setq doc (cons (car properties) doc)))
- (mapconcat #'symbol-name (nreverse doc) " "))
- (when (get symbol 'widget-type)
- (apropos-documentation-property
- symbol 'widget-documentation t))
+ symbol 'variable-documentation t))
+ (when (setq properties (symbol-plist symbol))
+ (setq doc (list (car properties)))
+ (while (setq properties (cdr (cdr properties)))
+ (setq doc (cons (car properties) doc)))
+ (mapconcat #'symbol-name (nreverse doc) " "))
+ (when (get symbol 'widget-type)
+ (apropos-documentation-property
+ symbol 'widget-documentation t))
(when (facep symbol)
(let ((alias (get symbol 'face-alias)))
(if alias
@@ -663,8 +678,8 @@ thus be found in `load-history'."
(apropos-documentation-property
symbol 'face-documentation t))))
(when (get symbol 'custom-group)
- (apropos-documentation-property
- symbol 'group-documentation t)))))
+ (apropos-documentation-property
+ symbol 'group-documentation t)))))
symbols)))
(apropos-print keys nil text)))
@@ -975,18 +990,13 @@ If non-nil TEXT is a string that will be printed as a heading."
(with-output-to-temp-buffer "*Apropos*"
(let ((p apropos-accumulator)
(old-buffer (current-buffer))
+ (inhibit-read-only t)
symbol item)
(set-buffer standard-output)
(apropos-mode)
- (if (display-mouse-p)
- (insert
- "If moving the mouse over text changes the text's color, "
- "you can click\n"
- "or press return on that text to get more information.\n"))
- (insert "In this buffer, go to the name of the command, or function,"
- " or variable,\n"
- (substitute-command-keys
- "and type \\[apropos-follow] to get full documentation.\n\n"))
+ (insert (substitute-command-keys "Type \\[apropos-follow] on ")
+ (if apropos-multi-type "a type label" "an entry")
+ " to view its full documentation.\n\n")
(if text (insert text "\n\n"))
(dolist (apropos-item p)
(when (and spacing (not (bobp)))
@@ -1068,8 +1078,7 @@ If non-nil TEXT is a string that will be printed as a heading."
(apropos-print-doc 5 'apropos-widget t)
(apropos-print-doc 4 'apropos-plist nil))
(set (make-local-variable 'truncate-partial-width-windows) t)
- (set (make-local-variable 'truncate-lines) t)
- (setq buffer-read-only t))))
+ (set (make-local-variable 'truncate-lines) t))))
(prog1 apropos-accumulator
(setq apropos-accumulator ()))) ; permit gc
@@ -1085,30 +1094,51 @@ If non-nil TEXT is a string that will be printed as a heading."
(defun apropos-print-doc (i type do-keys)
- (when (stringp (setq i (nth i apropos-item)))
- (if apropos-compact-layout
- (insert (propertize "\t" 'display '(space :align-to 32)) " ")
- (insert " "))
- (if (null apropos-multi-type)
- ;; If the query is only for a single type, there's no point
- ;; writing it over and over again. Insert a blank button, and
- ;; put the 'apropos-label property there (needed by
- ;; apropos-symbol-button-display-help).
- (insert-text-button
+ (let ((doc (nth i apropos-item)))
+ (when (stringp doc)
+ (if apropos-compact-layout
+ (insert (propertize "\t" 'display '(space :align-to 32)) " ")
+ (insert " "))
+ (if apropos-multi-type
+ (let ((button-face (button-type-get type 'face)))
+ (unless (consp button-face)
+ (setq button-face (list button-face)))
+ (insert-text-button
+ (if apropos-compact-layout
+ (format "<%s>" (button-type-get type 'apropos-short-label))
+ (button-type-get type 'apropos-label))
+ 'type type
+ ;; Can't use the default button face, since user may have changed the
+ ;; variable! Just say `no' to variables containing faces!
+ 'face (append button-face apropos-label-face)
+ 'apropos-symbol (car apropos-item))
+ (insert (if apropos-compact-layout " " ": ")))
+
+ ;; If the query is only for a single type, there's no point
+ ;; writing it over and over again. Insert a blank button, and
+ ;; put the 'apropos-label property there (needed by
+ ;; apropos-symbol-button-display-help).
+ (insert-text-button
" " 'type type 'skip t
- 'face 'default 'apropos-symbol (car apropos-item))
- (insert-text-button
- (if apropos-compact-layout
- (format "<%s>" (button-type-get type 'apropos-short-label))
- (button-type-get type 'apropos-label))
- 'type type
- ;; Can't use the default button face, since user may have changed the
- ;; variable! Just say `no' to variables containing faces!
- 'face apropos-label-face
- 'apropos-symbol (car apropos-item))
- (insert (if apropos-compact-layout " " ": ")))
- (insert (if do-keys (substitute-command-keys i) i))
- (or (bolp) (terpri))))
+ 'face 'default 'apropos-symbol (car apropos-item)))
+
+ (let ((opoint (point))
+ (ocol (current-column)))
+ (cond ((equal doc "")
+ (setq doc "(not documented)"))
+ (do-keys
+ (setq doc (substitute-command-keys doc))))
+ (insert doc)
+ (if (equal doc "(not documented)")
+ (put-text-property opoint (point) 'font-lock-face 'shadow))
+ ;; The labeling buttons might make the line too long, so fill it if
+ ;; necessary.
+ (let ((fill-column (+ 5 (if (integerp emacs-lisp-docstring-fill-column)
+ emacs-lisp-docstring-fill-column
+ fill-column)))
+ (fill-prefix (make-string ocol ?\s)))
+ (fill-region opoint (point) nil t)))
+ (or (bolp) (terpri)))))
(defun apropos-follow ()
"Invokes any button at point, otherwise invokes the nearest label button."
@@ -1136,5 +1166,4 @@ If non-nil TEXT is a string that will be printed as a heading."
(provide 'apropos)
-;; arch-tag: d56fa2ac-e56b-4ce3-84ff-852f9c0dc66e
;;; apropos.el ends here
diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el
index bfa3a6938c7..0d129856f1d 100644
--- a/lisp/arc-mode.el
+++ b/lisp/arc-mode.el
@@ -1,7 +1,6 @@
;;; arc-mode.el --- simple editing of archives
-;; Copyright (C) 1995, 1997, 1998, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 1997-1998, 2001-2011 Free Software Foundation, Inc.
;; Author: Morten Welinder <terra@gnu.org>
;; Keywords: files archives msdog editing major-mode
@@ -52,17 +51,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 +216,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 +314,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
@@ -326,7 +339,7 @@ Archive and member name will be added."
(defvar archive-local-name nil "Name of local copy of remote archive.")
(defvar archive-mode-map
(let ((map (make-keymap)))
- (suppress-keymap map)
+ (set-keymap-parent map special-mode-map)
(define-key map " " 'archive-next-line)
(define-key map "a" 'archive-alternate-display)
;;(define-key map "c" 'archive-copy)
@@ -335,15 +348,12 @@ Archive and member name will be added."
(define-key map "e" 'archive-extract)
(define-key map "f" 'archive-extract)
(define-key map "\C-m" 'archive-extract)
- (define-key map "g" 'revert-buffer)
- (define-key map "h" 'describe-mode)
(define-key map "m" 'archive-mark)
(define-key map "n" 'archive-next-line)
(define-key map "\C-n" 'archive-next-line)
(define-key map [down] 'archive-next-line)
(define-key map "o" 'archive-extract-other-window)
(define-key map "p" 'archive-previous-line)
- (define-key map "q" 'quit-window)
(define-key map "\C-p" 'archive-previous-line)
(define-key map [up] 'archive-previous-line)
(define-key map "r" 'archive-rename-entry)
@@ -602,7 +612,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 +742,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 +1058,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 +1092,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))))
@@ -1375,7 +1386,7 @@ as a relative change like \"g+rw\" as for chmod(2)."
(error "Renaming is not supported for this archive type"))))
;; Revert the buffer and recompute the dired-like listing.
-(defun archive-mode-revert (&optional no-auto-save no-confirm)
+(defun archive-mode-revert (&optional _no-auto-save _no-confirm)
(let ((no (archive-get-lineno)))
(setq archive-files nil)
(let ((revert-buffer-function nil)
@@ -1787,20 +1798,27 @@ 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
;; not on DOS/Windows, since that fails extraction on those
- ;; systems, and file names with wildcards in zip archives don't
- ;; work there anyway.
+ ;; systems (unless w32-quote-process-args is nil), and file names
+ ;; with wildcards in zip archives don't work there anyway.
;; FIXME: Does pkunzip need similar treatment?
- (if (and (not (memq system-type '(windows-nt ms-dos)))
+ (if (and (or (not (memq system-type '(windows-nt ms-dos)))
+ (and (boundp 'w32-quote-process-args)
+ (null w32-quote-process-args)))
(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 +2026,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 +2211,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 7cde3508cce..211124964a5 100644
--- a/lisp/array.el
+++ b/lisp/array.el
@@ -1,7 +1,6 @@
;;; array.el --- array editing commands for GNU Emacs
-;; Copyright (C) 1987, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1987, 2000-2011 Free Software Foundation, Inc.
;; Author: David M. Brown
;; Maintainer: FSF
@@ -748,9 +747,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 +772,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 +900,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/autoarg.el b/lisp/autoarg.el
index 693163d0db9..378ec1318b1 100644
--- a/lisp/autoarg.el
+++ b/lisp/autoarg.el
@@ -1,7 +1,6 @@
;;; autoarg.el --- make digit keys supply prefix args
-;; Copyright (C) 1998, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 2000-2011 Free Software Foundation, Inc.
;; Author: Dave Love <fx@gnu.org>
;; Created: 1998-09-04
@@ -144,5 +143,4 @@ which invoked this function, excluding the Autoarg keymap."
(provide 'autoarg)
-;; arch-tag: 2ba2ab4f-d60e-402a-ae4d-37e29af723c2
;;; autoarg.el ends here
diff --git a/lisp/autoinsert.el b/lisp/autoinsert.el
index 1a4ef592840..5793c3180be 100644
--- a/lisp/autoinsert.el
+++ b/lisp/autoinsert.el
@@ -1,7 +1,7 @@
;;; autoinsert.el --- automatic mode-dependent insertion of text into new files
-;; Copyright (C) 1985, 1986, 1987, 1994, 1995, 1998, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1987, 1994-1995, 1998, 2000-2011
+;; Free Software Foundation, Inc.
;; Author: Charlie Martin <crm@cs.duke.edu>
;; Adapted-By: Daniel Pfeiffer <occitan@esperanto.org>
@@ -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)
@@ -410,5 +410,4 @@ insert a template for the file depending on the mode of the buffer."
(provide 'autoinsert)
-;; arch-tag: 5b6630ac-c735-43cf-b097-b78c622af909
;;; autoinsert.el ends here
diff --git a/lisp/autorevert.el b/lisp/autorevert.el
index 5abe12fae65..c67b6663bd0 100644
--- a/lisp/autorevert.el
+++ b/lisp/autorevert.el
@@ -1,7 +1,6 @@
;;; autorevert.el --- revert buffers when files on disk change
-;; Copyright (C) 1997, 1998, 1999, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-1999, 2001-2011 Free Software Foundation, Inc.
;; Author: Anders Lindgren <andersl@andersl.com>
;; Keywords: convenience
@@ -117,12 +116,12 @@ Global Auto-Revert Mode applies to all buffers."
;;; What's this?: ;; Autoload for the benefit of `make-mode-line-mouse-sensitive'.
;;; What's this?: ;;;###autoload
(defvar auto-revert-mode nil
- "*Non-nil when Auto-Revert Mode is active.
+ "Non-nil when Auto-Revert Mode is active.
Never set this variable directly, use the command `auto-revert-mode' instead.")
(put 'auto-revert-mode 'permanent-local t)
(defvar auto-revert-tail-mode nil
- "*Non-nil when Auto-Revert Tail Mode is active.
+ "Non-nil when Auto-Revert Tail Mode is active.
Never set this variable directly, use the command
`auto-revert-tail-mode' instead.")
(put 'auto-revert-tail-mode 'permanent-local t)
@@ -255,8 +254,7 @@ buffers. CPU usage depends on the version control system."
:version "22.1")
(defvar global-auto-revert-ignore-buffer nil
- "*When non-nil, Global Auto-Revert Mode will not revert this buffer.
-
+ "When non-nil, Global Auto-Revert Mode will not revert this buffer.
This variable becomes buffer local when set in any fashion.")
(make-variable-buffer-local 'global-auto-revert-ignore-buffer)
@@ -436,9 +434,9 @@ This is an internal function used by Auto-Revert Mode."
(file-readable-p buffer-file-name)
(if auto-revert-tail-mode
;; Tramp caches the file attributes. Setting
- ;; `tramp-cache-inhibit' forces Tramp to
- ;; reread the values.
- (let ((tramp-cache-inhibit-cache t))
+ ;; `remote-file-name-inhibit-cache' forces Tramp
+ ;; to reread the values.
+ (let ((remote-file-name-inhibit-cache t))
(/= auto-revert-tail-pos
(setq size
(nth 7 (file-attributes
@@ -462,10 +460,10 @@ This is an internal function used by Auto-Revert Mode."
(when buffer-file-name
(setq eob (eobp))
(walk-windows
- #'(lambda (window)
- (and (eq (window-buffer window) buffer)
- (= (window-point window) (point-max))
- (push window eoblist)))
+ (lambda (window)
+ (and (eq (window-buffer window) buffer)
+ (= (window-point window) (point-max))
+ (push window eoblist)))
'no-mini t))
(if auto-revert-tail-mode
(auto-revert-tail-handler size)
@@ -576,5 +574,4 @@ the timer when no buffers need to be checked."
(run-hooks 'auto-revert-load-hook)
-;; arch-tag: f6bcb07b-4841-477e-9e44-b18678e58876
;;; autorevert.el ends here
diff --git a/lisp/avoid.el b/lisp/avoid.el
index c9c989b2ab9..038927105ec 100644
--- a/lisp/avoid.el
+++ b/lisp/avoid.el
@@ -1,7 +1,6 @@
;;; avoid.el --- make mouse pointer stay out of the way of editing
-;; Copyright (C) 1993, 1994, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1994, 2000-2011 Free Software Foundation, Inc.
;; Author: Boris Goldowsky <boris@gnu.org>
;; Keywords: mouse
@@ -277,7 +276,9 @@ 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
+ (not cursor-type) ; There's no cursor
+ 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.
@@ -407,5 +408,4 @@ definition of \"random distance\".)"
(if mouse-avoidance-mode
(mouse-avoidance-mode mouse-avoidance-mode))
-;; arch-tag: 64ad4ef8-a870-4183-8d96-3aa93b7a6800
;;; avoid.el ends here
diff --git a/lisp/battery.el b/lisp/battery.el
index 3acb467a2d5..9afe9de7b98 100644
--- a/lisp/battery.el
+++ b/lisp/battery.el
@@ -1,7 +1,6 @@
;;; battery.el --- display battery status information -*- coding: iso-8859-1 -*-
-;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-1998, 2000-2011 Free Software Foundation, Inc.
;; Author: Ralph Schleicher <rs@nunatak.allgaeu.org>
;; Keywords: hardware
@@ -553,5 +552,4 @@ MATCH-NUM in the match. Otherwise, return nil."
(provide 'battery)
-;; arch-tag: 65916f50-4754-4b6b-ac21-0b510f545a37
;;; battery.el ends here
diff --git a/lisp/bindings.el b/lisp/bindings.el
index d6270c458f1..8c48bdc5d59 100644
--- a/lisp/bindings.el
+++ b/lisp/bindings.el
@@ -1,11 +1,11 @@
;;; bindings.el --- define standard key bindings and some variables
-;; Copyright (C) 1985, 1986, 1987, 1992, 1993, 1994, 1995, 1996, 1999,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+;; Copyright (C) 1985-1987, 1992-1996, 1999-2011
;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -62,24 +62,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]
@@ -171,17 +153,17 @@ mouse-3: Describe current input method"))
,(propertize
"%z"
'help-echo
- #'(lambda (window object point)
- (with-current-buffer (window-buffer window)
- ;; Don't show this tip if the coding system is nil,
- ;; it reads like a bug, and is not useful anyway.
- (when buffer-file-coding-system
- (format "Buffer coding system %s\nmouse-1: describe coding system"
- (if enable-multibyte-characters
- (concat "(multi-byte): "
- (symbol-name buffer-file-coding-system))
- (concat "(unibyte): "
- (symbol-name buffer-file-coding-system)))))))
+ (lambda (window _object _point)
+ (with-current-buffer (window-buffer window)
+ ;; Don't show this tip if the coding system is nil,
+ ;; it reads like a bug, and is not useful anyway.
+ (when buffer-file-coding-system
+ (format "Buffer coding system %s\nmouse-1: describe coding system"
+ (if enable-multibyte-characters
+ (concat "(multi-byte): "
+ (symbol-name buffer-file-coding-system))
+ (concat "(unibyte): "
+ (symbol-name buffer-file-coding-system)))))))
'mouse-face 'mode-line-highlight
'local-map mode-line-coding-system-map)
(:eval (mode-line-eol-desc)))
@@ -227,7 +209,7 @@ Normally nil in most modes, since there is no process to display.")
(defvar mode-line-modified
(list (propertize
"%1*"
- 'help-echo (purecopy (lambda (window object point)
+ 'help-echo (purecopy (lambda (window _object _point)
(format "Buffer is %s\nmouse-1 toggles"
(save-selected-window
(select-window window)
@@ -240,7 +222,7 @@ Normally nil in most modes, since there is no process to display.")
'mouse-face 'mode-line-highlight)
(propertize
"%1+"
- 'help-echo (purecopy (lambda (window object point)
+ 'help-echo (purecopy (lambda (window _object _point)
(format "Buffer is %sodified\nmouse-1 toggles modified state"
(save-selected-window
(select-window window)
@@ -260,7 +242,7 @@ Normally nil in most modes, since there is no process to display.")
(list (propertize
"%1@"
'mouse-face 'mode-line-highlight
- 'help-echo (purecopy (lambda (window object point)
+ 'help-echo (purecopy (lambda (window _object _point)
(format "%s"
(save-selected-window
(select-window window)
@@ -335,7 +317,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 +333,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 +362,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
@@ -672,28 +655,14 @@ 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'.
+ "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")
- (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]")))))
+ (if arg (info-complete-symbol) (completion-at-point)))
;; Reduce total amount of space we must allocate during this function
;; that we will not need to keep permanently.
@@ -720,6 +689,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 +833,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 +899,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 +943,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 +1104,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)
@@ -1184,5 +1213,4 @@ or \\[semantic-mode]")))))
;; no-update-autoloads: t
;; End:
-;; arch-tag: 23b5c7e6-e47b-49ed-8c6c-ed213c5fffe0
;;; bindings.el ends here
diff --git a/lisp/bookmark.el b/lisp/bookmark.el
index 206fd2b367f..184cecb9e9c 100644
--- a/lisp/bookmark.el
+++ b/lisp/bookmark.el
@@ -1,7 +1,6 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Karl Fogel <kfogel@red-bean.com>
;; Maintainer: Karl Fogel <kfogel@red-bean.com>
@@ -92,7 +91,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)
@@ -304,9 +303,10 @@ This point is in `bookmark-current-buffer'.")
;; need to know anything about the format of bookmark-alist entries.
;; Everyone else should go through them.
-(defun bookmark-name-from-full-record (full-record)
- "Return name of FULL-RECORD (an alist element instead of a string)."
- (car full-record))
+(defun bookmark-name-from-full-record (bookmark-record)
+ "Return the name of BOOKMARK-RECORD. BOOKMARK-RECORD is, e.g.,
+one element from `bookmark-alist'."
+ (car bookmark-record))
(defun bookmark-all-names ()
@@ -315,113 +315,100 @@ This point is in `bookmark-current-buffer'.")
(mapcar 'bookmark-name-from-full-record bookmark-alist))
-(defun bookmark-get-bookmark (bookmark &optional noerror)
- "Return the bookmark record corresponding to BOOKMARK.
-If BOOKMARK is a string, look for the corresponding bookmark record in
-`bookmark-alist'; return it if found, otherwise error. Else if
-BOOKMARK is already a bookmark record, just return it."
+(defun bookmark-get-bookmark (bookmark-name-or-record &optional noerror)
+ "Return the bookmark record corresponding to BOOKMARK-NAME-OR-RECORD.
+If BOOKMARK-NAME-OR-RECORD is a string, look for the corresponding
+bookmark record in `bookmark-alist'; return it if found, otherwise
+error. Else if BOOKMARK-NAME-OR-RECORD is already a bookmark record,
+just return it."
(cond
- ((consp bookmark) bookmark)
- ((stringp bookmark)
- (or (assoc-string bookmark bookmark-alist bookmark-completion-ignore-case)
- (unless noerror (error "Invalid bookmark %s" bookmark))))))
-
-
-(defun bookmark-get-bookmark-record (bookmark)
- "Return the record portion of the entry for BOOKMARK in
-`bookmark-alist' (that is, all information but the name).
-BOOKMARK may be a bookmark name (a string) or a bookmark record."
- (let ((alist (cdr (bookmark-get-bookmark bookmark))))
+ ((consp bookmark-name-or-record) bookmark-name-or-record)
+ ((stringp bookmark-name-or-record)
+ (or (assoc-string bookmark-name-or-record bookmark-alist
+ bookmark-completion-ignore-case)
+ (unless noerror (error "Invalid bookmark %s"
+ bookmark-name-or-record))))))
+
+
+(defun bookmark-get-bookmark-record (bookmark-name-or-record)
+ "Return the record portion of the entry for BOOKMARK-NAME-OR-RECORD in
+`bookmark-alist' (that is, all information but the name)."
+ (let ((alist (cdr (bookmark-get-bookmark bookmark-name-or-record))))
;; The bookmark objects can either look like (NAME ALIST) or
;; (NAME . ALIST), so we have to distinguish the two here.
(if (and (null (cdr alist)) (consp (caar alist)))
(car alist) alist)))
-(defun bookmark-set-name (bookmark newname)
- "Set BOOKMARK's name to NEWNAME.
-BOOKMARK may be a bookmark name (a string) or a bookmark record."
- (setcar
- (if (stringp bookmark) (bookmark-get-bookmark bookmark) bookmark)
- newname))
+(defun bookmark-set-name (bookmark-name-or-record newname)
+ "Set BOOKMARK-NAME-OR-RECORD's name to NEWNAME."
+ (setcar (bookmark-get-bookmark bookmark-name-or-record) newname))
-(defun bookmark-prop-get (bookmark prop)
- "Return the property PROP of BOOKMARK, or nil if none.
-BOOKMARK may be a bookmark name (a string) or a bookmark record."
- (cdr (assq prop (bookmark-get-bookmark-record bookmark))))
+(defun bookmark-prop-get (bookmark-name-or-record prop)
+ "Return the property PROP of BOOKMARK-NAME-OR-RECORD, or nil if none."
+ (cdr (assq prop (bookmark-get-bookmark-record bookmark-name-or-record))))
-(defun bookmark-prop-set (bookmark prop val)
- "Set the property PROP of BOOKMARK to VAL.
-BOOKMARK may be a bookmark name (a string) or a bookmark record."
- (let ((cell (assq prop (bookmark-get-bookmark-record bookmark))))
+(defun bookmark-prop-set (bookmark-name-or-record prop val)
+ "Set the property PROP of BOOKMARK-NAME-OR-RECORD to VAL."
+ (let ((cell (assq
+ prop (bookmark-get-bookmark-record bookmark-name-or-record))))
(if cell
(setcdr cell val)
- (nconc (bookmark-get-bookmark-record bookmark)
+ (nconc (bookmark-get-bookmark-record bookmark-name-or-record)
(list (cons prop val))))))
-(defun bookmark-get-annotation (bookmark)
- "Return the annotation of BOOKMARK, or nil if none.
-BOOKMARK may be a bookmark name (a string) or a bookmark record."
- (bookmark-prop-get bookmark 'annotation))
+(defun bookmark-get-annotation (bookmark-name-or-record)
+ "Return the annotation of BOOKMARK-NAME-OR-RECORD, or nil if none."
+ (bookmark-prop-get bookmark-name-or-record 'annotation))
-(defun bookmark-set-annotation (bookmark ann)
- "Set the annotation of BOOKMARK to ANN.
-BOOKMARK may be a bookmark name (a string) or a bookmark record."
- (bookmark-prop-set bookmark 'annotation ann))
+(defun bookmark-set-annotation (bookmark-name-or-record ann)
+ "Set the annotation of BOOKMARK-NAME-OR-RECORD to ANN."
+ (bookmark-prop-set bookmark-name-or-record 'annotation ann))
-(defun bookmark-get-filename (bookmark)
- "Return the full filename of BOOKMARK, or nil if none.
-BOOKMARK may be a bookmark name (a string) or a bookmark record."
- (bookmark-prop-get bookmark 'filename))
+(defun bookmark-get-filename (bookmark-name-or-record)
+ "Return the full filename of BOOKMARK-NAME-OR-RECORD, or nil if none."
+ (bookmark-prop-get bookmark-name-or-record 'filename))
-(defun bookmark-set-filename (bookmark filename)
- "Set the full filename of BOOKMARK to FILENAME.
-BOOKMARK may be a bookmark name (a string) or a bookmark record."
- (bookmark-prop-set bookmark 'filename filename))
+(defun bookmark-set-filename (bookmark-name-or-record filename)
+ "Set the full filename of BOOKMARK-NAME-OR-RECORD to FILENAME."
+ (bookmark-prop-set bookmark-name-or-record 'filename filename))
-(defun bookmark-get-position (bookmark)
- "Return the position (i.e.: point) of BOOKMARK, or nil if none.
-BOOKMARK may be a bookmark name (a string) or a bookmark record."
- (bookmark-prop-get bookmark 'position))
+(defun bookmark-get-position (bookmark-name-or-record)
+ "Return the position (i.e.: point) of BOOKMARK-NAME-OR-RECORD, or nil if none."
+ (bookmark-prop-get bookmark-name-or-record 'position))
-(defun bookmark-set-position (bookmark position)
- "Set the position (i.e.: point) of BOOKMARK to POSITION.
-BOOKMARK may be a bookmark name (a string) or a bookmark record."
- (bookmark-prop-set bookmark 'position position))
+(defun bookmark-set-position (bookmark-name-or-record position)
+ "Set the position (i.e.: point) of BOOKMARK-NAME-OR-RECORD to POSITION."
+ (bookmark-prop-set bookmark-name-or-record 'position position))
-(defun bookmark-get-front-context-string (bookmark)
- "Return the front-context-string of BOOKMARK, or nil if none.
-BOOKMARK may be a bookmark name (a string) or a bookmark record."
- (bookmark-prop-get bookmark 'front-context-string))
+(defun bookmark-get-front-context-string (bookmark-name-or-record)
+ "Return the front-context-string of BOOKMARK-NAME-OR-RECORD, or nil if none."
+ (bookmark-prop-get bookmark-name-or-record 'front-context-string))
-(defun bookmark-set-front-context-string (bookmark string)
- "Set the front-context-string of BOOKMARK to STRING.
-BOOKMARK may be a bookmark name (a string) or a bookmark record."
- (bookmark-prop-set bookmark 'front-context-string string))
+(defun bookmark-set-front-context-string (bookmark-name-or-record string)
+ "Set the front-context-string of BOOKMARK-NAME-OR-RECORD to STRING."
+ (bookmark-prop-set bookmark-name-or-record 'front-context-string string))
-(defun bookmark-get-rear-context-string (bookmark)
- "Return the rear-context-string of BOOKMARK, or nil if none.
-BOOKMARK may be a bookmark name (a string) or a bookmark record."
- (bookmark-prop-get bookmark 'rear-context-string))
+(defun bookmark-get-rear-context-string (bookmark-name-or-record)
+ "Return the rear-context-string of BOOKMARK-NAME-OR-RECORD, or nil if none."
+ (bookmark-prop-get bookmark-name-or-record 'rear-context-string))
-(defun bookmark-set-rear-context-string (bookmark string)
- "Set the rear-context-string of BOOKMARK to STRING.
-BOOKMARK may be a bookmark name (a string) or a bookmark record."
- (bookmark-prop-set bookmark 'rear-context-string string))
+(defun bookmark-set-rear-context-string (bookmark-name-or-record string)
+ "Set the rear-context-string of BOOKMARK-NAME-OR-RECORD to STRING."
+ (bookmark-prop-set bookmark-name-or-record 'rear-context-string string))
-(defun bookmark-get-handler (bookmark)
- "Return the handler function for BOOKMARK, or nil if none.
-BOOKMARK may be a bookmark name (a string) or a bookmark record."
- (bookmark-prop-get bookmark 'handler))
+(defun bookmark-get-handler (bookmark-name-or-record)
+ "Return the handler function for BOOKMARK-NAME-OR-RECORD, or nil if none."
+ (bookmark-prop-get bookmark-name-or-record 'handler))
(defvar bookmark-history nil
"The history list for bookmark functions.")
@@ -528,26 +515,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 +770,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)))
-
- (bookmark-maybe-load-default-file)
-
- (setq bookmark-yank-point (point))
- (setq bookmark-current-buffer (current-buffer))
+ (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)))
- (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))))
@@ -812,11 +816,11 @@ This is used in `bookmark-edit-annotation' to record the bookmark
whose annotation is being edited.")
-(defun bookmark-default-annotation-text (bookmark)
- "Return default annotation text for BOOKMARK (a string, not a record).
+(defun bookmark-default-annotation-text (bookmark-name)
+ "Return default annotation text for BOOKMARK-NAME.
The default annotation text is simply some text explaining how to use
annotations."
- (concat "# Type the annotation for bookmark '" bookmark "' here.\n"
+ (concat "# Type the annotation for bookmark '" bookmark-name "' here.\n"
"# All lines which start with a '#' will be deleted.\n"
"# Type C-c C-c when done.\n#\n"
"# Author: " (user-full-name) " <" (user-login-name) "@"
@@ -838,22 +842,20 @@ It takes one argument, the name of the bookmark, as a string.")
"Keymap for editing an annotation of a bookmark.")
-(defun bookmark-edit-annotation-mode (bookmark)
- "Mode for editing the annotation of bookmark BOOKMARK.
+(defun bookmark-edit-annotation-mode (bookmark-name-or-record)
+ "Mode for editing the annotation of bookmark BOOKMARK-NAME-OR-RECORD.
When you have finished composing, type \\[bookmark-send-annotation].
-BOOKMARK is a bookmark name (a string) or a bookmark record.
-
\\{bookmark-edit-annotation-mode-map}"
(interactive)
(kill-all-local-variables)
(make-local-variable 'bookmark-annotation-name)
- (setq bookmark-annotation-name bookmark)
+ (setq bookmark-annotation-name bookmark-name-or-record)
(use-local-map bookmark-edit-annotation-mode-map)
(setq major-mode 'bookmark-edit-annotation-mode
mode-name "Edit Bookmark Annotation")
- (insert (funcall bookmark-edit-annotation-text-func bookmark))
- (let ((annotation (bookmark-get-annotation bookmark)))
+ (insert (funcall bookmark-edit-annotation-text-func bookmark-name-or-record))
+ (let ((annotation (bookmark-get-annotation bookmark-name-or-record)))
(if (and annotation (not (string-equal annotation "")))
(insert annotation)))
(run-mode-hooks 'text-mode-hook))
@@ -872,19 +874,18 @@ Lines beginning with `#' are ignored."
(forward-line 1)))
;; Take no chances with text properties.
(let ((annotation (buffer-substring-no-properties (point-min) (point-max)))
- (bookmark bookmark-annotation-name))
- (bookmark-set-annotation bookmark annotation)
+ (bookmark-name bookmark-annotation-name))
+ (bookmark-set-annotation bookmark-name annotation)
(setq bookmark-alist-modification-count
(1+ bookmark-alist-modification-count))
(bookmark-bmenu-surreptitiously-rebuild-list))
(kill-buffer (current-buffer)))
-(defun bookmark-edit-annotation (bookmark)
- "Pop up a buffer for editing bookmark BOOKMARK's annotation.
-BOOKMARK is a bookmark name (a string) or a bookmark record."
+(defun bookmark-edit-annotation (bookmark-name-or-record)
+ "Pop up a buffer for editing bookmark BOOKMARK-NAME-OR-RECORD's annotation."
(pop-to-buffer (generate-new-buffer-name "*Bookmark Annotation Compose*"))
- (bookmark-edit-annotation-mode bookmark))
+ (bookmark-edit-annotation-mode bookmark-name-or-record))
(defun bookmark-insert-current-bookmark ()
@@ -984,14 +985,14 @@ If `bookmark-sort-flag' is non-nil, then return a sorted copy of the alist."
"Hook run after `bookmark-jump' jumps to a bookmark.
Useful for example to unhide text in `outline-mode'.")
-(defun bookmark--jump-via (bookmark display-function)
- "Handle BOOKMARK, then call DISPLAY-FUNCTION with current buffer as argument.
-Bookmark may be a bookmark name (a string) or a bookmark record.
+(defun bookmark--jump-via (bookmark-name-or-record display-function)
+ "Handle BOOKMARK-NAME-OR-RECORD, then call DISPLAY-FUNCTION with
+current buffer as argument.
After calling DISPLAY-FUNCTION, set window point to the point specified
-by BOOKMARK, if necessary, run `bookmark-after-jump-hook', and then show
-any annotations for this bookmark."
- (bookmark-handle-bookmark bookmark)
+by BOOKMARK-NAME-OR-RECORD, if necessary, run `bookmark-after-jump-hook',
+and then show any annotations for this bookmark."
+ (bookmark-handle-bookmark bookmark-name-or-record)
(save-current-buffer
(funcall display-function (current-buffer)))
(let ((win (get-buffer-window (current-buffer) 0)))
@@ -1002,7 +1003,7 @@ any annotations for this bookmark."
(if bookmark-automatically-show-annotations
;; if there is an annotation for this bookmark,
;; show it in a buffer.
- (bookmark-show-annotation bookmark)))
+ (bookmark-show-annotation bookmark-name-or-record)))
;;;###autoload
@@ -1018,8 +1019,8 @@ if you wish to give the bookmark a new location, and `bookmark-jump'
will then jump to the new location, as well as recording it in place
of the old one in the permanent bookmark record.
-BOOKMARK may be a bookmark name (a string) or a bookmark record, but
-the latter is usually only used by programmatic callers.
+BOOKMARK is usually a bookmark name (a string). It can also be a
+bookmark record, but this is usually only done by programmatic callers.
If DISPLAY-FUNC is non-nil, it is a function to invoke to display the
bookmark. It defaults to `switch-to-buffer'. A typical value for
@@ -1043,11 +1044,9 @@ DISPLAY-FUNC would be `switch-to-buffer-other-window'."
(defun bookmark-jump-noselect (bookmark)
- "Return the location pointed to by the bookmark BOOKMARK.
+ "Return the location pointed to by BOOKMARK (see `bookmark-jump').
The return value has the form (BUFFER . POINT).
-BOOKMARK may be a bookmark name (a string) or a bookmark record.
-
Note: this function is deprecated and is present for Emacs 22
compatibility only."
(save-excursion
@@ -1056,26 +1055,27 @@ compatibility only."
(make-obsolete 'bookmark-jump-noselect 'bookmark-handle-bookmark "23.1")
-(defun bookmark-handle-bookmark (bookmark)
- "Call BOOKMARK's handler or `bookmark-default-handler' if it has none.
-BOOKMARK may be a bookmark name (a string) or a bookmark record.
-
-Changes current buffer and point and returns nil, or signals a `file-error'.
+(defun bookmark-handle-bookmark (bookmark-name-or-record)
+ "Call BOOKMARK-NAME-OR-RECORD's handler or `bookmark-default-handler'
+if it has none. This changes current buffer and point and returns nil,
+or signals a `file-error'.
-If BOOKMARK has no file, this is a no-op. If BOOKMARK has a file, but
-that file no longer exists, then offer interactively to relocate BOOKMARK."
+If BOOKMARK-NAME-OR-RECORD has no file, this is a no-op. If
+BOOKMARK-NAME-OR-RECORD has a file, but that file no longer exists,
+then offer interactively to relocate BOOKMARK-NAME-OR-RECORD."
(condition-case err
- (funcall (or (bookmark-get-handler bookmark)
+ (funcall (or (bookmark-get-handler bookmark-name-or-record)
'bookmark-default-handler)
- (bookmark-get-bookmark bookmark))
+ (bookmark-get-bookmark bookmark-name-or-record))
(bookmark-error-no-filename ;file-error
;; We were unable to find the marked file, so ask if user wants to
;; relocate the bookmark, else remind them to consider deletion.
- (when (stringp bookmark)
- ;; `bookmark' can be either a bookmark name (from `bookmark-alist')
- ;; or a bookmark object. If it's an object, we assume it's a
- ;; bookmark used internally by some other package.
- (let ((file (bookmark-get-filename bookmark)))
+ (when (stringp bookmark-name-or-record)
+ ;; `bookmark-name-or-record' can be either a bookmark name
+ ;; (from `bookmark-alist') or a bookmark object. If it's an
+ ;; object, we assume it's a bookmark used internally by some
+ ;; other package.
+ (let ((file (bookmark-get-filename bookmark-name-or-record)))
(when file ;Don't know how to relocate if there's no `file'.
;; If file is not a dir, directory-file-name just returns file.
(let ((display-name (directory-file-name file)))
@@ -1088,20 +1088,20 @@ that file no longer exists, then offer interactively to relocate BOOKMARK."
(let ((use-dialog-box nil)
(use-file-dialog nil))
(if (y-or-n-p (concat display-name " nonexistent. Relocate \""
- bookmark "\"? "))
+ bookmark-name-or-record "\"? "))
(progn
- (bookmark-relocate bookmark)
+ (bookmark-relocate bookmark-name-or-record)
;; Try again.
- (funcall (or (bookmark-get-handler bookmark)
+ (funcall (or (bookmark-get-handler bookmark-name-or-record)
'bookmark-default-handler)
- (bookmark-get-bookmark bookmark)))
+ (bookmark-get-bookmark bookmark-name-or-record)))
(message
"Bookmark not relocated; consider removing it (%s)."
- bookmark)
+ bookmark-name-or-record)
(signal (car err) (cdr err))))))))))
;; Added by db.
- (when (stringp bookmark)
- (setq bookmark-current-bookmark bookmark))
+ (when (stringp bookmark-name-or-record)
+ (setq bookmark-current-bookmark bookmark-name-or-record))
nil)
(put 'bookmark-error-no-filename
@@ -1141,23 +1141,22 @@ Changes current buffer and point and returns nil, or signals a `file-error'."
nil))
;;;###autoload
-(defun bookmark-relocate (bookmark)
- "Relocate BOOKMARK to another file (reading file name with minibuffer).
-BOOKMARK is a bookmark name (a string), not a bookmark record.
+(defun bookmark-relocate (bookmark-name)
+ "Relocate BOOKMARK-NAME to another file, reading file name with minibuffer.
This makes an already existing bookmark point to that file, instead of
the one it used to point at. Useful when a file has been renamed
after a bookmark was set in it."
(interactive (list (bookmark-completing-read "Bookmark to relocate")))
- (bookmark-maybe-historicize-string bookmark)
+ (bookmark-maybe-historicize-string bookmark-name)
(bookmark-maybe-load-default-file)
- (let* ((bmrk-filename (bookmark-get-filename bookmark))
+ (let* ((bmrk-filename (bookmark-get-filename bookmark-name))
(newloc (abbreviate-file-name
(expand-file-name
(read-file-name
- (format "Relocate %s to: " bookmark)
+ (format "Relocate %s to: " bookmark-name)
(file-name-directory bmrk-filename))))))
- (bookmark-set-filename bookmark newloc)
+ (bookmark-set-filename bookmark-name newloc)
(setq bookmark-alist-modification-count
(1+ bookmark-alist-modification-count))
(if (bookmark-time-to-save-p)
@@ -1166,17 +1165,16 @@ after a bookmark was set in it."
;;;###autoload
-(defun bookmark-insert-location (bookmark &optional no-history)
- "Insert the name of the file associated with BOOKMARK.
-BOOKMARK is a bookmark name (a string), not a bookmark record.
+(defun bookmark-insert-location (bookmark-name &optional no-history)
+ "Insert the name of the file associated with BOOKMARK-NAME.
Optional second arg NO-HISTORY means don't record this in the
minibuffer history list `bookmark-history'."
(interactive (list (bookmark-completing-read "Insert bookmark location")))
- (or no-history (bookmark-maybe-historicize-string bookmark))
+ (or no-history (bookmark-maybe-historicize-string bookmark-name))
(let ((start (point)))
(prog1
- (insert (bookmark-location bookmark)) ; *Return this line*
+ (insert (bookmark-location bookmark-name))
(if (display-mouse-p)
(add-text-properties
start
@@ -1190,36 +1188,39 @@ minibuffer history list `bookmark-history'."
;;;###autoload
(defalias 'bookmark-locate 'bookmark-insert-location)
-(defun bookmark-location (bookmark)
- "Return the name of the file associated with BOOKMARK, or nil if none.
-BOOKMARK may be a bookmark name (a string) or a bookmark record."
+(defun bookmark-location (bookmark-name-or-record)
+ "Return a description of the location of BOOKMARK-NAME-OR-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-name-or-record 'location)
+ (bookmark-get-filename bookmark-name-or-record)
+ "-- Unknown location --"))
;;;###autoload
-(defun bookmark-rename (old &optional new)
- "Change the name of OLD bookmark to NEW name.
-If called from keyboard, prompt for OLD and NEW. If called from
-menubar, select OLD from a menu and prompt for NEW.
-
-Both OLD and NEW are bookmark names (strings), never bookmark records.
+(defun bookmark-rename (old-name &optional new-name)
+ "Change the name of OLD-NAME bookmark to NEW-NAME name.
+If called from keyboard, prompt for OLD-NAME and NEW-NAME.
+If called from menubar, select OLD-NAME from a menu and prompt for NEW-NAME.
-If called from Lisp, prompt for NEW if only OLD was passed as an
-argument. If called with two strings, then no prompting is done. You
-must pass at least OLD when calling from Lisp.
+If called from Lisp, prompt for NEW-NAME if only OLD-NAME was passed
+as an argument. If called with two strings, then no prompting is done.
+You must pass at least OLD-NAME when calling from Lisp.
While you are entering the new name, consecutive C-w's insert
consecutive words from the text of the buffer into the new bookmark
name."
(interactive (list (bookmark-completing-read "Old bookmark name")))
- (bookmark-maybe-historicize-string old)
+ (bookmark-maybe-historicize-string old-name)
(bookmark-maybe-load-default-file)
(setq bookmark-yank-point (point))
(setq bookmark-current-buffer (current-buffer))
- (let ((newname
- (or new ; use second arg, if non-nil
+ (let ((final-new-name
+ (or new-name ; use second arg, if non-nil
(read-from-minibuffer
"New name: "
nil
@@ -1228,8 +1229,8 @@ name."
now-map)
nil
'bookmark-history))))
- (bookmark-set-name old newname)
- (setq bookmark-current-bookmark newname)
+ (bookmark-set-name old-name final-new-name)
+ (setq bookmark-current-bookmark final-new-name)
(bookmark-bmenu-surreptitiously-rebuild-list)
(setq bookmark-alist-modification-count
(1+ bookmark-alist-modification-count))
@@ -1238,21 +1239,21 @@ name."
;;;###autoload
-(defun bookmark-insert (bookmark)
- "Insert the text of the file pointed to by bookmark BOOKMARK.
-BOOKMARK is a bookmark name (a string), not a bookmark record.
+(defun bookmark-insert (bookmark-name)
+ "Insert the text of the file pointed to by bookmark BOOKMARK-NAME.
+BOOKMARK-NAME is a bookmark name (a string), not a bookmark record.
You may have a problem using this function if the value of variable
`bookmark-alist' is nil. If that happens, you need to load in some
bookmarks. See help on function `bookmark-load' for more about
this."
(interactive (list (bookmark-completing-read "Insert bookmark contents")))
- (bookmark-maybe-historicize-string bookmark)
+ (bookmark-maybe-historicize-string bookmark-name)
(bookmark-maybe-load-default-file)
(let ((orig-point (point))
(str-to-insert
(save-current-buffer
- (bookmark-handle-bookmark bookmark)
+ (bookmark-handle-bookmark bookmark-name)
(buffer-string))))
(insert str-to-insert)
(push-mark)
@@ -1260,9 +1261,8 @@ this."
;;;###autoload
-(defun bookmark-delete (bookmark &optional batch)
- "Delete BOOKMARK from the bookmark list.
-BOOKMARK is a bookmark name (a string), not a bookmark record.
+(defun bookmark-delete (bookmark-name &optional batch)
+ "Delete BOOKMARK-NAME from the bookmark list.
Removes only the first instance of a bookmark with that name. If
there are one or more other bookmarks with the same name, they will
@@ -1273,9 +1273,9 @@ probably because we were called from there."
(interactive
(list (bookmark-completing-read "Delete bookmark"
bookmark-current-bookmark)))
- (bookmark-maybe-historicize-string bookmark)
+ (bookmark-maybe-historicize-string bookmark-name)
(bookmark-maybe-load-default-file)
- (let ((will-go (bookmark-get-bookmark bookmark 'noerror)))
+ (let ((will-go (bookmark-get-bookmark bookmark-name 'noerror)))
(setq bookmark-alist (delq will-go bookmark-alist))
;; Added by db, nil bookmark-current-bookmark if the last
;; occurrence has been deleted
@@ -1475,8 +1475,7 @@ method buffers use to resolve name collisions."
(defvar bookmark-bmenu-mode-map
(let ((map (make-keymap)))
- (suppress-keymap map t)
- (define-key map "q" 'quit-window)
+ (set-keymap-parent map special-mode-map)
(define-key map "v" 'bookmark-bmenu-select)
(define-key map "w" 'bookmark-bmenu-locate)
(define-key map "2" 'bookmark-bmenu-2-window)
@@ -1496,7 +1495,6 @@ method buffers use to resolve name collisions."
(define-key map "n" 'next-line)
(define-key map "p" 'previous-line)
(define-key map "\177" 'bookmark-bmenu-backup-unmark)
- (define-key map "?" 'describe-mode)
(define-key map "u" 'bookmark-bmenu-unmark)
(define-key map "m" 'bookmark-bmenu-mark)
(define-key map "l" 'bookmark-bmenu-load)
@@ -1506,9 +1504,7 @@ method buffers use to resolve name collisions."
(define-key map "a" 'bookmark-bmenu-show-annotation)
(define-key map "A" 'bookmark-bmenu-show-all-annotations)
(define-key map "e" 'bookmark-bmenu-edit-annotation)
- ;; The original binding of M-g hides the M-g prefix map.
- ;; If someone has a better idea than M-g s, I'm open to suggestions.
- (define-key map [?\M-g ?s] 'bookmark-bmenu-search)
+ (define-key map "/" 'bookmark-bmenu-search)
(define-key map [mouse-2] 'bookmark-bmenu-other-window-with-mouse)
map))
@@ -1586,7 +1582,7 @@ deletion, or > if it is flagged for displaying."
-(defun bookmark-bmenu-mode ()
+(define-derived-mode bookmark-bmenu-mode special-mode "Bookmark Menu"
"Major mode for editing a list of bookmarks.
Each line describes one of the bookmarks in Emacs.
Letters do not insert themselves; instead, they are commands.
@@ -1619,13 +1615,8 @@ Bookmark names preceded by a \"*\" have annotations.
in another buffer.
\\[bookmark-bmenu-show-all-annotations] -- show the annotations of all bookmarks in another buffer.
\\[bookmark-bmenu-edit-annotation] -- edit the annotation for the current bookmark."
- (kill-all-local-variables)
- (use-local-map bookmark-bmenu-mode-map)
(setq truncate-lines t)
- (setq buffer-read-only t)
- (setq major-mode 'bookmark-bmenu-mode)
- (setq mode-name "Bookmark Menu")
- (run-mode-hooks 'bookmark-bmenu-mode-hook))
+ (setq buffer-read-only t))
(defun bookmark-bmenu-toggle-filenames (&optional show)
@@ -1661,7 +1652,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)
@@ -1723,19 +1714,18 @@ last full line, move to the last full line. The return value is undefined."
(get-text-property (point) 'bookmark-name-prop)))
-(defun bookmark-show-annotation (bookmark)
- "Display the annotation for bookmark named BOOKMARK in a buffer,
+(defun bookmark-show-annotation (bookmark-name-or-record)
+ "Display the annotation for BOOKMARK-NAME-OR-RECORD 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))))))
+ (let ((annotation (bookmark-get-annotation bookmark-name-or-record)))
+ (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 annotation)
+ (goto-char (point-min))
+ (switch-to-buffer-other-window old-buf))))))
(defun bookmark-show-all-annotations ()
@@ -2173,7 +2163,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
@@ -2189,7 +2179,8 @@ This also runs `bookmark-exit-hook'."
(bookmark-time-to-save-p t)
(bookmark-save)))
-(add-hook 'kill-emacs-hook 'bookmark-exit-hook-internal)
+(unless noninteractive
+ (add-hook 'kill-emacs-hook 'bookmark-exit-hook-internal))
(defun bookmark-unload-function ()
"Unload the Bookmark library."
@@ -2202,5 +2193,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 ea385108128..6965af1368c 100644
--- a/lisp/bs.el
+++ b/lisp/bs.el
@@ -1,7 +1,6 @@
-;;; bs.el --- menu for selecting and displaying buffers
+;;; bs.el --- menu for selecting and displaying buffers -*- lexical-binding: t -*-
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Olaf Sylvester <Olaf.Sylvester@netsurf.de>
;; Maintainer: Olaf Sylvester <Olaf.Sylvester@netsurf.de>
;; Keywords: convenience
@@ -41,16 +40,12 @@
;; | % vc-hooks.el 43605 Emacs-Lisp /usr/share/emacs/19.34/lisp$|
;; -----------------------------------------------------------------------
-;;; Quick Installation und Customization:
+;;; Quick Installation and Customization:
-;; Use
+;; To display the bs menu, do
;; M-x bs-show
-;; for buffer selection or optional bind a key to main function `bs-show'
-;; (global-set-key "\C-x\C-b" 'bs-show) ;; or another key
-;;
-;; For customization use
-;; M-x bs-customize
-
+;; To customize its behavior, do
+;; M-x bs-customize
;;; More Commentary:
@@ -698,7 +693,7 @@ Refresh whole Buffer Selection Menu."
(call-interactively 'bs-set-configuration)
(bs--redisplay t))
-(defun bs-refresh (&rest ignored)
+(defun bs-refresh (&rest _ignored)
"Refresh whole Buffer Selection Menu.
Arguments are IGNORED (for `revert-buffer')."
(interactive)
@@ -1022,7 +1017,7 @@ A value of t means BUFFER belongs to no file.
A value of nil means BUFFER belongs to a file."
(not (buffer-file-name buffer)))
-(defun bs-sort-buffer-interns-are-last (b1 b2)
+(defun bs-sort-buffer-interns-are-last (_b1 b2)
"Function for sorting internal buffers at the end of all buffers."
(string-match-p "^\\*" (buffer-name b2)))
@@ -1088,7 +1083,7 @@ configuration."
bs-dont-show-regexp (nth 3 list)
bs-dont-show-function (nth 4 list)
bs-buffer-sort-function (nth 5 list))
- ;; for backward compability
+ ;; for backward compatibility
(funcall (cdr list)))
;; else
(ding)
@@ -1152,7 +1147,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)
@@ -1267,7 +1262,7 @@ or a string."
fun)
(t (apply fun args))))
-(defun bs--get-marked-string (start-buffer all-buffers)
+(defun bs--get-marked-string (start-buffer _all-buffers)
"Return a string which describes whether current buffer is marked.
START-BUFFER is the buffer where we started buffer selection.
ALL-BUFFERS is the list of buffers appearing in Buffer Selection Menu.
@@ -1292,25 +1287,25 @@ The result string is one of `bs-string-current', `bs-string-current-marked',
(t
bs-string-show-always)))
-(defun bs--get-modified-string (start-buffer all-buffers)
+(defun bs--get-modified-string (_start-buffer _all-buffers)
"Return a string which describes whether current buffer is modified.
START-BUFFER is the buffer where we started buffer selection.
ALL-BUFFERS is the list of buffers appearing in Buffer Selection Menu."
(if (buffer-modified-p) "*" " "))
-(defun bs--get-readonly-string (start-buffer all-buffers)
+(defun bs--get-readonly-string (_start-buffer _all-buffers)
"Return a string which describes whether current buffer is read only.
START-BUFFER is the buffer where we started buffer selection.
ALL-BUFFERS is the list of buffers appearing in Buffer Selection Menu."
(if buffer-read-only "%" " "))
-(defun bs--get-size-string (start-buffer all-buffers)
+(defun bs--get-size-string (_start-buffer _all-buffers)
"Return a string which describes the size of current buffer.
START-BUFFER is the buffer where we started buffer selection.
ALL-BUFFERS is the list of buffers appearing in Buffer Selection Menu."
(int-to-string (buffer-size)))
-(defun bs--get-name (start-buffer all-buffers)
+(defun bs--get-name (_start-buffer _all-buffers)
"Return name of current buffer for Buffer Selection Menu.
The name of current buffer gets additional text properties
for mouse highlighting.
@@ -1320,13 +1315,13 @@ ALL-BUFFERS is the list of buffers appearing in Buffer Selection Menu."
'help-echo "mouse-2: select this buffer, mouse-3: select in other frame"
'mouse-face 'highlight))
-(defun bs--get-mode-name (start-buffer all-buffers)
+(defun bs--get-mode-name (start-buffer _all-buffers)
"Return the name of mode of current buffer for Buffer Selection Menu.
START-BUFFER is the buffer where we started buffer selection.
ALL-BUFFERS is the list of buffers appearing in Buffer Selection Menu."
(format-mode-line mode-name nil nil start-buffer))
-(defun bs--get-file-name (start-buffer all-buffers)
+(defun bs--get-file-name (_start-buffer _all-buffers)
"Return string for column 'File' in Buffer Selection Menu.
This is the variable `buffer-file-name' of current buffer.
If not visiting a file, `list-buffers-directory' is returned instead.
@@ -1425,18 +1420,18 @@ for buffer selection."
(bs-show-in-buffer liste)
(bs-message-without-log "%s" (bs--current-config-message)))))
-(defun bs--configuration-name-for-prefix-arg (prefix-arg)
- "Convert prefix argument PREFIX-ARG to a name of a buffer configuration.
-If PREFIX-ARG is nil return `bs-default-configuration'.
-If PREFIX-ARG is an integer return PREFIX-ARG element of `bs-configurations'.
+(defun bs--configuration-name-for-prefix-arg (prefix)
+ "Convert prefix argument PREFIX to a name of a buffer configuration.
+If PREFIX is nil return `bs-default-configuration'.
+If PREFIX is an integer return PREFIX element of `bs-configurations'.
Otherwise return `bs-alternative-configuration'."
(cond ;; usually activation
- ((null prefix-arg)
+ ((null prefix)
bs-default-configuration)
;; call with integer as prefix argument
- ((integerp prefix-arg)
- (if (and (< 0 prefix-arg) (<= prefix-arg (length bs-configurations)))
- (car (nth (1- prefix-arg) bs-configurations))
+ ((integerp prefix)
+ (if (and (< 0 prefix) (<= prefix (length bs-configurations)))
+ (car (nth (1- prefix) bs-configurations))
bs-default-configuration))
;; call by prefix argument C-u
(t bs-alternative-configuration)))
@@ -1486,5 +1481,4 @@ name of buffer configuration."
;; Now provide feature bs
(provide 'bs)
-;; arch-tag: c0d9ab34-bf06-4368-ae9d-af88878e6802
;;; bs.el ends here
diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el
index 3454f416314..9886b30d122 100644
--- a/lisp/buff-menu.el
+++ b/lisp/buff-menu.el
@@ -1,10 +1,11 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1987, 1993-1995, 2000-2011
+;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: convenience
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -263,14 +264,14 @@ Letters do not insert themselves; instead, they are commands.
(set (make-local-variable 'revert-buffer-function)
'Buffer-menu-revert-function)
(set (make-local-variable 'buffer-stale-function)
- #'(lambda (&optional noconfirm) 'fast))
+ (lambda (&optional _noconfirm) 'fast))
(setq truncate-lines t)
(setq buffer-read-only t))
(define-obsolete-variable-alias 'buffer-menu-mode-hook
'Buffer-menu-mode-hook "23.1")
-(defun Buffer-menu-revert-function (ignore1 ignore2)
+(defun Buffer-menu-revert-function (_ignore1 _ignore2)
(or (eq buffer-undo-list t)
(setq buffer-undo-list nil))
;; We can not use save-excursion here. The buffer gets erased.
@@ -308,9 +309,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
@@ -930,5 +929,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 4881d9f8741..2e485547745 100644
--- a/lisp/button.el
+++ b/lisp/button.el
@@ -1,10 +1,10 @@
;;; button.el --- clickable buttons
;;
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
-;; 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;;
;; 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 0b759ff9bbc..308b5115aa2 100644
--- a/lisp/calc/README
+++ b/lisp/calc/README
@@ -1,13 +1,11 @@
-Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
- Free Software Foundation, Inc.
+Copyright (C) 2001-2011 Free Software Foundation, Inc.
See the end of the file for license conditions.
This directory contains Calc, an advanced desk calculator for GNU
Emacs.
-"Calc" Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
- 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+"Calc" Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
Written by:
Dave Gillespie
@@ -72,6 +70,23 @@ opinions.
Summary of changes to "Calc"
------- -- ------- -- ----
+Emacs 24.1
+
+* Support for musical notes added.
+
+* Support for logarithmic units added.
+
+* 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/README.prev b/lisp/calc/README.prev
index 2f74223252b..69da211efc2 100644
--- a/lisp/calc/README.prev
+++ b/lisp/calc/README.prev
@@ -1,5 +1,4 @@
-Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
- Free Software Foundation, Inc.
+Copyright (C) 2001-2011 Free Software Foundation, Inc.
See the end of the file for license conditions.
diff --git a/lisp/calc/calc-aent.el b/lisp/calc/calc-aent.el
index ca8a2feff1c..00e07aba6a5 100644
--- a/lisp/calc/calc-aent.el
+++ b/lisp/calc/calc-aent.el
@@ -1,7 +1,6 @@
;;; calc-aent.el --- algebraic entry functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -315,10 +314,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 +339,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 +432,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 +443,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 +492,7 @@ The value t means abort and give an error message.")
("≥" ">=")
("≦" "<=")
("≧" ">=")
+ ("µ" "μ")
;; fractions
("¼" "(1:4)") ; 1/4
("½" "(1:2)") ; 1/2
@@ -608,9 +591,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 +658,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 +694,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 +727,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 +792,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 +814,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 +1123,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 +1166,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,8 +1266,8 @@ 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:
-;; arch-tag: 5599e45d-e51e-44bb-9a20-9f4ed8c96c32
;;; calc-aent.el ends here
diff --git a/lisp/calc/calc-alg.el b/lisp/calc/calc-alg.el
index 453aa78712e..728acf5b0f1 100644
--- a/lisp/calc/calc-alg.el
+++ b/lisp/calc/calc-alg.el
@@ -1,7 +1,6 @@
;;; calc-alg.el --- algebraic functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -1659,11 +1658,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 +1671,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 +1689,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 +1697,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 +1705,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 +1748,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 +1758,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)))))
@@ -1914,5 +1913,4 @@
(provide 'calc-alg)
-;; arch-tag: 52e7dcdf-9688-464d-a02b-4bbe789348d0
;;; calc-alg.el ends here
diff --git a/lisp/calc/calc-arith.el b/lisp/calc/calc-arith.el
index bec3c0661cc..a557e5fb92d 100644
--- a/lisp/calc/calc-arith.el
+++ b/lisp/calc/calc-arith.el
@@ -1,7 +1,6 @@
;;; calc-arith.el --- arithmetic functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -3067,5 +3066,4 @@
(provide 'calc-arith)
-;; arch-tag: 6c396b5b-14c6-40ed-bb2a-7cc2e8111465
;;; calc-arith.el ends here
diff --git a/lisp/calc/calc-bin.el b/lisp/calc/calc-bin.el
index dcf0245d93e..20b4a9db5e2 100644
--- a/lisp/calc/calc-bin.el
+++ b/lisp/calc/calc-bin.el
@@ -1,7 +1,6 @@
;;; calc-bin.el --- binary functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -175,7 +174,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 +844,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)
"##"
@@ -852,5 +853,4 @@ the size of a Calc bignum digit.")
(provide 'calc-bin)
-;; arch-tag: f6dba7bc-53b2-41ae-919c-c266ab0ca8b3
;;; calc-bin.el ends here
diff --git a/lisp/calc/calc-comb.el b/lisp/calc/calc-comb.el
index a282a4fbf2c..da5bae69803 100644
--- a/lisp/calc/calc-comb.el
+++ b/lisp/calc/calc-comb.el
@@ -1,7 +1,6 @@
;;; calc-comb.el --- combinatoric functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -1027,5 +1026,4 @@
(provide 'calc-comb)
-;; arch-tag: 1d75ee9b-0815-42bd-a321-bb3dc001cc02
;;; calc-comb.el ends here
diff --git a/lisp/calc/calc-cplx.el b/lisp/calc/calc-cplx.el
index 88df0c385f2..f2e0c493144 100644
--- a/lisp/calc/calc-cplx.el
+++ b/lisp/calc/calc-cplx.el
@@ -1,7 +1,6 @@
;;; calc-cplx.el --- Complex number functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -355,5 +354,4 @@
(provide 'calc-cplx)
-;; arch-tag: de73a331-941c-4507-ae76-46c76adc70dd
;;; calc-cplx.el ends here
diff --git a/lisp/calc/calc-embed.el b/lisp/calc/calc-embed.el
index 74ab819de3f..f011d187a42 100644
--- a/lisp/calc/calc-embed.el
+++ b/lisp/calc/calc-embed.el
@@ -1,7 +1,6 @@
;;; calc-embed.el --- embed Calc in a buffer
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -1382,5 +1381,4 @@ The command \\[yank] can retrieve it from there."
;; generated-autoload-file: "calc-loaddefs.el"
;; End:
-;; arch-tag: 1b8f311e-fba1-40d3-b8c3-1d6f68fd26fc
;;; calc-embed.el ends here
diff --git a/lisp/calc/calc-ext.el b/lisp/calc/calc-ext.el
index c806b84fd57..9ea773fbb98 100644
--- a/lisp/calc/calc-ext.el
+++ b/lisp/calc/calc-ext.el
@@ -1,7 +1,6 @@
;;; calc-ext.el --- various extension functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -104,6 +103,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)
@@ -135,8 +135,6 @@
(define-key calc-mode-map "\C-w" 'calc-kill-region)
(define-key calc-mode-map "\M-w" 'calc-copy-region-as-kill)
(define-key calc-mode-map "\M-\C-w" 'kill-ring-save)
- (define-key calc-mode-map "\C-_" 'calc-undo)
- (define-key calc-mode-map "\C-xu" 'calc-undo)
(define-key calc-mode-map "\M-\C-m" 'calc-last-args)
(define-key calc-mode-map "a" nil)
@@ -423,6 +421,20 @@
(define-key calc-mode-map "kP" 'calc-utpp)
(define-key calc-mode-map "kT" 'calc-utpt)
+ (define-key calc-mode-map "l" nil)
+ (define-key calc-mode-map "lq" 'calc-lu-quant)
+ (define-key calc-mode-map "ld" 'calc-db)
+ (define-key calc-mode-map "ln" 'calc-np)
+ (define-key calc-mode-map "l+" 'calc-lu-plus)
+ (define-key calc-mode-map "l-" 'calc-lu-minus)
+ (define-key calc-mode-map "l*" 'calc-lu-times)
+ (define-key calc-mode-map "l/" 'calc-lu-divide)
+ (define-key calc-mode-map "ls" 'calc-spn)
+ (define-key calc-mode-map "lm" 'calc-midi)
+ (define-key calc-mode-map "lf" 'calc-freq)
+
+ (define-key calc-mode-map "l?" 'calc-l-prefix-help)
+
(define-key calc-mode-map "m" nil)
(define-key calc-mode-map "m?" 'calc-m-prefix-help)
(define-key calc-mode-map "ma" 'calc-algebraic-mode)
@@ -931,7 +943,11 @@ calc-store-value calc-var-name)
("calc-stuff" calc-explain-why calcFunc-clean
calcFunc-pclean calcFunc-pfloat calcFunc-pfrac)
- ("calc-units" calcFunc-usimplify
+ ("calc-units" calcFunc-usimplify calcFunc-lufadd calcFunc-lupadd
+calcFunc-lufsub calcFunc-lupsub calcFunc-lufmul calcFunc-lupmul
+calcFunc-lufdiv calcFunc-lupdiv calcFunc-lufquant calcFunc-lupquant
+calcFunc-dbfield calcFunc-dbpower calcFunc-npfield
+calcFunc-nppower calcFunc-spn calcFunc-midi calcFunc-freq
math-build-units-table math-build-units-table-buffer
math-check-unit-name math-convert-temperature math-convert-units
math-extract-units math-remove-units math-simplify-units
@@ -959,7 +975,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 +1004,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,10 +1061,11 @@ 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)
+calc-t-prefix-help calc-u-prefix-help calc-l-prefix-help
+calc-v-prefix-help)
("calc-incom" calc-begin-complex calc-begin-vector calc-comma
calc-dots calc-end-complex calc-end-vector calc-semi)
@@ -1155,14 +1172,17 @@ calc-trail-kill calc-trail-last calc-trail-marker calc-trail-next
calc-trail-out calc-trail-previous calc-trail-scroll-left
calc-trail-scroll-right calc-trail-yank)
- ("calc-undo" calc-last-args calc-redo calc-undo)
+ ("calc-undo" calc-last-args calc-redo)
("calc-units" calc-autorange-units calc-base-units
calc-convert-temperature calc-convert-units calc-define-unit
calc-enter-units-table calc-explain-units calc-extract-units
calc-get-unit-definition calc-permanent-units calc-quick-units
calc-remove-units calc-simplify-units calc-undefine-unit
-calc-view-units-table)
+calc-view-units-table calc-lu-quant calc-db
+calc-np calc-lu-plus calc-lu-minus
+calc-lu-times calc-lu-divide calc-spn calc-midi
+calc-freq)
("calc-vec" calc-arrange-vector calc-build-vector calc-cnorm
calc-conj-transpose calc-cons calc-cross calc-kron calc-diag
@@ -1408,9 +1428,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 +1518,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 +1542,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 +1721,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 +3302,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 +3488,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 +3519,8 @@ A key may contain additional specs for Inverse, Hyperbolic, and Inv+Hyp.")
(provide 'calc-ext)
-;; arch-tag: 1814ba7f-a390-49dc-9e25-a5adc205e97e
+;; Local variables:
+;; coding: utf-8
+;; End:
+
;;; calc-ext.el ends here
diff --git a/lisp/calc/calc-fin.el b/lisp/calc/calc-fin.el
index 78eb1447ec1..2e1d072dfb8 100644
--- a/lisp/calc/calc-fin.el
+++ b/lisp/calc/calc-fin.el
@@ -1,7 +1,6 @@
;;; calc-fin.el --- financial functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -410,5 +409,4 @@
(provide 'calc-fin)
-;; arch-tag: 82f30ca8-d02f-4b33-84b4-bb6ecd84597b
;;; calc-fin.el ends here
diff --git a/lisp/calc/calc-forms.el b/lisp/calc/calc-forms.el
index 2d94455cb9e..912bbc7f78d 100644
--- a/lisp/calc/calc-forms.el
+++ b/lisp/calc/calc-forms.el
@@ -1,7 +1,6 @@
;;; calc-forms.el --- data format conversion functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -1922,5 +1921,4 @@ and ends on the last Sunday of October at 2 a.m."
(provide 'calc-forms)
-;; arch-tag: a3d8f33b-9508-4043-8060-d02b8c9c750c
;;; calc-forms.el ends here
diff --git a/lisp/calc/calc-frac.el b/lisp/calc/calc-frac.el
index 701ec676e6b..30894b406b5 100644
--- a/lisp/calc/calc-frac.el
+++ b/lisp/calc/calc-frac.el
@@ -1,7 +1,6 @@
;;; calc-frac.el --- fraction functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -205,18 +204,33 @@
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)
-;; arch-tag: 89d65274-0b3b-42d8-aacd-eaf86da5b4ea
;;; calc-frac.el ends here
diff --git a/lisp/calc/calc-funcs.el b/lisp/calc/calc-funcs.el
index 780dc2acfc3..e065493562e 100644
--- a/lisp/calc/calc-funcs.el
+++ b/lisp/calc/calc-funcs.el
@@ -1,7 +1,6 @@
;;; calc-funcs.el --- well-known functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -1009,5 +1008,4 @@
(provide 'calc-funcs)
-;; arch-tag: 421ddb7a-550f-4dda-a31c-06638ebfc43a
;;; calc-funcs.el ends here
diff --git a/lisp/calc/calc-graph.el b/lisp/calc/calc-graph.el
index e16b8ac11ec..d5d8f0aaf35 100644
--- a/lisp/calc/calc-graph.el
+++ b/lisp/calc/calc-graph.el
@@ -1,7 +1,6 @@
;;; calc-graph.el --- graph output functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -433,7 +432,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
@@ -575,16 +574,16 @@
(setq calc-graph-xstep 1)
(error "%s is not a suitable basis for %s" calc-graph-xname calc-graph-yname)))))
(or (math-realp calc-graph-yvalue)
- (let ((arglist nil))
+ (let ((math-arglist nil))
(setq calc-graph-yvalue (math-evaluate-expr calc-graph-yvalue))
(calc-default-formula-arglist calc-graph-yvalue)
- (or arglist
+ (or math-arglist
(error "%s does not contain any unassigned variables" calc-graph-yname))
- (and (cdr arglist)
+ (and (cdr math-arglist)
(error "%s contains more than one variable: %s"
- calc-graph-yname arglist))
+ calc-graph-yname math-arglist))
(setq calc-graph-yvalue (math-expr-subst calc-graph-yvalue
- (math-build-var-name (car arglist))
+ (math-build-var-name (car math-arglist))
'(var DUMMY var-DUMMY)))))
(setq calc-graph-ycache (assoc calc-graph-yvalue calc-graph-data-cache))
(delq calc-graph-ycache calc-graph-data-cache)
@@ -736,17 +735,17 @@
calc-graph-zp calc-graph-yvalue
calc-graph-xvec t))
(or (math-realp calc-graph-yvalue)
- (let ((arglist nil))
+ (let ((math-arglist nil))
(setq calc-graph-yvalue (math-evaluate-expr calc-graph-yvalue))
(calc-default-formula-arglist calc-graph-yvalue)
- (setq arglist (sort arglist 'string-lessp))
- (or (cdr arglist)
+ (setq math-arglist (sort math-arglist 'string-lessp))
+ (or (cdr math-arglist)
(error "%s does not contain enough unassigned variables" calc-graph-yname))
- (and (cdr (cdr arglist))
- (error "%s contains too many variables: %s" calc-graph-yname arglist))
+ (and (cdr (cdr math-arglist))
+ (error "%s contains too many variables: %s" calc-graph-yname math-arglist))
(setq calc-graph-yvalue (math-multi-subst calc-graph-yvalue
(mapcar 'math-build-var-name
- arglist)
+ math-arglist)
'((var DUMMY var-DUMMY)
(var DUMMY2 var-DUMMY2))))))
(if (setq calc-graph-xvec (eq (car-safe calc-graph-xvalue) 'vec))
@@ -1506,5 +1505,4 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(provide 'calc-graph)
-;; arch-tag: e4b06a52-c386-4d54-a2bb-7c0a0ef533c2
;;; calc-graph.el ends here
diff --git a/lisp/calc/calc-help.el b/lisp/calc/calc-help.el
index 8b3bee088e7..427cf6ba233 100644
--- a/lisp/calc/calc-help.el
+++ b/lisp/calc/calc-help.el
@@ -1,7 +1,6 @@
;;; calc-help.el --- help display functions for Calc,
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -128,7 +127,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 +445,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
@@ -455,6 +455,7 @@ C-w Describe how there is no warranty for Calc."
calc-h-prefix-help
calc-j-prefix-help
calc-k-prefix-help
+ calc-l-prefix-help
calc-m-prefix-help
calc-r-prefix-help
calc-s-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)
@@ -663,6 +669,14 @@ C-w Describe how there is no warranty for Calc."
"SHIFT + stat: + (sum), - (asum), * (prod), # (count)")
"units/stat" ?u))
+(defun calc-l-prefix-help ()
+ (interactive)
+ (calc-do-prefix-help
+ '("Quantity, DB level, Np level"
+ "+, -, *, /"
+ "Scientific pitch notation, Midi number, Frequency"
+ )
+ "log units" ?l))
(defun calc-v-prefix-help ()
(interactive)
@@ -682,5 +696,4 @@ C-w Describe how there is no warranty for Calc."
(provide 'calc-help)
-;; arch-tag: 2d347593-7591-449e-a64a-93dab5f2f686
;;; calc-help.el ends here
diff --git a/lisp/calc/calc-incom.el b/lisp/calc/calc-incom.el
index 8087182612b..a9cf89e6058 100644
--- a/lisp/calc/calc-incom.el
+++ b/lisp/calc/calc-incom.el
@@ -1,7 +1,6 @@
;;; calc-incom.el --- complex data type input functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -176,9 +175,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 +187,7 @@
(erase-buffer))
(exit-minibuffer)))
;; just ignore extra decimal point, anticipating ".."
- (delete-backward-char 1)))
+ (delete-char -1)))
(defun calc-dots ()
(interactive)
@@ -230,5 +229,4 @@
(provide 'calc-incom)
-;; arch-tag: b8001270-4dc7-481b-a3e3-a952e19b390d
;;; calc-incom.el ends here
diff --git a/lisp/calc/calc-keypd.el b/lisp/calc/calc-keypd.el
index 1188e882ab7..cc10d9e993c 100644
--- a/lisp/calc/calc-keypd.el
+++ b/lisp/calc/calc-keypd.el
@@ -1,7 +1,6 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -390,9 +389,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 +616,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 f6e269589ed..7e3a08a1459 100644
--- a/lisp/calc/calc-lang.el
+++ b/lisp/calc/calc-lang.el
@@ -1,7 +1,6 @@
;;; calc-lang.el --- calc language functions
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -214,7 +213,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 +311,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 +334,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 +378,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 +398,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 +497,7 @@
(intv . math-compose-tex-intv)))
(put 'tex 'math-variable-table
- '(
+ '(
;; The Greek letters
( \\alpha . var-alpha )
( \\beta . var-beta )
@@ -540,6 +539,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 +612,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 +639,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 +700,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 +711,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 +731,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 +833,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 +875,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 +997,7 @@
(cdr (math-transpose a)))
'("}")))))
-(put 'eqn 'math-var-formatter
+(put 'eqn 'math-var-formatter
(function
(lambda (a prec)
(let (v)
@@ -1011,7 +1020,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 +1031,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 +1044,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 +1078,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 +1198,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 +1365,7 @@
(math-compose-expr (nth 2 a) -1)
(if (not (nth 3 a))
")"
- (concat
+ (concat
","
(math-compose-expr (nth 3 a) -1)
","
@@ -1393,7 +1402,7 @@
'(("+" + 100 100)
("-" - 100 134)
("*" * 120 120)
- ("." * 130 129)
+ ("." * 130 129)
("/" / 120 120)
("u-" neg -1 180)
("u+" ident -1 180)
@@ -1494,9 +1503,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 +1581,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 +1743,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 +1757,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 +1779,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 +2010,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 +2053,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 +2064,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 +2116,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 +2175,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 +2189,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 +2208,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 +2310,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 +2356,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 +2398,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 +2492,8 @@ order to Calc's."
(provide 'calc-lang)
-;; arch-tag: 483bfe15-f290-4fef-bb7d-ce65be687f2e
+;; Local variables:
+;; coding: utf-8
+;; End:
+
;;; calc-lang.el ends here
diff --git a/lisp/calc/calc-macs.el b/lisp/calc/calc-macs.el
index 8da071276fc..f922687e7fa 100644
--- a/lisp/calc/calc-macs.el
+++ b/lisp/calc/calc-macs.el
@@ -1,7 +1,6 @@
;;; calc-macs.el --- important macros for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -207,5 +206,4 @@
(provide 'calc-macs)
-;; arch-tag: 08ba8ec2-fcff-4b80-a079-ec661bdb057e
;;; calc-macs.el ends here
diff --git a/lisp/calc/calc-map.el b/lisp/calc/calc-map.el
index 0ffc15d6a43..2ea4de20293 100644
--- a/lisp/calc/calc-map.el
+++ b/lisp/calc/calc-map.el
@@ -1,7 +1,6 @@
;;; calc-map.el --- higher-order functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -572,7 +571,7 @@
(and nargs forcenargs (/= nargs forcenargs) (>= nargs 0)
(error "Must be a %d-argument operator" nargs)))
((memq key '(?\$ ?\'))
- (let* ((arglist nil)
+ (let* ((math-arglist nil)
(has-args nil)
(record-entry nil)
(expr (if (eq key ?\$)
@@ -592,13 +591,13 @@
(if (> calc-dollar-used 0)
(progn
(setq has-args calc-dollar-used
- arglist (calc-invent-args has-args))
+ math-arglist (calc-invent-args has-args))
(math-multi-subst (car func)
- (reverse arglist)
- arglist))
+ (reverse math-arglist)
+ math-arglist))
(if (> calc-hashes-used 0)
(setq has-args calc-hashes-used
- arglist (calc-invent-args has-args)))
+ math-arglist (calc-invent-args has-args)))
(car func))))))
(if (eq (car-safe expr) 'calcFunc-lambda)
(setq oper (list "$" (- (length expr) 2) expr)
@@ -607,16 +606,16 @@
(progn
(calc-default-formula-arglist expr)
(setq record-entry t
- arglist (sort arglist 'string-lessp))
+ math-arglist (sort math-arglist 'string-lessp))
(if calc-verify-arglist
- (setq arglist (read-from-minibuffer
+ (setq math-arglist (read-from-minibuffer
"Function argument list: "
- (if arglist
- (prin1-to-string arglist)
+ (if math-arglist
+ (prin1-to-string math-arglist)
"()")
minibuffer-local-map
t)))
- (setq arglist (mapcar (function
+ (setq math-arglist (mapcar (function
(lambda (x)
(list 'var
x
@@ -624,10 +623,10 @@
(concat
"var-"
(symbol-name x))))))
- arglist))))
+ math-arglist))))
(setq oper (list "$"
- (length arglist)
- (append '(calcFunc-lambda) arglist
+ (length math-arglist)
+ (append '(calcFunc-lambda) math-arglist
(list expr)))
done t))
(if record-entry
@@ -1274,5 +1273,4 @@
(provide 'calc-map)
-;; arch-tag: 980eac49-00e0-4870-b72a-e726b74c7990
;;; calc-map.el ends here
diff --git a/lisp/calc/calc-math.el b/lisp/calc/calc-math.el
index cd1b86d6b9f..076dab31fd9 100644
--- a/lisp/calc/calc-math.el
+++ b/lisp/calc/calc-math.el
@@ -1,7 +1,6 @@
;;; calc-math.el --- mathematical functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -1575,7 +1574,7 @@ If this can't be done, return NIL."
(if calc-infinite-mode
'(neg (var inf var-inf))
(math-reject-arg x "*Logarithm of zero")))
- (calc-symbolic-mode (signal 'inexact-result nil))
+ (calc-symbolic-mode (signal 'inexact-result nil))
((Math-numberp x)
(math-with-extra-prec 2
(let ((xf (math-float x)))
@@ -2165,5 +2164,4 @@ If this can't be done, return NIL."
(provide 'calc-math)
-;; arch-tag: c7367e8e-d0b8-4f70-8577-2fb3f31dbb4c
;;; calc-math.el ends here
diff --git a/lisp/calc/calc-menu.el b/lisp/calc/calc-menu.el
index 40f8ff9987a..d8099b0aadc 100644
--- a/lisp/calc/calc-menu.el
+++ b/lisp/calc/calc-menu.el
@@ -1,6 +1,6 @@
;;; calc-menu.el --- a menu for Calc
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -960,6 +960,111 @@
(require 'calc-units)
(call-interactively 'calc-view-units-table))
:keys "u V"]
+ (list "Logarithmic Units"
+ ["Convert (1:) to dB (power)"
+ (progn
+ (require 'calc-units)
+ (call-interactively 'calc-db))
+ :keys "l d"
+ :active (>= (calc-stack-size) 1)]
+ ["Convert (2:) to dB (power) with reference level (1:)"
+ (progn
+ (require 'calc-units)
+ (let ((calc-option-flag t))
+ (call-interactively 'calc-db)))
+ :keys "O l d"
+ :active (>= (calc-stack-size) 2)]
+ ["Convert (1:) to Np (power)"
+ (progn
+ (require 'calc-units)
+ (call-interactively 'calc-np))
+ :keys "l n"
+ :active (>= (calc-stack-size) 1)]
+ ["Convert (2:) to Np (power) with reference level (1:)"
+ (progn
+ (require 'calc-units)
+ (let ((calc-option-flag t))
+ (call-interactively 'calc-np)))
+ :keys "O l n"
+ :active (>= (calc-stack-size) 2)]
+ ["Convert (1:) to power quantity"
+ (progn
+ (require 'calc-units)
+ (call-interactively 'calc-lu-quant))
+ :keys "l q"
+ :active (>= (calc-stack-size) 1)]
+ ["Convert (2:) to power quantity with reference level (1:)"
+ (progn
+ (require 'calc-units)
+ (let ((calc-option-flag t))
+ (call-interactively 'calc-lu-quant)))
+ :keys "O l q"
+ :active (>= (calc-stack-size) 2)]
+ "----"
+ ["Convert (1:) to dB (field)"
+ (progn
+ (require 'calc-units)
+ (let ((calc-hyperbolic-flag t))
+ (call-interactively 'calc-db)))
+ :keys "H l d"
+ :active (>= (calc-stack-size) 1)]
+ ["Convert (2:) to dB (field) with reference level (1:)"
+ (progn
+ (require 'calc-units)
+ (let ((calc-option-flag t)
+ (calc-hyperbolic-flag t))
+ (call-interactively 'calc-db)))
+ :keys "O H l d"
+ :active (>= (calc-stack-size) 2)]
+ ["Convert (1:) to Np (field)"
+ (progn
+ (require 'calc-units)
+ (let ((calc-hyperbolic-flag t))
+ (call-interactively 'calc-np)))
+ :keys "H l n"
+ :active (>= (calc-stack-size) 1)]
+ ["Convert (2:) to Np (field) with reference level (1:)"
+ (progn
+ (require 'calc-units)
+ (let ((calc-option-flag t)
+ (calc-hyperbolic-flag t))
+ (call-interactively 'calc-np)))
+ :keys "O H l d"
+ :active (>= (calc-stack-size) 2)]
+ ["Convert (1:) to field quantity"
+ (progn
+ (require 'calc-units)
+ (let ((calc-hyperbolic-flag t))
+ (call-interactively 'calc-lu-quant)))
+ :keys "H l q"
+ :active (>= (calc-stack-size) 1)]
+ ["Convert (2:) to field quantity with reference level (1:)"
+ (progn
+ (require 'calc-units)
+ (let ((calc-option-flag t)
+ (calc-hyperbolic-flag))
+ (call-interactively 'calc-lu-quant)))
+ :keys "O H l q"
+ :active (>= (calc-stack-size) 2)])
+ (list "Musical Notes"
+ ["Convert (1:) to scientific pitch notation"
+ (progn
+ (require 'calc-units)
+ (call-interactively 'calc-spn))
+ :keys "l s"
+ :active (>= (calc-stack-size) 1)]
+ ["Convert (1:) to midi number"
+ (progn
+ (require 'calc-units)
+ (call-interactively 'calc-midi))
+ :keys "l m"
+ :active (>= (calc-stack-size) 1)]
+ ["Convert (1:) to frequency"
+ (progn
+ (require 'calc-units)
+ (call-interactively 'calc-freq))
+ :keys "l f"
+ :active (>= (calc-stack-size) 1)])
"----"
["Help on Units"
(calc-info-goto-node "Units")])
@@ -1461,4 +1566,3 @@
(provide 'calc-menu)
-;; arch-tag: 9612c86a-cd4f-4baa-ab0b-40af7344d21f
diff --git a/lisp/calc/calc-misc.el b/lisp/calc/calc-misc.el
index ea9210cef76..db86c08422e 100644
--- a/lisp/calc/calc-misc.el
+++ b/lisp/calc/calc-misc.el
@@ -1,7 +1,6 @@
;;; calc-misc.el --- miscellaneous functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -35,6 +34,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 +219,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 +245,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]")
+ ""))))))))
+
@@ -960,5 +962,4 @@ doing 'M-x toggle-debug-on-error', then reproducing the bug.
;; generated-autoload-file: "calc-loaddefs.el"
;; End:
-;; arch-tag: 7984d9d0-62e5-41dc-afb8-e904b975f250
;;; calc-misc.el ends here
diff --git a/lisp/calc/calc-mode.el b/lisp/calc/calc-mode.el
index e9edd0c1724..856dfad882d 100644
--- a/lisp/calc/calc-mode.el
+++ b/lisp/calc/calc-mode.el
@@ -1,7 +1,6 @@
;;; calc-mode.el --- calculator modes for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -677,5 +676,4 @@
(provide 'calc-mode)
-;; arch-tag: ecc70eea-c712-43f2-9085-4205e58d6ddf
;;; calc-mode.el ends here
diff --git a/lisp/calc/calc-mtx.el b/lisp/calc/calc-mtx.el
index 1c2a74d2a8b..5ec15005b48 100644
--- a/lisp/calc/calc-mtx.el
+++ b/lisp/calc/calc-mtx.el
@@ -1,7 +1,6 @@
;;; calc-mtx.el --- matrix functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -233,6 +232,20 @@
(setq math-lud-cache (cons (cons m entry) math-lud-cache)))
lud))))
+
+(defun math-lud-pivot-check (a)
+ "Determine a useful value for checking the size of potential pivots
+in LUD decomposition."
+ (cond ((eq (car-safe a) 'mod)
+ (if (and (math-integerp (nth 1 a))
+ (math-integerp (nth 2 a))
+ (eq (math-gcd (nth 1 a) (nth 2 a)) 1))
+ 1
+ 0))
+ (t
+ (math-abs-approx a))))
+
+
;;; Numerical Recipes section 2.3; implicit pivoting omitted.
(defun math-do-matrix-lud (m)
(let* ((lu (math-copy-matrix m))
@@ -262,7 +275,7 @@
(nth j (nth k lu))))
k (1+ k)))
(setcar (nthcdr j (nth i lu)) sum)
- (let ((dum (math-abs-approx sum)))
+ (let ((dum (math-lud-pivot-check sum)))
(if (Math-lessp big dum)
(setq big dum
imax i)))
@@ -365,5 +378,4 @@
(provide 'calc-mtx)
-;; arch-tag: fc0947b1-90e1-4a23-8950-d8ead9c3a306
;;; calc-mtx.el ends here
diff --git a/lisp/calc/calc-nlfit.el b/lisp/calc/calc-nlfit.el
index 985d9326fc1..37e6f66c1b1 100644
--- a/lisp/calc/calc-nlfit.el
+++ b/lisp/calc/calc-nlfit.el
@@ -1,6 +1,6 @@
;;; calc-nlfit.el --- nonlinear curve fitting for Calc
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -818,4 +818,3 @@
(provide 'calc-nlfit)
-;; arch-tag: 6eba3cd6-f48b-4a84-8174-10c15a024928
diff --git a/lisp/calc/calc-poly.el b/lisp/calc/calc-poly.el
index 94ed8aa0c7f..e16c26eaa19 100644
--- a/lisp/calc/calc-poly.el
+++ b/lisp/calc/calc-poly.el
@@ -1,7 +1,6 @@
;;; calc-poly.el --- polynomial functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -663,7 +662,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)
@@ -1200,5 +1199,4 @@ If no partial fraction representation can be found, return nil."
(provide 'calc-poly)
-;; arch-tag: d2566c51-2ccc-45f1-8c50-f3462c2953ff
;;; calc-poly.el ends here
diff --git a/lisp/calc/calc-prog.el b/lisp/calc/calc-prog.el
index a925be0bb39..0d3fbe8586a 100644
--- a/lisp/calc/calc-prog.el
+++ b/lisp/calc/calc-prog.el
@@ -1,7 +1,6 @@
;;; calc-prog.el --- user programmability functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -171,17 +170,17 @@
(interactive)
(calc-wrapper
(let* ((form (calc-top 1))
- (arglist nil)
+ (math-arglist nil)
(is-lambda (and (eq (car-safe form) 'calcFunc-lambda)
(>= (length form) 2)))
odef key keyname cmd cmd-base cmd-base-default
func calc-user-formula-alist is-symb)
(if is-lambda
- (setq arglist (mapcar (function (lambda (x) (nth 1 x)))
+ (setq math-arglist (mapcar (function (lambda (x) (nth 1 x)))
(nreverse (cdr (reverse (cdr form)))))
form (nth (1- (length form)) form))
(calc-default-formula-arglist form)
- (setq arglist (sort arglist 'string-lessp)))
+ (setq math-arglist (sort math-arglist 'string-lessp)))
(message "Define user key: z-")
(setq key (read-char))
(if (= (calc-user-function-classify key) 0)
@@ -267,17 +266,17 @@
(format "%05d" (% (random) 10000)))))))
(if is-lambda
- (setq calc-user-formula-alist arglist)
+ (setq calc-user-formula-alist math-arglist)
(while
(progn
(setq calc-user-formula-alist
(read-from-minibuffer "Function argument list: "
- (if arglist
- (prin1-to-string arglist)
+ (if math-arglist
+ (prin1-to-string math-arglist)
"()")
minibuffer-local-map
t))
- (and (not (calc-subsetp calc-user-formula-alist arglist))
+ (and (not (calc-subsetp calc-user-formula-alist math-arglist))
(not (y-or-n-p
"Okay for arguments that don't appear in formula to be ignored? "))))))
(setq is-symb (and calc-user-formula-alist
@@ -328,14 +327,14 @@
(setcdr kmap (cons (cons key cmd) (cdr kmap)))))))
(message "")))
-(defvar arglist) ; dynamically bound in all callers
+(defvar math-arglist) ; dynamically bound in all callers
(defun calc-default-formula-arglist (form)
(if (consp form)
(if (eq (car form) 'var)
- (if (or (memq (nth 1 form) arglist)
+ (if (or (memq (nth 1 form) math-arglist)
(math-const-var form))
()
- (setq arglist (cons (nth 1 form) arglist)))
+ (setq math-arglist (cons (nth 1 form) math-arglist)))
(calc-default-formula-arglist-step (cdr form)))))
(defun calc-default-formula-arglist-step (l)
@@ -394,23 +393,23 @@
(intern (concat "calcFunc-" x))))))))
(comps (get func 'math-compose-forms))
entry entry2
- (arglist nil)
+ (math-arglist nil)
(calc-user-formula-alist nil))
(if (math-zerop comp)
(if (setq entry (assq calc-language comps))
(put func 'math-compose-forms (delq entry comps)))
(calc-default-formula-arglist comp)
- (setq arglist (sort arglist 'string-lessp))
+ (setq math-arglist (sort math-arglist 'string-lessp))
(while
(progn
(setq calc-user-formula-alist
(read-from-minibuffer "Composition argument list: "
- (if arglist
- (prin1-to-string arglist)
+ (if math-arglist
+ (prin1-to-string math-arglist)
"()")
minibuffer-local-map
t))
- (and (not (calc-subsetp calc-user-formula-alist arglist))
+ (and (not (calc-subsetp calc-user-formula-alist math-arglist))
(y-or-n-p
"Okay for arguments that don't appear in formula to be invisible? "))))
(or (setq entry (assq calc-language comps))
@@ -627,7 +626,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)
@@ -2364,5 +2364,4 @@ Redefine the corresponding command."
(provide 'calc-prog)
-;; arch-tag: 4c5a183b-c9e5-4632-bb3f-e41a764518b0
;;; calc-prog.el ends here
diff --git a/lisp/calc/calc-rewr.el b/lisp/calc/calc-rewr.el
index f7c5727a0c9..1498b622e1f 100644
--- a/lisp/calc/calc-rewr.el
+++ b/lisp/calc/calc-rewr.el
@@ -1,7 +1,6 @@
;;; calc-rewr.el --- rewriting functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -2108,5 +2107,4 @@
(provide 'calc-rewr)
-;; arch-tag: ca8d7b7d-bff1-4535-90f3-e2241f5e786b
;;; calc-rewr.el ends here
diff --git a/lisp/calc/calc-rules.el b/lisp/calc/calc-rules.el
index d5ebe715c84..fa57a350729 100644
--- a/lisp/calc/calc-rules.el
+++ b/lisp/calc/calc-rules.el
@@ -1,7 +1,6 @@
;;; calc-rules.el --- rules for simplifying algebraic expressions in Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -445,5 +444,4 @@ fitparam(n) = x := x ]"))
(provide 'calc-rules)
-;; arch-tag: 0ed54a52-38f3-4ed7-9ca7-b8ecf8f2febe
;;; calc-rules.el ends here
diff --git a/lisp/calc/calc-sel.el b/lisp/calc/calc-sel.el
index aa9e1d8308a..26834a44598 100644
--- a/lisp/calc/calc-sel.el
+++ b/lisp/calc/calc-sel.el
@@ -1,7 +1,6 @@
;;; calc-sel.el --- data selection functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -309,6 +308,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 +331,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.
@@ -870,5 +875,4 @@
(provide 'calc-sel)
-;; arch-tag: e5169792-777d-428f-bff5-acca66813fa2
;;; calc-sel.el ends here
diff --git a/lisp/calc/calc-stat.el b/lisp/calc/calc-stat.el
index 9605a059f17..83ce71a2376 100644
--- a/lisp/calc/calc-stat.el
+++ b/lisp/calc/calc-stat.el
@@ -1,7 +1,6 @@
;;; calc-stat.el --- statistical functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -583,5 +582,4 @@
(provide 'calc-stat)
-;; arch-tag: 423858e9-8513-489c-9f35-710cd9d9c307
;;; calc-stat.el ends here
diff --git a/lisp/calc/calc-store.el b/lisp/calc/calc-store.el
index 16a3d34ea54..2da551ee215 100644
--- a/lisp/calc/calc-store.el
+++ b/lisp/calc/calc-store.el
@@ -1,7 +1,6 @@
;;; calc-store.el --- value storage functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -197,12 +196,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 +676,8 @@
(provide 'calc-store)
-;; arch-tag: 2fbfec82-a521-42ca-bcd8-4f254ae6313e
+;; Local variables:
+;; coding: utf-8
+;; End:
+
;;; calc-store.el ends here
diff --git a/lisp/calc/calc-stuff.el b/lisp/calc/calc-stuff.el
index 2078080d6f8..0558d8d2285 100644
--- a/lisp/calc/calc-stuff.el
+++ b/lisp/calc/calc-stuff.el
@@ -1,7 +1,6 @@
;;; calc-stuff.el --- miscellaneous functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -295,5 +294,4 @@ With a prefix, push that prefix as a number onto the stack."
(provide 'calc-stuff)
-;; arch-tag: 789332ef-a178-49d3-8fb7-5d7ed7e21f56
;;; calc-stuff.el ends here
diff --git a/lisp/calc/calc-trail.el b/lisp/calc/calc-trail.el
index c4620610721..eec4cd2af58 100644
--- a/lisp/calc/calc-trail.el
+++ b/lisp/calc/calc-trail.el
@@ -1,7 +1,6 @@
;;; calc-trail.el --- functions for manipulating the Calc "trail"
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -108,20 +107,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")
@@ -173,5 +180,4 @@
(provide 'calc-trail)
-;; arch-tag: 59b76655-d882-4aab-a3ee-b83870e530d0
;;; calc-trail.el ends here
diff --git a/lisp/calc/calc-undo.el b/lisp/calc/calc-undo.el
index 72cc2e62f7c..9168d9b0947 100644
--- a/lisp/calc/calc-undo.el
+++ b/lisp/calc/calc-undo.el
@@ -1,7 +1,6 @@
;;; calc-undo.el --- undo functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -32,6 +31,7 @@
;;; Undo.
+;;;###autoload
(defun calc-undo (n)
(interactive "p")
(when calc-executing-macro
@@ -148,5 +148,4 @@
(provide 'calc-undo)
-;; arch-tag: eeb485d2-fb3d-454a-9d79-450af1f50d6c
;;; calc-undo.el ends here
diff --git a/lisp/calc/calc-units.el b/lisp/calc/calc-units.el
index 2f650fc2e08..43cb5828e85 100644
--- a/lisp/calc/calc-units.el
+++ b/lisp/calc/calc-units.el
@@ -1,7 +1,6 @@
;;; calc-units.el --- unit conversion functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -36,13 +35,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 +56,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 +85,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 +209,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 +259,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 +274,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
@@ -289,7 +295,10 @@
( R0 "8.314472 J/(mol K)" "Molar gas constant" nil
"8.314472 J/(mol K) (*)")
( V0 "22.710981*10^(-3) m^3/mol" "Standard volume of ideal gas" nil
- "22.710981 10^-3 m^3/mol (*)")))
+ "22.710981 10^-3 m^3/mol (*)")
+ ;; Logarithmic units
+ ( Np nil "*Neper")
+ ( dB "(ln(10)/20) Np" "decibel")))
(defvar math-additional-units nil
@@ -316,6 +325,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 +591,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 +602,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)))))
@@ -863,6 +873,7 @@ If EXPR is nil, return nil."
(or (eq (nth 1 expr) 'pi)
(error "Unknown name %s in defining expression for unit %s"
(nth 1 expr) (car math-fbu-entry))))
+ ((equal expr '(calcFunc-ln 10)))
(t (error "Malformed defining expression for unit %s" (car math-fbu-entry))))))
@@ -949,7 +960,10 @@ If EXPR is nil, return nil."
(if (eq base 'pi)
(math-pi)
expr)))
- (if (Math-primp expr)
+ (if (or
+ (Math-primp expr)
+ (and (eq (car-safe expr) 'calcFunc-subscr)
+ (eq (car-safe (nth 1 expr)) 'var)))
expr
(cons (car expr)
(mapcar 'math-to-standard-rec (cdr expr))))))
@@ -1523,7 +1537,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)
@@ -1538,11 +1557,528 @@ If EXPR is nil, return nil."
(pop-to-buffer (get-buffer "*Units Table*"))
(display-buffer (get-buffer "*Units Table*")))))
+;;; Logarithmic units functions
+
+(defvar math-logunits '((var dB var-dB)
+ (var Np var-Np)))
+
+(defun math-conditional-apply (fn &rest args)
+ "Evaluate f(args) unless in symbolic mode.
+In symbolic mode, return the list (fn args)."
+ (if calc-symbolic-mode
+ (cons fn args)
+ (apply fn args)))
+
+(defun math-conditional-pow (a b)
+ "Evaluate a^b unless in symbolic mode.
+In symbolic mode, return the list (^ a b)."
+ (if calc-symbolic-mode
+ (list '^ a b)
+ (math-pow a b)))
+
+(defun math-extract-logunits (expr)
+ (if (memq (car-safe expr) '(* /))
+ (cons (car expr)
+ (mapcar 'math-extract-logunits (cdr expr)))
+ (if (memq (car-safe expr) '(^))
+ (list '^ (math-extract-logunits (nth 1 expr)) (nth 2 expr))
+ (if (member expr math-logunits) expr 1))))
+
+(defun math-logunits-add (a b neg power)
+ (let ((aunit (math-simplify (math-extract-logunits a))))
+ (if (not (eq (car-safe aunit) 'var))
+ (calc-record-why "*Improper logarithmic unit" aunit)
+ (let* ((units (math-extract-units a))
+ (acoeff (math-simplify (math-remove-units a)))
+ (bcoeff (math-simplify (math-to-standard-units
+ (list '/ b units) nil))))
+ (if (math-units-in-expr-p bcoeff nil)
+ (calc-record-why "*Inconsistent units" nil)
+ (if (and neg
+ (or (math-lessp acoeff bcoeff)
+ (math-equal acoeff bcoeff)))
+ (calc-record-why "*Improper coefficients" nil)
+ (math-mul
+ (if (equal aunit '(var dB var-dB))
+ (let ((coef (if power 10 20)))
+ (math-mul coef
+ (math-conditional-apply 'calcFunc-log10
+ (if neg
+ (math-sub
+ (math-conditional-pow 10 (math-div acoeff coef))
+ (math-conditional-pow 10 (math-div bcoeff coef)))
+ (math-add
+ (math-conditional-pow 10 (math-div acoeff coef))
+ (math-conditional-pow 10 (math-div bcoeff coef)))))))
+ (let ((coef (if power 2 1)))
+ (math-div
+ (math-conditional-apply 'calcFunc-ln
+ (if neg
+ (math-sub
+ (math-conditional-apply 'calcFunc-exp (math-mul coef acoeff))
+ (math-conditional-apply 'calcFunc-exp (math-mul coef bcoeff)))
+ (math-add
+ (math-conditional-apply 'calcFunc-exp (math-mul coef acoeff))
+ (math-conditional-apply 'calcFunc-exp (math-mul coef bcoeff)))))
+ coef)))
+ units)))))))
+
+(defun calcFunc-lufadd (a b)
+ (math-logunits-add a b nil nil))
+
+(defun calcFunc-lupadd (a b)
+ (math-logunits-add a b nil t))
+
+(defun calcFunc-lufsub (a b)
+ (math-logunits-add a b t nil))
+
+(defun calcFunc-lupsub (a b)
+ (math-logunits-add a b t t))
+
+(defun calc-lu-plus (arg)
+ (interactive "P")
+ (calc-slow-wrapper
+ (if (calc-is-inverse)
+ (if (calc-is-hyperbolic)
+ (calc-binary-op "lu-" 'calcFunc-lufsub arg)
+ (calc-binary-op "lu-" 'calcFunc-lupsub arg))
+ (if (calc-is-hyperbolic)
+ (calc-binary-op "lu+" 'calcFunc-lufadd arg)
+ (calc-binary-op "lu+" 'calcFunc-lupadd arg)))))
+
+(defun calc-lu-minus (arg)
+ (interactive "P")
+ (calc-slow-wrapper
+ (if (calc-is-inverse)
+ (if (calc-is-hyperbolic)
+ (calc-binary-op "lu+" 'calcFunc-lufadd arg)
+ (calc-binary-op "lu+" 'calcFunc-lupadd arg))
+ (if (calc-is-hyperbolic)
+ (calc-binary-op "lu-" 'calcFunc-lufsub arg)
+ (calc-binary-op "lu-" 'calcFunc-lupsub arg)))))
+
+(defun math-logunits-mul (a b power)
+ (let (logunit coef units number)
+ (cond
+ ((and
+ (setq logunit (math-simplify (math-extract-logunits a)))
+ (eq (car-safe logunit) 'var)
+ (eq (math-simplify (math-extract-units b)) 1))
+ (setq coef (math-simplify (math-remove-units a))
+ units (math-extract-units a)
+ number b))
+ ((and
+ (setq logunit (math-simplify (math-extract-logunits b)))
+ (eq (car-safe logunit) 'var)
+ (eq (math-simplify (math-extract-units a)) 1))
+ (setq coef (math-simplify (math-remove-units b))
+ units (math-extract-units b)
+ number a))
+ (t (setq logunit nil)))
+ (if logunit
+ (cond
+ ((equal logunit '(var dB var-dB))
+ (math-simplify
+ (math-mul
+ (math-add
+ coef
+ (math-mul (if power 10 20)
+ (math-conditional-apply 'calcFunc-log10 number)))
+ units)))
+ (t
+ (math-simplify
+ (math-mul
+ (math-add
+ coef
+ (math-div (math-conditional-apply 'calcFunc-ln number) (if power 2 1)))
+ units))))
+ (calc-record-why "*Improper units" nil))))
+
+(defun math-logunits-divide (a b power)
+ (let ((logunit (math-simplify (math-extract-logunits a))))
+ (if (not (eq (car-safe logunit) 'var))
+ (calc-record-why "*Improper logarithmic unit" logunit)
+ (if (math-units-in-expr-p b nil)
+ (calc-record-why "*Improper units quantity" b)
+ (let* ((units (math-extract-units a))
+ (coef (math-simplify (math-remove-units a))))
+ (cond
+ ((equal logunit '(var dB var-dB))
+ (math-simplify
+ (math-mul
+ (math-sub
+ coef
+ (math-mul (if power 10 20)
+ (math-conditional-apply 'calcFunc-log10 b)))
+ units)))
+ (t
+ (math-simplify
+ (math-mul
+ (math-sub
+ coef
+ (math-div (math-conditional-apply 'calcFunc-ln b) (if power 2 1)))
+ units)))))))))
+
+(defun calcFunc-lufmul (a b)
+ (math-logunits-mul a b nil))
+
+(defun calcFunc-lupmul (a b)
+ (math-logunits-mul a b t))
+
+(defun calc-lu-times (arg)
+ (interactive "P")
+ (calc-slow-wrapper
+ (if (calc-is-inverse)
+ (if (calc-is-hyperbolic)
+ (calc-binary-op "lu/" 'calcFunc-lufdiv arg)
+ (calc-binary-op "lu/" 'calcFunc-lupdiv arg))
+ (if (calc-is-hyperbolic)
+ (calc-binary-op "lu*" 'calcFunc-lufmul arg)
+ (calc-binary-op "lu*" 'calcFunc-lupmul arg)))))
+
+(defun calcFunc-lufdiv (a b)
+ (math-logunits-divide a b nil))
+
+(defun calcFunc-lupdiv (a b)
+ (math-logunits-divide a b t))
+
+(defun calc-lu-divide (arg)
+ (interactive "P")
+ (calc-slow-wrapper
+ (if (calc-is-inverse)
+ (if (calc-is-hyperbolic)
+ (calc-binary-op "lu*" 'calcFunc-lufmul arg)
+ (calc-binary-op "lu*" 'calcFunc-lupmul arg))
+ (if (calc-is-hyperbolic)
+ (calc-binary-op "lu/" 'calcFunc-lufdiv arg)
+ (calc-binary-op "lu/" 'calcFunc-lupdiv arg)))))
+
+(defun math-logunits-quant (val ref power)
+ (let* ((units (math-simplify (math-extract-units val)))
+ (lunit (math-simplify (math-extract-logunits units))))
+ (if (not (eq (car-safe lunit) 'var))
+ (calc-record-why "*Improper logarithmic unit" lunit)
+ (let ((runits (math-simplify (math-div units lunit)))
+ (coeff (math-simplify (math-div val units))))
+ (math-mul
+ (if (equal lunit '(var dB var-dB))
+ (math-mul
+ ref
+ (math-conditional-pow
+ 10
+ (math-div
+ coeff
+ (if power 10 20))))
+ (math-mul
+ ref
+ (math-conditional-apply 'calcFunc-exp
+ (if power
+ (math-mul 2 coeff)
+ coeff))))
+ runits)))))
+
+(defvar calc-lu-field-reference)
+(defvar calc-lu-power-reference)
+
+(defun calcFunc-lufquant (val &optional ref)
+ (unless ref
+ (setq ref (math-read-expr calc-lu-field-reference)))
+ (math-logunits-quant val ref nil))
+
+(defun calcFunc-lupquant (val &optional ref)
+ (unless ref
+ (setq ref (math-read-expr calc-lu-power-reference)))
+ (math-logunits-quant val ref t))
+
+(defun calc-lu-quant (arg)
+ (interactive "P")
+ (calc-slow-wrapper
+ (if (calc-is-hyperbolic)
+ (if (calc-is-option)
+ (calc-binary-op "lupq" 'calcFunc-lufquant arg)
+ (calc-unary-op "lupq" 'calcFunc-lufquant arg))
+ (if (calc-is-option)
+ (calc-binary-op "lufq" 'calcFunc-lupquant arg)
+ (calc-unary-op "lufq" 'calcFunc-lupquant arg)))))
+
+(defun math-logunits-level (val ref db power)
+ "Compute the value of VAL in decibels or nepers."
+ (let* ((ratio (math-simplify-units (math-div val ref)))
+ (ratiou (math-simplify-units (math-remove-units ratio)))
+ (units (math-simplify (math-extract-units ratio))))
+ (math-mul
+ (if db
+ (math-mul
+ (math-mul (if power 10 20)
+ (math-conditional-apply 'calcFunc-log10 ratiou))
+ '(var dB var-dB))
+ (math-mul
+ (math-div (math-conditional-apply 'calcFunc-ln ratiou) (if power 2 1))
+ '(var Np var-Np)))
+ units)))
+
+(defun calcFunc-dbfield (val &optional ref)
+ (unless ref
+ (setq ref (math-read-expr calc-lu-field-reference)))
+ (math-logunits-level val ref t nil))
+
+(defun calcFunc-dbpower (val &optional ref)
+ (unless ref
+ (setq ref (math-read-expr calc-lu-power-reference)))
+ (math-logunits-level val ref t t))
+
+(defun calcFunc-npfield (val &optional ref)
+ (unless ref
+ (setq ref (math-read-expr calc-lu-field-reference)))
+ (math-logunits-level val ref nil nil))
+
+(defun calcFunc-nppower (val &optional ref)
+ (unless ref
+ (setq ref (math-read-expr calc-lu-power-reference)))
+ (math-logunits-level val ref nil t))
+
+(defun calc-db (arg)
+ (interactive "P")
+ (calc-slow-wrapper
+ (if (calc-is-hyperbolic)
+ (if (calc-is-option)
+ (calc-binary-op "ludb" 'calcFunc-dbfield arg)
+ (calc-unary-op "ludb" 'calcFunc-dbfield arg))
+ (if (calc-is-option)
+ (calc-binary-op "ludb" 'calcFunc-dbpower arg)
+ (calc-unary-op "ludb" 'calcFunc-dbpower arg)))))
+
+(defun calc-np (arg)
+ (interactive "P")
+ (calc-slow-wrapper
+ (if (calc-is-hyperbolic)
+ (if (calc-is-option)
+ (calc-binary-op "lunp" 'calcFunc-npfield arg)
+ (calc-unary-op "lunp" 'calcFunc-npfield arg))
+ (if (calc-is-option)
+ (calc-binary-op "lunp" 'calcFunc-nppower arg)
+ (calc-unary-op "lunp" 'calcFunc-nppower arg)))))
+
+;;; Musical notes
+
+
+(defvar calc-note-threshold)
+
+(defun math-midi-round (num)
+ "Round NUM to an integer N if NUM is within calc-note-threshold cents of N."
+ (let* ((n (math-round num))
+ (diff (math-abs
+ (math-sub num n))))
+ (if (< (math-compare diff
+ (math-div (math-read-expr calc-note-threshold) 100)) 0)
+ n
+ num)))
+
+(defconst math-notes
+ '(((var C var-C) . 0)
+ ((var Csharp var-Csharp) . 1)
+; ((var C♯ var-C♯) . 1)
+ ((var Dflat var-Dflat) . 1)
+; ((var D♭ var-D♭) . 1)
+ ((var D var-D) . 2)
+ ((var Dsharp var-Dsharp) . 3)
+; ((var D♯ var-D♯) . 3)
+ ((var E var-E) . 4)
+ ((var F var-F) . 5)
+ ((var Fsharp var-Fsharp) . 6)
+; ((var F♯ var-F♯) . 6)
+ ((var Gflat var-Gflat) . 6)
+; ((var G♭ var-G♭) . 6)
+ ((var G var-G) . 7)
+ ((var Gsharp var-Gsharp) . 8)
+; ((var G♯ var-G♯) . 8)
+ ((var A var-A) . 9)
+ ((var Asharp var-Asharp) . 10)
+; ((var A♯ var-A♯) . 10)
+ ((var Bflat var-Bflat) . 10)
+; ((var B♭ var-B♭) . 10)
+ ((var B var-B) . 11))
+ "An alist of notes with their number of semitones above C.")
+
+(defun math-freqp (freq)
+ "Non-nil if FREQ is a positive number times the unit Hz.
+If non-nil, return the coefficient of Hz."
+ (let ((freqcoef (math-simplify-units
+ (math-div freq '(var Hz var-Hz)))))
+ (if (Math-posp freqcoef) freqcoef)))
+
+(defun math-midip (num)
+ "Non-nil if NUM is a possible MIDI note number.
+If non-nil, return NUM."
+ (if (Math-numberp num) num))
+
+(defun math-spnp (spn)
+ "Non-nil if NUM is a scientific pitch note (note + cents).
+If non-nil, return a list consisting of the note and the cents coefficient."
+ (let (note cents rnote rcents)
+ (if (eq (car-safe spn) '+)
+ (setq note (nth 1 spn)
+ cents (nth 2 spn))
+ (setq note spn
+ cents nil))
+ (cond
+ ((and ;; NOTE is a note, CENTS is nil or cents.
+ (eq (car-safe note) 'calcFunc-subscr)
+ (assoc (nth 1 note) math-notes)
+ (integerp (nth 2 note))
+ (setq rnote note)
+ (or
+ (not cents)
+ (Math-numberp (setq rcents
+ (math-simplify
+ (math-div cents '(var cents var-cents)))))))
+ (list rnote rcents))
+ ((and ;; CENTS is a note, NOTE is cents.
+ (eq (car-safe cents) 'calcFunc-subscr)
+ (assoc (nth 1 cents) math-notes)
+ (integerp (nth 2 cents))
+ (setq rnote cents)
+ (or
+ (not note)
+ (Math-numberp (setq rcents
+ (math-simplify
+ (math-div note '(var cents var-cents)))))))
+ (list rnote rcents)))))
+
+(defun math-freq-to-midi (freq)
+ "Return the midi note number corresponding to FREQ Hz."
+ (let ((midi (math-add
+ 69
+ (math-mul
+ 12
+ (calcFunc-log
+ (math-div freq 440)
+ 2)))))
+ (math-midi-round midi)))
+
+(defun math-spn-to-midi (spn)
+ "Return the MIDI number corresponding to SPN."
+ (let* ((note (cdr (assoc (nth 1 (car spn)) math-notes)))
+ (octave (math-add (nth 2 (car spn)) 1))
+ (cents (nth 1 spn))
+ (midi (math-add
+ (math-mul 12 octave)
+ note)))
+ (if cents
+ (math-add midi (math-div cents 100))
+ midi)))
+
+(defun math-midi-to-spn (midi)
+ "Return the scientific pitch notation corresponding to midi number MIDI."
+ (let (midin cents)
+ (if (math-integerp midi)
+ (setq midin midi
+ cents nil)
+ (setq midin (math-floor midi)
+ cents (math-mul 100 (math-sub midi midin))))
+ (let* ((nr ;; This should be (math-idivmod midin 12), but with
+ ;; better behavior for negative midin.
+ (if (Math-negp midin)
+ (let ((dm (math-idivmod (math-neg midin) 12)))
+ (if (= (cdr dm) 0)
+ (cons (math-neg (car dm)) 0)
+ (cons
+ (math-sub (math-neg (car dm)) 1)
+ (math-sub 12 (cdr dm)))))
+ (math-idivmod midin 12)))
+ (n (math-sub (car nr) 1))
+ (note (car (rassoc (cdr nr) math-notes))))
+ (if cents
+ (list '+ (list 'calcFunc-subscr note n)
+ (list '* cents '(var cents var-cents)))
+ (list 'calcFunc-subscr note n)))))
+
+(defun math-freq-to-spn (freq)
+ "Return the scientific pitch notation corresponding to FREQ Hz."
+ (math-with-extra-prec 3
+ (math-midi-to-spn (math-freq-to-midi freq))))
+
+(defun math-midi-to-freq (midi)
+ "Return the frequency of the note with midi number MIDI."
+ (list '*
+ (math-mul
+ 440
+ (math-pow
+ 2
+ (math-div
+ (math-sub
+ midi
+ 69)
+ 12)))
+ '(var Hz var-Hz)))
+
+(defun math-spn-to-freq (spn)
+ "Return the frequency of the note with scientific pitch notation SPN."
+ (math-midi-to-freq (math-spn-to-midi spn)))
+
+(defun calcFunc-spn (expr)
+ "Return EXPR written as scientific pitch notation + cents."
+ ;; Get the coeffecient of Hz
+ (let (note)
+ (cond
+ ((setq note (math-freqp expr))
+ (math-freq-to-spn note))
+ ((setq note (math-midip expr))
+ (math-midi-to-spn note))
+ ((math-spnp expr)
+ expr)
+ (t
+ (math-reject-arg expr "*Improper expression")))))
+
+(defun calcFunc-midi (expr)
+ "Return EXPR written as a MIDI number."
+ (let (note)
+ (cond
+ ((setq note (math-freqp expr))
+ (math-freq-to-midi note))
+ ((setq note (math-spnp expr))
+ (math-spn-to-midi note))
+ ((math-midip expr)
+ expr)
+ (t
+ (math-reject-arg expr "*Improper expression")))))
+
+(defun calcFunc-freq (expr)
+ "Return the frequency corresponding to EXPR."
+ (let (note)
+ (cond
+ ((setq note (math-midip expr))
+ (math-midi-to-freq note))
+ ((setq note (math-spnp expr))
+ (math-spn-to-freq note))
+ ((math-freqp expr)
+ expr)
+ (t
+ (math-reject-arg expr "*Improper expression")))))
+
+(defun calc-freq (arg)
+ "Return the frequency corresponding to the expression on the stack."
+ (interactive "P")
+ (calc-slow-wrapper
+ (calc-unary-op "freq" 'calcFunc-freq arg)))
+
+(defun calc-midi (arg)
+ "Return the MIDI number corresponding to the expression on the stack."
+ (interactive "P")
+ (calc-slow-wrapper
+ (calc-unary-op "midi" 'calcFunc-midi arg)))
+
+(defun calc-spn (arg)
+ "Return the scientific pitch notation corresponding to the expression on the stack."
+ (interactive "P")
+ (calc-slow-wrapper
+ (calc-unary-op "spn" 'calcFunc-spn arg)))
+
+
(provide 'calc-units)
-;; Local Variables:
-;; coding: iso-latin-1
+;; Local variables:
+;; coding: utf-8
;; End:
-;; arch-tag: e993314f-3adc-4191-be61-4ef8874881c4
;;; calc-units.el ends here
diff --git a/lisp/calc/calc-vec.el b/lisp/calc/calc-vec.el
index c9ed2a0481d..47ef3241b3e 100644
--- a/lisp/calc/calc-vec.el
+++ b/lisp/calc/calc-vec.el
@@ -1,7 +1,6 @@
;;; calc-vec.el --- vector functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -451,16 +450,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")
@@ -758,12 +759,13 @@
(math-reject-arg n "*Index out of range")))))
(defun calcFunc-subscr (mat n &optional m)
- (setq mat (calcFunc-mrow mat n))
- (if m
- (if (math-num-integerp n)
- (calcFunc-mrow mat m)
- (calcFunc-mcol mat m))
- mat))
+ (if (eq (car-safe mat) 'var) nil
+ (setq mat (calcFunc-mrow mat n))
+ (if m
+ (if (math-num-integerp n)
+ (calcFunc-mrow mat m)
+ (calcFunc-mcol mat m))
+ mat)))
;;; Get the Nth column of a matrix.
(defun math-mat-col (mat n)
@@ -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.
@@ -1642,5 +1675,4 @@ of two matrices is a matrix."
(provide 'calc-vec)
-;; arch-tag: 7902a7af-ec69-440a-8635-ebb4db263402
;;; calc-vec.el ends here
diff --git a/lisp/calc/calc-yank.el b/lisp/calc/calc-yank.el
index 18c3393ad08..2360cf00ddc 100644
--- a/lisp/calc/calc-yank.el
+++ b/lisp/calc/calc-yank.el
@@ -1,7 +1,6 @@
;;; calc-yank.el --- kill-ring functionality for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -282,11 +281,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 +709,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 8f18b4931b7..41f549cbe2c 100644
--- a/lisp/calc/calc.el
+++ b/lisp/calc/calc.el
@@ -1,7 +1,6 @@
;;; calc.el --- the GNU Emacs calculator
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -419,12 +418,51 @@ 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)
+
+(defcustom calc-lu-field-reference
+ "20 uPa"
+ "The default reference level for logarithmic units (field)."
+ :group 'calc
+ :type '(string))
+
+(defcustom calc-lu-power-reference
+ "mW"
+ "The default reference level for logarithmic units (power)."
+ :group 'calc
+ :type '(string))
+
+(defcustom calc-note-threshold "1"
+ "The number of cents that a frequency should be near a note
+to be identified as that note."
+ :type 'string
+ :group 'calc)
+
+(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 +835,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 +965,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 +1037,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)))
@@ -1034,12 +1078,13 @@ Used by `calc-user-invocation'.")
(define-key map "\C-j" 'calc-over)
(define-key map "\C-y" 'calc-yank)
(define-key map [mouse-2] 'calc-yank)
+ (define-key map [remap undo] 'calc-undo)
(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"
- ":\\|!()[]<>{},;=~`\C-k\C-w\C-_"))
+ (concat "ABCDEFGHIJKLMNOPQRSTUVXZabcdfghjkmoprstuvwxyz"
+ ":\\|!()[]<>{},;=~`\C-k\C-w"))
(define-key map "\M-w" 'calc-missing-key)
(define-key map "\M-k" 'calc-missing-key)
(define-key map "\M-\C-w" 'calc-missing-key)
@@ -1227,7 +1272,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 +1424,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 +1663,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 +1802,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 +2014,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 +2424,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 +3447,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 +3591,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 +3603,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 +3631,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 +3642,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 +3835,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 +3852,8 @@ See Info node `(calc)Defining Functions'."
(provide 'calc)
-;; arch-tag: 0c3b170c-4ce6-4eaf-8d9b-5834d1fe938f
+;; Local variables:
+;; coding: utf-8
+;; End:
+
;;; calc.el ends here
diff --git a/lisp/calc/calcalg2.el b/lisp/calc/calcalg2.el
index 4a2fb053983..25b51fc89f6 100644
--- a/lisp/calc/calcalg2.el
+++ b/lisp/calc/calcalg2.el
@@ -1,7 +1,6 @@
;;; calcalg2.el --- more algebraic functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -1886,9 +1885,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 +1916,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 +1939,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 +1949,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))
@@ -3669,5 +3668,4 @@
(provide 'calcalg2)
-;; arch-tag: f2932ec8-dd63-418b-a542-11a644b9d4c4
;;; calcalg2.el ends here
diff --git a/lisp/calc/calcalg3.el b/lisp/calc/calcalg3.el
index 600d21303c4..a9118964b46 100644
--- a/lisp/calc/calcalg3.el
+++ b/lisp/calc/calcalg3.el
@@ -1,7 +1,6 @@
;;; calcalg3.el --- more algebraic functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -1928,5 +1927,4 @@
(provide 'calcalg3)
-;; arch-tag: ff9f2920-8111-48b5-b3fa-b0682c3e44a6
;;; calcalg3.el ends here
diff --git a/lisp/calc/calccomp.el b/lisp/calc/calccomp.el
index 5a7d5d75907..906517ac503 100644
--- a/lisp/calc/calccomp.el
+++ b/lisp/calc/calccomp.el
@@ -1,7 +1,6 @@
;;; calccomp.el --- composition functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -50,19 +49,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 +99,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 +110,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 +280,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 +662,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 +733,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 +759,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 +807,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 +868,7 @@
math-comp-vector-prec)
(if (= col cols)
""
- (concat
+ (concat
math-comp-comma-spc " ")))))
a)))
res)))
@@ -878,7 +879,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 +1118,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 +1194,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 +1243,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))))
@@ -1281,12 +1282,7 @@
(let ((prefix "") mrg wid)
(setq mrg (aref math-comp-buf-margin i))
(if (> mrg 12) ; indenting too far, go back to far left
- (let ((j i) (new (if calc-line-numbering 5 1)))
- '(while (<= j math-comp-level)
- (aset math-comp-buf-margin j
- (+ (aref math-comp-buf-margin j) (- new mrg)))
- (setq j (1+ j)))
- (setq mrg new)))
+ (setq mrg (if calc-line-numbering 5 1)))
(setq wid (+ (length str) math-comp-margin))
(and (> (length str) 0) (= (aref str 0) ? )
(> (length math-comp-buf) 0)
@@ -1337,16 +1333,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 +1665,8 @@
(provide 'calccomp)
-;; arch-tag: 7c45d10a-a286-4dab-af49-7ae8989fbf78
+;; Local variables:
+;; coding: utf-8
+;; End:
+
;;; calccomp.el ends here
diff --git a/lisp/calc/calcsel2.el b/lisp/calc/calcsel2.el
index dfe79d07a8b..f44da07763f 100644
--- a/lisp/calc/calcsel2.el
+++ b/lisp/calc/calcsel2.el
@@ -1,7 +1,6 @@
;;; calcsel2.el --- selection functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -300,5 +299,4 @@
(provide 'calcsel2)
-;; arch-tag: 7c5b8d65-b8f0-45d9-820d-9930f8ee114b
;;; calcsel2.el ends here
diff --git a/lisp/calculator.el b/lisp/calculator.el
index fef9c0d2da6..45ed699c4f5 100644
--- a/lisp/calculator.el
+++ b/lisp/calculator.el
@@ -1,7 +1,6 @@
;;; calculator.el --- a [not so] simple calculator for Emacs
-;; Copyright (C) 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 2000-2011 Free Software Foundation, Inc.
;; Author: Eli Barzilay <eli@barzilay.org>
;; Keywords: tools, convenience
@@ -54,7 +53,7 @@
:prefix "calculator"
:version "21.1"
:group 'tools
- :group 'convenience)
+ :group 'applications)
(defcustom calculator-electric-mode nil
"Run `calculator' electrically, in the echo area.
@@ -382,10 +381,7 @@ Used for repeating operations in calculator-repR/L.")
;;;---------------------------------------------------------------------
;;; Key bindings
-(defvar calculator-mode-map nil
- "The calculator key map.")
-
-(or calculator-mode-map
+(defvar calculator-mode-map
(let ((map (make-sparse-keymap)))
(suppress-keymap map t)
(define-key map "i" nil)
@@ -471,113 +467,114 @@ Used for repeating operations in calculator-repR/L.")
("Binary" bin "B")
("Octal" oct "O")
("Hexadecimal" hex "H"))))
- (op '(lambda (name key)
- `[,name (calculator-op ,key) :keys ,key])))
+ (op (lambda (name key)
+ `[,name (calculator-op ,key) :keys ,key])))
(easy-menu-define
- calculator-menu map "Calculator menu."
- `("Calculator"
- ["Help"
- (let ((last-command 'calculator-help)) (calculator-help))
- :keys "?"]
- "---"
- ["Copy" calculator-copy]
- ["Paste" calculator-paste]
- "---"
- ["Electric mode"
- (progn (calculator-quit)
- (setq calculator-restart-other-mode t)
- (run-with-timer 0.1 nil '(lambda () (message nil)))
- ;; the message from the menu will be visible,
- ;; couldn't make it go away...
- (calculator))
- :active (not calculator-electric-mode)]
- ["Normal mode"
- (progn (setq calculator-restart-other-mode t)
- (calculator-quit))
- :active calculator-electric-mode]
- "---"
- ("Functions"
- ,(funcall op "Repeat-right" ">")
- ,(funcall op "Repeat-left" "<")
- "------General------"
- ,(funcall op "Reciprocal" ";")
- ,(funcall op "Log" "L")
- ,(funcall op "Square-root" "Q")
- ,(funcall op "Factorial" "!")
- "------Trigonometric------"
- ,(funcall op "Sinus" "S")
- ,(funcall op "Cosine" "C")
- ,(funcall op "Tangent" "T")
- ,(funcall op "Inv-Sinus" "IS")
- ,(funcall op "Inv-Cosine" "IC")
- ,(funcall op "Inv-Tangent" "IT")
- "------Bitwise------"
- ,(funcall op "Or" "|")
- ,(funcall op "Xor" "#")
- ,(funcall op "And" "&")
- ,(funcall op "Not" "~"))
- ("Saved List"
- ["Eval+Save" calculator-save-on-list]
- ["Prev number" calculator-saved-up]
- ["Next number" calculator-saved-down]
- ["Delete current" calculator-clear
- :active (and calculator-display-fragile
- calculator-saved-list
- (= (car calculator-stack)
- (nth calculator-saved-ptr
- calculator-saved-list)))]
- ["Delete all" calculator-clear-saved]
+ calculator-menu map "Calculator menu."
+ `("Calculator"
+ ["Help"
+ (let ((last-command 'calculator-help)) (calculator-help))
+ :keys "?"]
"---"
- ,(funcall op "List-total" "l")
- ,(funcall op "List-average" "v"))
- ("Registers"
- ["Get register" calculator-get-register]
- ["Set register" calculator-set-register])
- ("Modes"
- ["Radians"
- (progn
- (and (or calculator-input-radix calculator-output-radix)
- (calculator-radix-mode "D"))
- (and calculator-deg (calculator-dec/deg-mode)))
- :keys "D"
- :style radio
- :selected (not (or calculator-input-radix
- calculator-output-radix
- calculator-deg))]
- ["Degrees"
- (progn
- (and (or calculator-input-radix calculator-output-radix)
- (calculator-radix-mode "D"))
- (or calculator-deg (calculator-dec/deg-mode)))
- :keys "D"
- :style radio
- :selected (and calculator-deg
- (not (or calculator-input-radix
- calculator-output-radix)))]
+ ["Copy" calculator-copy]
+ ["Paste" calculator-paste]
"---"
- ,@(mapcar 'car radix-selectors)
- ("Separate I/O"
- ,@(mapcar (lambda (x) (nth 1 x)) radix-selectors)
+ ["Electric mode"
+ (progn (calculator-quit)
+ (setq calculator-restart-other-mode t)
+ (run-with-timer 0.1 nil '(lambda () (message nil)))
+ ;; the message from the menu will be visible,
+ ;; couldn't make it go away...
+ (calculator))
+ :active (not calculator-electric-mode)]
+ ["Normal mode"
+ (progn (setq calculator-restart-other-mode t)
+ (calculator-quit))
+ :active calculator-electric-mode]
+ "---"
+ ("Functions"
+ ,(funcall op "Repeat-right" ">")
+ ,(funcall op "Repeat-left" "<")
+ "------General------"
+ ,(funcall op "Reciprocal" ";")
+ ,(funcall op "Log" "L")
+ ,(funcall op "Square-root" "Q")
+ ,(funcall op "Factorial" "!")
+ "------Trigonometric------"
+ ,(funcall op "Sinus" "S")
+ ,(funcall op "Cosine" "C")
+ ,(funcall op "Tangent" "T")
+ ,(funcall op "Inv-Sinus" "IS")
+ ,(funcall op "Inv-Cosine" "IC")
+ ,(funcall op "Inv-Tangent" "IT")
+ "------Bitwise------"
+ ,(funcall op "Or" "|")
+ ,(funcall op "Xor" "#")
+ ,(funcall op "And" "&")
+ ,(funcall op "Not" "~"))
+ ("Saved List"
+ ["Eval+Save" calculator-save-on-list]
+ ["Prev number" calculator-saved-up]
+ ["Next number" calculator-saved-down]
+ ["Delete current" calculator-clear
+ :active (and calculator-display-fragile
+ calculator-saved-list
+ (= (car calculator-stack)
+ (nth calculator-saved-ptr
+ calculator-saved-list)))]
+ ["Delete all" calculator-clear-saved]
+ "---"
+ ,(funcall op "List-total" "l")
+ ,(funcall op "List-average" "v"))
+ ("Registers"
+ ["Get register" calculator-get-register]
+ ["Set register" calculator-set-register])
+ ("Modes"
+ ["Radians"
+ (progn
+ (and (or calculator-input-radix calculator-output-radix)
+ (calculator-radix-mode "D"))
+ (and calculator-deg (calculator-dec/deg-mode)))
+ :keys "D"
+ :style radio
+ :selected (not (or calculator-input-radix
+ calculator-output-radix
+ calculator-deg))]
+ ["Degrees"
+ (progn
+ (and (or calculator-input-radix calculator-output-radix)
+ (calculator-radix-mode "D"))
+ (or calculator-deg (calculator-dec/deg-mode)))
+ :keys "D"
+ :style radio
+ :selected (and calculator-deg
+ (not (or calculator-input-radix
+ calculator-output-radix)))]
"---"
- ,@(mapcar (lambda (x) (nth 2 x)) radix-selectors)))
- ("Decimal Display"
- ,@(mapcar (lambda (d)
- (vector (cadr d)
- ;; Note: inserts actual object here
- `(calculator-rotate-displayer ',d)))
- calculator-displayers)
+ ,@(mapcar 'car radix-selectors)
+ ("Separate I/O"
+ ,@(mapcar (lambda (x) (nth 1 x)) radix-selectors)
+ "---"
+ ,@(mapcar (lambda (x) (nth 2 x)) radix-selectors)))
+ ("Decimal Display"
+ ,@(mapcar (lambda (d)
+ (vector (cadr d)
+ ;; Note: inserts actual object here
+ `(calculator-rotate-displayer ',d)))
+ calculator-displayers)
+ "---"
+ ["Change Prev Display" calculator-displayer-prev]
+ ["Change Next Display" calculator-displayer-next])
"---"
- ["Change Prev Display" calculator-displayer-prev]
- ["Change Next Display" calculator-displayer-next])
- "---"
- ["Copy+Quit" calculator-save-and-quit]
- ["Quit" calculator-quit]))))
- (setq calculator-mode-map map)))
+ ["Copy+Quit" calculator-save-and-quit]
+ ["Quit" calculator-quit]))))
+ map)
+ "The calculator key map.")
;;;---------------------------------------------------------------------
;;; Startup and mode stuff
-(defun calculator-mode ()
+(define-derived-mode calculator-mode fundamental-mode "Calculator"
;; this help is also used as the major help screen
"A [not so] simple calculator for Emacs.
@@ -671,13 +668,7 @@ Some interesting customization variables are:
See the documentation for these variables, and \"calculator.el\" for
more information.
-\\{calculator-mode-map}"
- (interactive)
- (kill-all-local-variables)
- (setq major-mode 'calculator-mode)
- (setq mode-name "Calculator")
- (use-local-map calculator-mode-map)
- (run-mode-hooks 'calculator-mode-hook))
+\\{calculator-mode-map}")
(eval-when-compile (require 'electric) (require 'ehelp))
@@ -1832,5 +1823,4 @@ To use this, apply a binary operator (evaluate it), then call this."
(provide 'calculator)
-;; arch-tag: a1b9766c-af8a-4a74-b466-65ad8eeb0c73
;;; calculator.el ends here
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 4c318dc3ab4..d1483c5445d 100644
--- a/lisp/calendar/appt.el
+++ b/lisp/calendar/appt.el
@@ -1,11 +1,12 @@
;;; appt.el --- appointment notification functions
-;; Copyright (C) 1989, 1990, 1994, 1998, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1989-1990, 1994, 1998, 2001-2011
+;; Free Software Foundation, Inc.
;; 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,62 +83,42 @@
: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."
+ "Default time in minutes before an appointment that the warning begins."
:type 'integer
:group 'appt)
-(defcustom appt-audible t
- "Non-nil means beep to indicate appointment."
- :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
+(defcustom appt-warning-time-regexp "warntime \\([0-9]+\\)"
+ "Regexp matching a string giving the warning time for an appointment.
+The first subexpression matches the time in minutes (an integer).
+This overrides the default `appt-message-warning-time'.
+You may want to put this inside a diary comment (see `diary-comment-start').
+For example, to be warned 30 minutes in advance of an appointment:
+ 2011/06/01 12:00 Do something ## warntime 30
+"
+ :version "24.1"
+ :type 'regexp
: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'."
+(defcustom appt-audible t
+ "Non-nil means beep to indicate appointment."
: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.
@@ -198,11 +179,10 @@ Each element of the generated list has the form
\(MINUTES STRING [FLAG] [WARNTIME])
where MINUTES is the time in minutes of the appointment after midnight,
and STRING is the description of the appointment.
-FLAG and WARNTIME can only be present if the element was made
-with `appt-add'. A non-nil FLAG indicates that the element was made
-with `appt-add', so calling `appt-make-list' again should preserve it.
-If WARNTIME is non-nil, it is an integer to use in place
-of `appt-message-warning-time'.")
+FLAG and WARNTIME are not always present. A non-nil FLAG
+indicates that the element was made with `appt-add', so calling
+`appt-make-list' again should preserve it. If WARNTIME is non-nil,
+it is an integer to use in place of `appt-message-warning-time'.")
(defconst appt-max-time (1- (* 24 60))
"11:59pm in minutes - number of minutes in a day minus 1.")
@@ -235,28 +215,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 +296,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 +305,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 +457,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 +468,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 +487,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 +496,101 @@ 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)
+ time-string literal)
+ ;; 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))
+ ;; Including any comments.
+ literal (or (nth 2 (nth 3 (car entry-list)))
+ time-string))
+ (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)))
+ (warntime
+ (if (string-match appt-warning-time-regexp literal)
+ (string-to-number (match-string 1 literal))))
+ ;; 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 (append
+ (list appt-time appt-time-string)
+ (if warntime (list nil warntime)))))
+ ;; 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.
+ ;; (This allows for multiple appts per entry.)
+ time-string
+ (if end (substring time-string end) ""))
+ ;; Similarly, discard the start of literal.
+ (and (> (length time-string) 0)
+ (string-match appt-time-regexp literal)
+ (setq end (string-match
+ (concat "\n[ \t]*" appt-time-regexp)
+ literal (match-end 0)))
+ (setq literal (substring literal 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 +630,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 +645,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 66c9cd9e9c3..ae5dc02862d 100644
--- a/lisp/calendar/cal-bahai.el
+++ b/lisp/calendar/cal-bahai.el
@@ -1,11 +1,11 @@
;;; cal-bahai.el --- calendar functions for the Bahá'í calendar.
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;; 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.
@@ -360,5 +360,4 @@ Prefix argument ARG will make the entry nonmarking."
;; coding: utf-8
;; End:
-;; arch-tag: c1cb1d67-862a-4264-a01c-41cb4df01f14
;;; cal-bahai.el ends here
diff --git a/lisp/calendar/cal-china.el b/lisp/calendar/cal-china.el
index cc672913484..d17c2c71f8a 100644
--- a/lisp/calendar/cal-china.el
+++ b/lisp/calendar/cal-china.el
@@ -1,12 +1,12 @@
;;; cal-china.el --- calendar functions for the Chinese calendar
-;; Copyright (C) 1995, 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: Chinese calendar, calendar, holidays, diary
+;; Package: calendar
;; This file is part of GNU Emacs.
@@ -575,8 +575,7 @@ Defaults to today's date if DATE is not given."
;; Remainder of (1+(floor month))/12, with
;; 12 instead of 0.
(1+ (mod (floor month) 12))
- 1)))
- (m-cycle (% (+ (* year 5) (floor month)) 60)))
+ 1))))
(format "Cycle %s, year %s (%s), %smonth %s%s, day %s (%s)"
cycle
year (calendar-chinese-sexagesimal-name year)
@@ -685,5 +684,4 @@ Echo Chinese date unless NOECHO is non-nil."
(provide 'cal-china)
-;; arch-tag: 7e5b7e0d-676c-47e3-8696-93e7ea0ab644
;;; cal-china.el ends here
diff --git a/lisp/calendar/cal-coptic.el b/lisp/calendar/cal-coptic.el
index 13812ffaf40..4db2743777f 100644
--- a/lisp/calendar/cal-coptic.el
+++ b/lisp/calendar/cal-coptic.el
@@ -1,12 +1,12 @@
;;; cal-coptic.el --- calendar functions for the Coptic/Ethiopic calendars
-;; Copyright (C) 1995, 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
;; 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.
@@ -268,5 +268,4 @@ Echo Ethiopic date unless NOECHO is t."
(provide 'cal-coptic)
-;; arch-tag: 72d49161-25df-4072-9312-b182cdca7627
;;; cal-coptic.el ends here
diff --git a/lisp/calendar/cal-dst.el b/lisp/calendar/cal-dst.el
index 2c86e4c3379..ffb367a70f6 100644
--- a/lisp/calendar/cal-dst.el
+++ b/lisp/calendar/cal-dst.el
@@ -1,13 +1,13 @@
;;; cal-dst.el --- calendar functions for daylight saving rules
-;; Copyright (C) 1993, 1994, 1995, 1996, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1996, 2001-2011 Free Software Foundation, Inc.
;; Author: Paul Eggert <eggert@twinsun.com>
;; Edward M. Reingold <reingold@cs.uiuc.edu>
;; 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.
@@ -445,16 +445,12 @@ Fractional part of DATE is local standard time of day."
(or (<= dst-starts date) (< date dst-ends))))))
;; used by calc, lunar, solar.
-(defun dst-adjust-time (date time &optional style)
+(defun dst-adjust-time (date time)
"Adjust, to account for dst on DATE, decimal fraction standard TIME.
Returns a list (date adj-time zone) where `date' and `adj-time' are the values
adjusted for `zone'; here `date' is a list (month day year), `adj-time' is a
decimal fraction time, and `zone' is a string.
-Optional parameter STYLE forces the result time to be standard time when its
-value is 'standard and daylight saving time (if available) when its value is
-'daylight.
-
Conversion to daylight saving time is done according to
`calendar-daylight-savings-starts', `calendar-daylight-savings-ends',
`calendar-daylight-savings-starts-time',
@@ -473,5 +469,4 @@ Conversion to daylight saving time is done according to
(provide 'cal-dst)
-;; arch-tag: a141d204-213c-4ca5-bdc6-f9df3aa92aad
;;; cal-dst.el ends here
diff --git a/lisp/calendar/cal-french.el b/lisp/calendar/cal-french.el
index 952222a8d35..ef1ce8767ab 100644
--- a/lisp/calendar/cal-french.el
+++ b/lisp/calendar/cal-french.el
@@ -1,12 +1,13 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1988-1989, 1992, 1994-1995, 1997, 2001-2011
+;; 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 +41,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 +56,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 +175,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 +209,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 +265,8 @@ Echo French Revolutionary date unless NOECHO is non-nil."
(provide 'cal-french)
-;; arch-tag: 7e8045a3-8609-46b5-9cde-cf40ce541cf9
+;; Local Variables:
+;; coding: utf-8
+;; End:
+
;;; cal-french.el ends here
diff --git a/lisp/calendar/cal-hebrew.el b/lisp/calendar/cal-hebrew.el
index c780ee5efcd..52bf442915f 100644
--- a/lisp/calendar/cal-hebrew.el
+++ b/lisp/calendar/cal-hebrew.el
@@ -1,13 +1,13 @@
;;; cal-hebrew.el --- calendar functions for the Hebrew calendar
-;; Copyright (C) 1995, 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Nachum Dershowitz <nachum@cs.uiuc.edu>
;; Edward M. Reingold <reingold@cs.uiuc.edu>
;; 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 +375,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 +453,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 +527,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 +558,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 +592,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
@@ -765,8 +764,6 @@ from the cursor position."
(message "Computing Yahrzeits...")
(let* ((h-date (calendar-hebrew-from-absolute
(calendar-absolute-from-gregorian death-date)))
- (h-month (calendar-extract-month h-date))
- (h-day (calendar-extract-day h-date))
(h-year (calendar-extract-year h-date))
(i (1- start-year)))
(calendar-in-read-only-buffer calendar-hebrew-yahrzeit-buffer
@@ -793,6 +790,20 @@ from the cursor position."
(define-obsolete-function-alias 'list-yahrzeit-dates
'calendar-hebrew-list-yahrzeits "23.1")
+(defun calendar-hebrew-birthday (date year)
+ "Absolute date of the anniversary of Hebrew birth DATE, in Hebrew YEAR."
+ (let ((b-day (calendar-extract-day date))
+ (b-month (calendar-extract-month date))
+ (b-year (calendar-extract-year date)))
+ ;; If it's Adar in a normal Hebrew year or Adar II in a Hebrew leap year...
+ (if (= b-month (calendar-hebrew-last-month-of-year b-year))
+ ;; ...then use the same day in last month of Hebrew year.
+ (calendar-hebrew-to-absolute
+ (list (calendar-hebrew-last-month-of-year year) b-day year))
+ ;; Else use the normal anniversary of the birth date,
+ ;; or the corresponding day in years without that date.
+ (+ (calendar-hebrew-to-absolute (list b-month 1 year)) b-day -1))))
+
(defvar date)
;; To be called from diary-list-sexp-entries, where DATE is bound.
@@ -801,6 +812,37 @@ from the cursor position."
"Hebrew calendar equivalent of date diary entry."
(format "Hebrew date (until sunset): %s" (calendar-hebrew-date-string date)))
+(defvar entry)
+(declare-function diary-ordinal-suffix "diary-lib" (n))
+
+;;;###diary-autoload
+(defun diary-hebrew-birthday (month day year &optional after-sunset)
+ "Hebrew birthday diary entry.
+Entry applies if date is birthdate (MONTH DAY YEAR), or the day before.
+The order of the input parameters changes according to
+`calendar-date-style' (e.g. to DAY MONTH YEAR in the European style).
+
+Assumes the associated diary entry is the name of the person.
+
+Although the date of birth is specified by the *civil* calendar,
+this function determines the proper Hebrew calendar birthday.
+If the optional argument AFTER-SUNSET is non-nil, this means the
+birth occurred after local sunset on the given civil date.
+In this case, the following civil date corresponds to the Hebrew birthday."
+ (let* ((h-date (calendar-hebrew-from-absolute
+ (+ (calendar-absolute-from-gregorian
+ (diary-make-date month day year))
+ (if after-sunset 1 0))))
+ (h-year (calendar-extract-year h-date)) ; birth-day
+ (d (calendar-absolute-from-gregorian date)) ; today
+ (h-yr (calendar-extract-year (calendar-hebrew-from-absolute d)))
+ (age (- h-yr h-year)) ; current H year - birth H-year
+ (b-date (calendar-hebrew-birthday h-date h-yr)))
+ (and (> age 0) (memq b-date (list d (1+ d)))
+ (format "%s's %d%s Hebrew birthday%s" entry age
+ (diary-ordinal-suffix age)
+ (if (= b-date d) "" " (evening)")))))
+
;;;###diary-autoload
(defun diary-hebrew-omer (&optional mark)
"Omer count diary entry.
@@ -830,30 +872,32 @@ use when highlighting the day in the calendar."
;;;###diary-autoload
(define-obsolete-function-alias 'diary-omer 'diary-hebrew-omer "23.1")
-(defvar entry)
-
(autoload 'diary-make-date "diary-lib")
(declare-function diary-ordinal-suffix "diary-lib" (n))
;;;###diary-autoload
-(defun diary-hebrew-yahrzeit (death-month death-day death-year &optional mark)
+(defun diary-hebrew-yahrzeit (death-month death-day death-year
+ &optional mark after-sunset)
"Yahrzeit diary entry--entry applies if date is Yahrzeit or the day before.
Parameters are DEATH-MONTH, DEATH-DAY, DEATH-YEAR; the diary
entry is assumed to be the name of the person. Although the date
of death is specified by the civil calendar, the proper Hebrew
calendar Yahrzeit is determined.
+If the death occurred after local sunset on the given civil date,
+the following civil date corresponds to the Hebrew date of
+death--set the optional parameter AFTER-SUNSET non-nil in this case.
+
The order of the input parameters changes according to `calendar-date-style'
\(e.g. to DEATH-DAY, DEATH-MONTH, DEATH-YEAR in the European style).
An optional parameter MARK specifies a face or single-character string to
use when highlighting the day in the calendar."
(let* ((h-date (calendar-hebrew-from-absolute
- (calendar-absolute-from-gregorian
- (diary-make-date death-month death-day death-year))))
- (h-month (calendar-extract-month h-date))
- (h-day (calendar-extract-day h-date))
+ (+ (calendar-absolute-from-gregorian
+ (diary-make-date death-month death-day death-year))
+ (if after-sunset 1 0))))
(h-year (calendar-extract-year h-date))
(d (calendar-absolute-from-gregorian date))
(yr (calendar-extract-year (calendar-hebrew-from-absolute d)))
@@ -906,16 +950,17 @@ use when highlighting the day in the calendar."
(format "%s (second day)" this-month)
this-month))))
(if (= (% d 7) 6) ; Saturday--check for Shabbat Mevarchim
- (cons mark
- (cond ((and (> h-day 22) (/= h-month 6) (= 29 last-day))
+ (cond ((and (> h-day 22) (/= h-month 6) (= 29 last-day))
+ (cons mark
(format "Mevarchim Rosh Hodesh %s (%s)"
(aref h-month-names
(if (= h-month
(calendar-hebrew-last-month-of-year
h-year))
0 h-month))
- (aref calendar-day-name-array (- 29 h-day))))
- ((and (< h-day 30) (> h-day 22) (= 30 last-day))
+ (aref calendar-day-name-array (- 29 h-day)))))
+ ((and (< h-day 30) (> h-day 22) (= 30 last-day))
+ (cons mark
(format "Mevarchim Rosh Hodesh %s (%s-%s)"
(aref h-month-names h-month)
(if (= h-day 29)
@@ -1161,5 +1206,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 c8b1c229827..bcc19ccda0b 100644
--- a/lisp/calendar/cal-html.el
+++ b/lisp/calendar/cal-html.el
@@ -1,12 +1,12 @@
;;; cal-html.el --- functions for printing HTML calendars
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Anna M. Bigatti <bigatti@dima.unige.it>
;; Keywords: calendar
;; Human-Keywords: calendar, diary, HTML
;; Created: 23 Aug 2002
+;; Package: calendar
;; This file is part of GNU Emacs.
@@ -247,7 +247,7 @@ Contains links to previous and next month and year, and current minical."
(insert cal-html-e-tablerow-string)
;; Initial empty slots.
(insert cal-html-b-tablerow-string)
- (dotimes (i blank-days)
+ (dotimes (_i blank-days)
(insert
cal-html-b-tabledata-string
cal-html-e-tabledata-string))
@@ -442,5 +442,4 @@ specified by EVENT. Note that any existing output files are overwritten."
(provide 'cal-html)
-;; arch-tag: 4e73377d-d2c1-46ea-a103-02c111da5f57
;;; cal-html.el ends here
diff --git a/lisp/calendar/cal-islam.el b/lisp/calendar/cal-islam.el
index 179c54f4a80..e69a2389e6c 100644
--- a/lisp/calendar/cal-islam.el
+++ b/lisp/calendar/cal-islam.el
@@ -1,12 +1,12 @@
;;; cal-islam.el --- calendar functions for the Islamic calendar
-;; Copyright (C) 1995, 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: Islamic calendar, calendar, diary
+;; Package: calendar
;; This file is part of GNU Emacs.
@@ -344,5 +344,4 @@ Prefix argument ARG makes the entry nonmarking."
(provide 'cal-islam)
-;; arch-tag: a951b6c1-6f47-48d5-bac3-1b505cd719f7
;;; cal-islam.el ends here
diff --git a/lisp/calendar/cal-iso.el b/lisp/calendar/cal-iso.el
index c000a6e4d7a..e745b6264e0 100644
--- a/lisp/calendar/cal-iso.el
+++ b/lisp/calendar/cal-iso.el
@@ -1,12 +1,12 @@
;;; cal-iso.el --- calendar functions for the ISO calendar
-;; Copyright (C) 1995, 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: ISO calendar, calendar, diary
+;; Package: calendar
;; This file is part of GNU Emacs.
@@ -154,5 +154,4 @@ Interactively, goes to the first day of the specified week."
(provide 'cal-iso)
-;; arch-tag: 3c0154cc-d30f-4981-9f60-42bdf7a468f6
;;; cal-iso.el ends here
diff --git a/lisp/calendar/cal-julian.el b/lisp/calendar/cal-julian.el
index 34cf8b81794..e0f85b36d44 100644
--- a/lisp/calendar/cal-julian.el
+++ b/lisp/calendar/cal-julian.el
@@ -1,12 +1,12 @@
;;; cal-julian.el --- calendar functions for the Julian calendar
-;; Copyright (C) 1995, 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
;; 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.
@@ -217,5 +217,4 @@ Echo astronomical (Julian) day number unless NOECHO is non-nil."
(provide 'cal-julian)
-;; arch-tag: 0520acdd-1c60-4188-9aa8-9b8c24d856ae
;;; cal-julian.el ends here
diff --git a/lisp/calendar/cal-mayan.el b/lisp/calendar/cal-mayan.el
index e54fc2d5da5..283c68cb32d 100644
--- a/lisp/calendar/cal-mayan.el
+++ b/lisp/calendar/cal-mayan.el
@@ -1,13 +1,14 @@
;;; cal-mayan.el --- calendar functions for the Mayan calendars
-;; Copyright (C) 1992, 1993, 1995, 1997, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992-1993, 1995, 1997, 2001-2011
+;; Free Software Foundation, Inc.
;; Author: Stewart M. Clamen <clamen@cs.cmu.edu>
;; Edward M. Reingold <reingold@cs.uiuc.edu>
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: Mayan calendar, Maya, calendar, diary
+;; Package: calendar
;; This file is part of GNU Emacs.
@@ -389,5 +390,4 @@ Echo Mayan date unless NOECHO is non-nil."
(provide 'cal-mayan)
-;; arch-tag: 54f35144-cd0f-4873-935a-a60129de07df
;;; cal-mayan.el ends here
diff --git a/lisp/calendar/cal-menu.el b/lisp/calendar/cal-menu.el
index a6a60c38078..3ebb7edab3f 100644
--- a/lisp/calendar/cal-menu.el
+++ b/lisp/calendar/cal-menu.el
@@ -1,13 +1,13 @@
;;; cal-menu.el --- calendar functions for menu bar and popup menu support
-;; Copyright (C) 1994, 1995, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1995, 2001-2011 Free Software Foundation, Inc.
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
;; Lara Rios <lrios@coewl.cen.uiuc.edu>
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: calendar, popup menus, menu bar
+;; Package: calendar
;; This file is part of GNU Emacs.
@@ -280,5 +280,4 @@ is non-nil."
(provide 'cal-menu)
-;; arch-tag: aa81cf73-ce89-48a4-97ec-9ef861e87fe9
;;; cal-menu.el ends here
diff --git a/lisp/calendar/cal-move.el b/lisp/calendar/cal-move.el
index fad7a2496d5..72b34beda6b 100644
--- a/lisp/calendar/cal-move.el
+++ b/lisp/calendar/cal-move.el
@@ -1,12 +1,12 @@
;;; cal-move.el --- calendar functions for movement in the calendar
-;; Copyright (C) 1995, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1995, 2001-2011 Free Software Foundation, Inc.
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: calendar
+;; Package: calendar
;; This file is part of GNU Emacs.
@@ -204,6 +204,18 @@ EVENT is an event like `last-nonmenu-event'."
(define-obsolete-function-alias 'scroll-calendar-left-three-months
'calendar-scroll-left-three-months "23.1")
+;; cf scroll-bar-toolkit-scroll
+;;;###cal-autoload
+(defun calendar-scroll-toolkit-scroll (event)
+ "Function to scroll the calendar after a toolkit scroll-bar click."
+ (interactive "e")
+ (let ((part (nth 4 (event-end event))))
+ ;; Not bothering with drag events (handle, end-scroll).
+ (cond ((memq part '(above-handle up top))
+ (calendar-scroll-right nil event))
+ ((memq part '(below-handle down bottom))
+ (calendar-scroll-left nil event)))))
+
;;;###cal-autoload
(defun calendar-scroll-right-three-months (arg &optional event)
"Scroll the displayed calendar window right by 3*ARG months.
@@ -405,5 +417,4 @@ Negative DAY counts backward from end of year."
(provide 'cal-move)
-;; arch-tag: d0883c46-7e16-4914-8ff8-8f67e699b781
;;; cal-move.el ends here
diff --git a/lisp/calendar/cal-persia.el b/lisp/calendar/cal-persia.el
index da0c4ba4f31..a8b3f180e0f 100644
--- a/lisp/calendar/cal-persia.el
+++ b/lisp/calendar/cal-persia.el
@@ -1,12 +1,12 @@
;;; cal-persia.el --- calendar functions for the Persian calendar
-;; Copyright (C) 1996, 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: Persian calendar, calendar, diary
+;; Package: calendar
;; This file is part of GNU Emacs.
@@ -217,5 +217,4 @@ Echo Persian date unless NOECHO is non-nil."
(provide 'cal-persia)
-;; arch-tag: 2832383c-e4b4-4dc2-8ee9-cfbdd53e5e2d
;;; cal-persia.el ends here
diff --git a/lisp/calendar/cal-tex.el b/lisp/calendar/cal-tex.el
index 515bf08e18e..89e265aeb7e 100644
--- a/lisp/calendar/cal-tex.el
+++ b/lisp/calendar/cal-tex.el
@@ -1,13 +1,13 @@
;;; cal-tex.el --- calendar functions for printing calendars with LaTeX
-;; Copyright (C) 1995, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 2001-2011 Free Software Foundation, Inc.
;; Author: Steve Fisk <fisk@bowdoin.edu>
;; Edward M. Reingold <reingold@cs.uiuc.edu>
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: Calendar, LaTeX
+;; Package: calendar
;; This file is part of GNU Emacs.
@@ -253,7 +253,7 @@ This definition is the heart of the calendar!")
3)))
holidays in-range a)
(calendar-increment-month displayed-month displayed-year 1)
- (dotimes (idummy number-of-intervals)
+ (dotimes (_idummy number-of-intervals)
(setq holidays (append holidays (calendar-holiday-list)))
(calendar-increment-month displayed-month displayed-year 3))
(dolist (hol holidays)
@@ -525,7 +525,7 @@ indicates a buffer position to use instead of point."
(cal-tex-insert-day-names)
(cal-tex-nl ".2cm")
(cal-tex-insert-blank-days month year cal-tex-day-prefix)
- (dotimes (idummy n)
+ (dotimes (_idummy n)
(cal-tex-insert-days month year diary-list holidays cal-tex-day-prefix)
(when (= (calendar-week-end-day)
(calendar-day-of-week
@@ -642,7 +642,7 @@ in the calendar starting in MONTH YEAR."
;; start of the last week in the month.
(catch 'found
(let ((last-day (calendar-last-day-of-month month year))
- day dow)
+ dow)
(dotimes (i 7)
(if (memq (setq dow (calendar-day-of-week
(list month (- last-day i) year)))
@@ -717,7 +717,7 @@ entries are not shown). The calendar shows the hours 8-12am, 1-5pm."
(cal-tex-e-center)
(cal-tex-hspace "-.2in")
(cal-tex-b-parbox "l" "7in")
- (dotimes (jdummy 7)
+ (dotimes (_jdummy 7)
(cal-tex-week-hours date holidays "3.1")
(setq date (cal-tex-incr-date date)))
(cal-tex-e-parbox)
@@ -749,7 +749,6 @@ Optional EVENT indicates a buffer position to use instead of point."
(calendar-cursor-to-date t event)))))
(month (calendar-extract-month date))
(year (calendar-extract-year date))
- (d date)
(d1 (calendar-absolute-from-gregorian date))
(d2 (+ (* 7 n) d1))
(holidays (if cal-tex-holidays
@@ -773,7 +772,7 @@ Optional EVENT indicates a buffer position to use instead of point."
(cal-tex-e-center)
(cal-tex-hspace "-.2in")
(cal-tex-b-parbox "l" "\\textwidth")
- (dotimes (jdummy 3)
+ (dotimes (_jdummy 3)
(cal-tex-week-hours date holidays "5")
(setq date (cal-tex-incr-date date)))
(cal-tex-e-parbox)
@@ -801,7 +800,7 @@ Optional EVENT indicates a buffer position to use instead of point."
(insert "}")
(cal-tex-nl)
(cal-tex-b-parbox "l" "\\textwidth")
- (dotimes (jdummy 4)
+ (dotimes (_jdummy 4)
(cal-tex-week-hours date holidays "5")
(setq date (cal-tex-incr-date date)))
(cal-tex-e-parbox)
@@ -863,7 +862,7 @@ position to use instead of point."
(cal-tex-nl ".5cm")
(cal-tex-e-center)
(cal-tex-b-parbox "l" "\\textwidth")
- (dotimes (j 7)
+ (dotimes (_j 7)
(cal-tex-b-parbox "t" "\\textwidth")
(cal-tex-b-parbox "t" "\\textwidth")
(cal-tex-rule "0pt" "\\textwidth" ".2mm")
@@ -1112,7 +1111,7 @@ Optional EVENT indicates a buffer position to use instead of point."
(cal-tex-month-name (calendar-extract-month d))
(calendar-extract-year d))))))
(insert "%\n")
- (dotimes (jdummy 7)
+ (dotimes (_jdummy 7)
(if (zerop (mod i 2))
(insert "\\rightday")
(insert "\\leftday"))
@@ -1216,7 +1215,7 @@ Optional EVENT indicates a buffer position to use instead of point."
(cal-tex-month-name (calendar-extract-month d))
(calendar-extract-year d))))))
(insert "%\n")
- (dotimes (jdummy 3)
+ (dotimes (_jdummy 3)
(insert "\\leftday")
(cal-tex-arg (cal-tex-LaTeXify-string (calendar-day-name date)))
(cal-tex-arg (number-to-string (calendar-extract-day date)))
@@ -1247,7 +1246,7 @@ Optional EVENT indicates a buffer position to use instead of point."
(cal-tex-month-name (calendar-extract-month d))
(calendar-extract-year d))))))
(insert "%\n")
- (dotimes (jdummy 2)
+ (dotimes (_jdummy 2)
(insert "\\rightday")
(cal-tex-arg (cal-tex-LaTeXify-string (calendar-day-name date)))
(cal-tex-arg (number-to-string (calendar-extract-day date)))
@@ -1256,7 +1255,7 @@ Optional EVENT indicates a buffer position to use instead of point."
(cal-tex-arg (eval cal-tex-daily-string))
(insert "%\n")
(setq date (cal-tex-incr-date date)))
- (dotimes (jdummy 2)
+ (dotimes (_jdummy 2)
(insert "\\weekend")
(cal-tex-arg (cal-tex-LaTeXify-string (calendar-day-name date)))
(cal-tex-arg (number-to-string (calendar-extract-day date)))
@@ -1362,7 +1361,7 @@ Optional EVENT indicates a buffer position to use instead of point."
(cal-tex-newpage)
(setq date (cal-tex-incr-date date)))
(insert "%\n")
- (dotimes (jdummy 2)
+ (dotimes (_jdummy 2)
(insert "\\lefthead")
(cal-tex-arg (calendar-date-string date))
(insert "\\weekend")
@@ -1523,7 +1522,7 @@ Optional string COLSEP gives the column separation (default \"1mm\")."
(if (= i 6)
"\\\\[0.7mm]\n"
" & "))))
- (dotimes (idummy blank-days)
+ (dotimes (_idummy blank-days)
(setq str (concat str " & ")))
(dotimes (i last)
(setq str (concat str (number-to-string (1+ i)))
@@ -1587,6 +1586,16 @@ FINAL-SEPARATOR is non-nil."
Insert the trailer to LaTeX document, pop to LaTeX buffer, add
informative header, and run HOOK."
(cal-tex-e-document)
+ (or (and cal-tex-preamble-extra
+ (string-match "inputenc" cal-tex-preamble-extra))
+ (not (re-search-backward "[^[:ascii:]]" nil 'move))
+ (progn
+ (goto-char (point-min))
+ (when (search-forward "documentclass" nil t)
+ (forward-line 1)
+ ;; Eg for some Bahai holidays.
+ ;; FIXME latin1 might not always be right.
+ (insert "\\usepackage[latin1]{inputenc}\n"))))
(latex-mode)
(pop-to-buffer cal-tex-buffer)
(goto-char (point-min))
@@ -1831,5 +1840,4 @@ Add trailing COMMENT if present."
(provide 'cal-tex)
-;; arch-tag: ca8168a4-5a00-4508-a565-17e3bccce6d0
;;; cal-tex.el ends here
diff --git a/lisp/calendar/cal-x.el b/lisp/calendar/cal-x.el
index 46cd64c042a..e95d284a36b 100644
--- a/lisp/calendar/cal-x.el
+++ b/lisp/calendar/cal-x.el
@@ -1,13 +1,13 @@
;;; cal-x.el --- calendar windows in dedicated frames
-;; Copyright (C) 1994, 1995, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1995, 2001-2011 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.sunysb.edu>
;; Edward M. Reingold <reingold@cs.uiuc.edu>
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: calendar, dedicated frames
+;; Package: calendar
;; This file is part of GNU Emacs.
@@ -188,5 +188,4 @@ See `calendar-frame-setup' for more information."
(provide 'cal-x)
-;; arch-tag: c6dbddca-ae84-442d-87fc-244b76e38e17
;;; cal-x.el ends here
diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el
index 0a5373b8a57..e81eb554458 100644
--- a/lisp/calendar/calendar.el
+++ b/lisp/calendar/calendar.el
@@ -1,8 +1,6 @@
;;; calendar.el --- calendar functions
-;; Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1997,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1988-1995, 1997, 2000-2011 Free Software Foundation, Inc.
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
;; Maintainer: Glenn Morris <rgm@gnu.org>
@@ -1365,7 +1363,6 @@ Optional integers MON and YR are used instead of today's date."
(year (calendar-extract-year today))
(today-visible (or (not mon)
(<= (abs (calendar-interval mon yr month year)) 1)))
- (day-in-week (calendar-day-of-week today))
(in-calendar-window (eq (window-buffer (selected-window))
(get-buffer calendar-buffer))))
(calendar-generate (or mon month) (or yr year))
@@ -1650,14 +1647,17 @@ line."
(define-key map [down-mouse-2]
(easy-menu-binding cal-menu-global-mouse-menu))
- ;; Left-click moves us forward in time, right-click backwards.
;; cf scroll-bar.el.
- (define-key map [vertical-scroll-bar mouse-1] 'calendar-scroll-left)
- (define-key map [vertical-scroll-bar drag-mouse-1] 'calendar-scroll-left)
- ;; down-mouse-2 stays as scroll-bar-drag.
- (define-key map [vertical-scroll-bar mouse-3] 'calendar-scroll-right)
- (define-key map [vertical-scroll-bar drag-mouse-3] 'calendar-scroll-right)
-
+ (if (and (boundp 'x-toolkit-scroll-bars) x-toolkit-scroll-bars)
+ (define-key map [vertical-scroll-bar mouse-1]
+ 'calendar-scroll-toolkit-scroll)
+ ;; Left-click moves us forward in time, right-click backwards.
+ (define-key map [vertical-scroll-bar mouse-1] 'calendar-scroll-left)
+ (define-key map [vertical-scroll-bar drag-mouse-1] 'calendar-scroll-left)
+ ;; down-mouse-2 stays as scroll-bar-drag.
+ (define-key map [vertical-scroll-bar mouse-3] 'calendar-scroll-right)
+ (define-key map [vertical-scroll-bar drag-mouse-3]
+ 'calendar-scroll-right))
map)
"Keymap for `calendar-mode'.")
diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el
index 42080cd7eda..62da7579d50 100644
--- a/lisp/calendar/diary-lib.el
+++ b/lisp/calendar/diary-lib.el
@@ -1,7 +1,7 @@
;;; diary-lib.el --- diary functions
-;; Copyright (C) 1989, 1990, 1992, 1993, 1994, 1995, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1989-1990, 1992-1995, 2001-2011
+;; Free Software Foundation, Inc.
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
;; Maintainer: Glenn Morris <rgm@gnu.org>
@@ -142,6 +142,26 @@ See the documentation for the function `diary-list-sexp-entries'."
:type 'string
:group 'diary)
+(defcustom diary-comment-start nil
+ "String marking the start of a comment in the diary, or nil.
+Nil means there are no comments. The diary does not display
+parts of entries that are inside comments. You can use comments
+for whatever you like, e.g. for meta-data that packages such as
+`appt.el' can use. Comments may not span mutliple lines, and there
+can be only one comment on any line.
+See also `diary-comment-end'."
+ :version "24.1"
+ :type '(choice (const :tag "No comment" nil) string)
+ :group 'diary)
+
+(defcustom diary-comment-end ""
+ "String marking the end of a comment in the diary.
+The empty string means comments finish at the end of a line.
+See also `diary-comment-start'."
+ :version "24.1"
+ :type 'string
+ :group 'diary)
+
(defcustom diary-hook nil
"List of functions called after the display of the diary.
Used for example by the appointment package - see `appt-activate'."
@@ -192,7 +212,15 @@ you will probably also want to add `diary-mark-included-diary-files' to
in your `.emacs' file to cause the fancy diary buffer to be displayed with
diary entries from various included files, each day's entries sorted into
lexicographic order. Note how the sort function is placed last,
-so that it can sort the entries included from other files."
+so that it can sort the entries included from other files.
+
+This hook runs after `diary-nongregorian-listing-hook'. These two hooks
+differ only if you are using included diary files. In that case,
+`diary-nongregorian-listing-hook' runs for each file, whereas
+`diary-list-entries-hook' only runs once, for the main diary file.
+So for example, to sort the complete list of diary entries you would
+use the list-entries hook, whereas to process e.g. Islamic entries in
+the main file and all included files, you would use the nongregorian hook."
:type 'hook
:options '(diary-include-other-diary-files diary-sort-entries)
:group 'diary)
@@ -204,7 +232,12 @@ so that it can sort the entries included from other files."
"List of functions called after marking diary entries in the calendar.
You might wish to add `diary-mark-included-diary-files', in which case
you will probably also want to add `diary-include-other-diary-files' to
-`diary-list-entries-hook'."
+`diary-list-entries-hook'.
+
+This hook runs after `diary-nongregorian-marking-hook'. These two hooks
+differ only if you are using included diary files. In that case,
+`diary-nongregorian-marking-hook' runs for each file, whereas
+`diary-mark-entries-hook' only runs once, for the main diary file."
:type 'hook
:options '(diary-mark-included-diary-files)
:group 'diary)
@@ -218,7 +251,11 @@ As the files are processed for diary entries, these functions are used
to cull relevant entries. You can use any or all of
`diary-bahai-list-entries', `diary-hebrew-list-entries', and
`diary-islamic-list-entries'. The documentation for these functions
-describes the style of such diary entries."
+describes the style of such diary entries.
+
+You can use this hook for other functions as well, if you want them to
+be run on the main diary file and any included diary files. Otherwise,
+use `diary-list-entries-hook', which runs only for the main diary file."
:type 'hook
:options '(diary-bahai-list-entries
diary-hebrew-list-entries
@@ -234,7 +271,11 @@ As the files are processed for diary entries, these functions are used
to cull relevant entries. You can use any or all of
`diary-bahai-mark-entries', `diary-hebrew-mark-entries' and
`diary-islamic-mark-entries'. The documentation for these functions
-describes the style of such diary entries."
+describes the style of such diary entries.
+
+You can use this hook for other functions as well, if you want them to
+be run on the main diary file and any included diary files. Otherwise,
+use `diary-mark-entries-hook', which runs only for the main diary file."
:type 'hook
:options '(diary-bahai-mark-entries
diary-hebrew-mark-entries
@@ -304,28 +345,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 +548,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)
@@ -592,21 +651,37 @@ If LITERAL is nil, it is taken to be the same as STRING.
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."
+FILENAME being the file containing the diary entry.
+
+Modifies STRING using `diary-modify-entry-list-string-function', if non-nil.
+Also removes the region between `diary-comment-start' and
+`diary-comment-end', if the former is non-nil."
(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))
+ cstart)
+ (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)))
+ (when (and diary-comment-start
+ (string-match (setq cstart (regexp-quote diary-comment-start))
+ string))
+ ;; Preserve the value with the comments.
+ (or literal (setq literal string))
+ ;; Handles multiple comments per entry, so long as each is on
+ ;; a single line, and each line has no more than one comment.
+ (setq string (replace-regexp-in-string
+ (format "%s.*%s" cstart (regexp-quote diary-comment-end))
+ "" 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")
@@ -691,7 +766,7 @@ MONTHS is an array of month names. SYMBOL marks diary entries of the type
in question. ABSFUNC is a function that converts absolute dates to dates
of the appropriate type."
(let ((gdate original-date))
- (dotimes (idummy number)
+ (dotimes (_idummy number)
(diary-list-entries-2
(funcall absfunc (calendar-absolute-from-gregorian gdate))
diary-nonmarking-symbol file-glob-attrs list-only months symbol gdate)
@@ -700,16 +775,14 @@ 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'.")
-;; FIXME non-greg and list hooks run same number of times?
(defun diary-list-entries (date number &optional list-only)
"Create and display a buffer containing the relevant lines in `diary-file'.
-The arguments are DATE and NUMBER; the entries selected are those
-for NUMBER days starting with date DATE. The other entries are hidden
-using overlays. If NUMBER is less than 1, this function does nothing.
+Selects entries for NUMBER days starting with date DATE. Hides any
+other entries using overlays. If NUMBER is less than 1, this function
+does nothing.
Returns a list of all relevant diary entries found.
The list entries have the form ((MONTH DAY YEAR) STRING SPECIFIER) where
@@ -718,30 +791,30 @@ SPECIFIER is the applicability. If the variable `diary-list-include-blanks'
is non-nil, this list includes a dummy diary entry consisting of the empty
string for a date with no diary entries.
-If entries are being produced for multiple dates (i.e., NUMBER > 1),
-then this function normally returns the entries from any given
-diary file in date order. The entries for any given day are in
-the order in which they were found in the file, not necessarily
-in time-of-day order. Note that any functions present on the
+If producing entries for multiple dates (i.e., NUMBER > 1), then
+this function normally returns the entries from any given diary
+file in date order. The entries for any given day are in the
+order in which they were found in the file, not necessarily in
+time-of-day order. Note that any functions present on the
hooks (see below) may add entries, or change the order. For
example, `diary-include-other-diary-files' adds entries from any
include files that it finds to the end of the original list. The
entries from each file will be in date order, but the overall
-list will not be. If you want the entire list to be in time order,
-add `diary-sort-entries' to the end of `diary-list-entries-hook'.
+list will not be. If you want the entire list to be in time
+order, add `diary-sort-entries' to the end of `diary-list-entries-hook'.
-After the initial list is prepared, the following hooks are run:
+After preparing the initial list, hooks run in this order:
- `diary-nongregorian-listing-hook' can cull dates from the diary
- and each included file, for example to process Islamic diary
- entries. Applied to *each* file.
+ `diary-nongregorian-listing-hook' runs for the main diary file,
+ and each included file. For example, this is the appropriate hook
+ to process Islamic entries in all diary files.
- `diary-list-entries-hook' adds or manipulates diary entries from
- external sources. Used, for example, to include diary entries
- from other files or to sort the diary entries. Invoked *once*
- only, before the display hook is run.
+ `diary-list-entries-hook' runs once only, for the main diary file.
+ For example, this is appropriate for sorting all the entries.
+ If not using include files, there is no difference from the previous
+ hook.
- `diary-hook' is run last, after the diary is displayed.
+ `diary-hook' runs last, after the diary is displayed.
This is used e.g. by `appt-check'.
Functions called by these hooks may use the variables ORIGINAL-DATE
@@ -759,66 +832,83 @@ 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))
+ ;; Although it looks like list-entries-hook runs
+ ;; every time, diary-include-other-diary-files
+ ;; binds it to nil (essentially) when it runs
+ ;; in included files.
+ (run-hooks 'diary-nongregorian-listing-hook
+ 'diary-list-entries-hook)
+ ;; We could make this explicit:
+ ;;; (run-hooks 'diary-nongregorian-listing-hook)
+ ;;; (if d-incp
+ ;;; (diary-include-other-diary-files) ; recurse
+ ;;; (run-hooks '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,37 +919,34 @@ 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'.
-This function is suitable for use with `diary-list-entries-hook';
-it enables you to use shared diary files together with your own.
-The files included are specified in the `diary-file' by lines of this form:
- #include \"filename\"
-This is recursive; that is, #include directives in diary files thus included
-are obeyed. You can change the `#include' to some other string by changing
-the variable `diary-include-string'."
+ "Add diary entries from included diary files to `diary-entries-list'.
+For example, this enables you to share common diary files.
+To use, add this function to `diary-list-entries-hook'.
+Specify include files using lines matching `diary-include-string', e.g.
+ #include \"filename\"
+This is recursive; that is, included files may include other files.
+See also `diary-mark-included-diary-files'."
(goto-char (point-min))
(while (re-search-forward
(format "^%s \"\\([^\"]*\\)\"" (regexp-quote 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 +1015,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 +1137,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 +1211,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.
@@ -1296,13 +1378,18 @@ function that converts absolute dates to dates of the appropriate type. "
;;;###cal-autoload
(defun diary-mark-entries (&optional redraw)
"Mark days in the calendar window that have diary entries.
-Each entry in the diary file visible in the calendar window is
-marked. After the entries are marked, the hooks
-`diary-nongregorian-marking-hook' and `diary-mark-entries-hook'
-are run. If the optional argument REDRAW is non-nil (which is
-the case interactively, for example) then any existing diary
-marks are first removed. This is intended to deal with deleted
-diary entries."
+Marks each entry in the diary that is visible in the calendar window.
+
+After marking the entries, runs `diary-nongregorian-marking-hook'
+for the main diary file, and each included file. For example,
+this is the appropriate hook to process Islamic entries in all
+diary files. Next `diary-mark-entries-hook' runs, for the main diary
+file only. If not using include files, there is no difference between
+these two hooks.
+
+If the optional argument REDRAW is non-nil (which is the case
+interactively, for example) then this first removes any existing diary
+marks. This is intended to deal with deleted diary entries."
(interactive "p")
;; To remove any deleted diary entries. Do not redraw when:
;; i) processing #include diary files (else only get the marks from
@@ -1324,6 +1411,9 @@ diary entries."
(with-syntax-table diary-syntax-table
(diary-mark-entries-1 'calendar-mark-date-pattern)
(diary-mark-sexp-entries)
+ ;; Although it looks like mark-entries-hook runs every time,
+ ;; diary-mark-included-diary-files binds it to nil
+ ;; (essentially) when it runs in included files.
(run-hooks 'diary-nongregorian-marking-hook
'diary-mark-entries-hook))
(message "Marking diary entries...done")))))
@@ -1334,7 +1424,7 @@ diary entries."
(defun diary-sexp-entry (sexp entry date)
"Process a SEXP diary ENTRY for DATE."
(let ((result (if calendar-debug-sexp
- (let ((stack-trace-on-error t))
+ (let ((debug-on-error t))
(eval (car (read-from-string sexp))))
(condition-case nil
(eval (car (read-from-string sexp)))
@@ -1409,14 +1499,13 @@ is marked. See the documentation for the function `diary-list-sexp-entries'."
'diary-mark-sexp-entries "23.1")
(defun diary-mark-included-diary-files ()
- "Mark the diary entries from other diary files with those of the diary file.
-This function is suitable for use with `diary-mark-entries-hook'; it enables
-you to use shared diary files together with your own. The files included are
-specified in the `diary-file' by lines of this form:
- #include \"filename\"
-This is recursive; that is, #include directives in diary files thus included
-are obeyed. You can change the `#include' to some other string by changing
-the variable `diary-include-string'."
+ "Mark diary entries from included diary files.
+For example, this enables you to share common diary files.
+To use, add this function to `diary-mark-entries-hook'.
+Specify include files using lines matching `diary-include-string', e.g.
+ #include \"filename\"
+This is recursive; that is, included files may include other files.
+See also `diary-include-other-diary-files'."
(goto-char (point-min))
(while (re-search-forward
(format "^%s \"\\([^\"]*\\)\"" (regexp-quote diary-include-string))
@@ -1490,7 +1579,7 @@ passed to `calendar-mark-visible-date' as MARK."
(let ((m displayed-month)
(y displayed-year))
(calendar-increment-month m y -1)
- (dotimes (idummy 3)
+ (dotimes (_idummy 3)
(calendar-mark-month m y month day year color)
(calendar-increment-month m y 1)))))
@@ -2071,7 +2160,7 @@ Optional symbol TYPE is either `monthly' or `yearly'."
'(day " " monthname))
(t '(monthname " " day))))
;; Iso cannot contain "-", because this form used eg by
- ;; insert-anniversary-diary-entry.
+ ;; diary-insert-anniversary-entry.
(t (cond ((eq calendar-date-style 'iso)
'((format "%s %.2d %.2d" year
(string-to-number month) (string-to-number day))))
@@ -2334,43 +2423,58 @@ return a font-lock pattern matching array of MONTHS and marking SYMBOL."
"Major mode for editing the diary file."
(set (make-local-variable 'font-lock-defaults)
'(diary-font-lock-keywords t))
+ (set (make-local-variable 'comment-start) diary-comment-start)
+ (set (make-local-variable 'comment-end) diary-comment-end)
(add-to-invisibility-spec '(diary . nil))
(add-hook 'after-save-hook 'diary-redraw-calendar nil t)
+ ;; In case the file was modified externally, refresh the calendar
+ ;; after refreshing the diary buffer.
+ (add-hook 'after-revert-hook 'diary-redraw-calendar nil t)
(if diary-header-line-flag
(setq header-line-format diary-header-line-format)))
;;; Fancy Diary Mode.
-(defvar diary-fancy-date-pattern
+(defun diary-fancy-date-pattern ()
+ "Return a regexp matching the first line of a fancy diary date header.
+This depends on the calendar date style."
(concat
(let ((dayname (diary-name-pattern calendar-day-name-array nil t))
(monthname (diary-name-pattern calendar-month-name-array nil t))
- (day "[0-9]+")
- (month "[0-9]+")
- (year "-?[0-9]+"))
- (mapconcat 'eval calendar-date-display-form ""))
+ (day "1")
+ (month "2")
+ ;; FIXME? This used to be "-?[0-9]+" - what was the "-?" for?
+ (year "3"))
+ ;; This is ugly. c-d-d-form expects `day' etc to be "numbers in
+ ;; string form"; eg the iso version calls string-to-number on some.
+ ;; Therefore we cannot eg just let day = "[0-9]+". (Bug#8583).
+ ;; Assumes no integers in c-day/month-name-array.
+ (replace-regexp-in-string "[0-9]+" "[0-9]+"
+ (mapconcat 'eval calendar-date-display-form "")
+ nil t))
;; Optional ": holiday name" after the date.
- "\\(: .*\\)?")
- "Regular expression matching a date header in Fancy Diary.")
+ "\\(: .*\\)?"))
+
+(defun diary-fancy-date-matcher (limit)
+ "Search for a fancy diary data header, up to LIMIT."
+ ;; Any number of " other holiday name" lines, followed by "==" line.
+ (when (re-search-forward
+ (format "%s\\(\n +.*\\)*\n=+$" (diary-fancy-date-pattern)) limit t)
+ (put-text-property (match-beginning 0) (match-end 0) 'font-lock-multiline t)
+ t))
(define-obsolete-variable-alias 'fancy-diary-font-lock-keywords
'diary-fancy-font-lock-keywords "23.1")
(defvar diary-fancy-font-lock-keywords
- (list
- (list
- ;; Any number of " other holiday name" lines, followed by "==" line.
- (concat diary-fancy-date-pattern "\\(\n +.*\\)*\n=+$")
- '(0 (progn (put-text-property (match-beginning 0) (match-end 0)
- 'font-lock-multiline t)
- diary-face)))
- '("^.*\\([aA]nniversary\\|[bB]irthday\\).*$" . 'diary-anniversary)
- '("^.*Yahrzeit.*$" . font-lock-reference-face)
- '("^\\(Erev \\)?Rosh Hodesh.*" . font-lock-function-name-face)
- '("^Day.*omer.*$" . font-lock-builtin-face)
- '("^Parashat.*$" . font-lock-comment-face)
- `(,(format "\\(^\\|\\s-\\)%s\\(-%s\\)?" diary-time-regexp
+ `((diary-fancy-date-matcher . diary-face)
+ ("^.*\\([aA]nniversary\\|[bB]irthday\\).*$" . 'diary-anniversary)
+ ("^.*Yahrzeit.*$" . font-lock-reference-face)
+ ("^\\(Erev \\)?Rosh Hodesh.*" . font-lock-function-name-face)
+ ("^Day.*omer.*$" . font-lock-builtin-face)
+ ("^Parashat.*$" . font-lock-comment-face)
+ (,(format "\\(^\\|\\s-\\)%s\\(-%s\\)?" diary-time-regexp
diary-time-regexp) . 'diary-time))
"Keywords to highlight in fancy diary display.")
@@ -2386,7 +2490,7 @@ Fontify the region between BEG and END, quietly unless VERBOSE is non-nil."
(while (and (looking-at " +[^ ]")
(zerop (forward-line -1))))
;; This check not essential.
- (if (looking-at diary-fancy-date-pattern)
+ (if (looking-at (diary-fancy-date-pattern))
(setq beg (line-beginning-position)))
(goto-char end)
(forward-line 0)
@@ -2396,12 +2500,10 @@ Fontify the region between BEG and END, quietly unless VERBOSE is non-nil."
(setq end (line-beginning-position 2)))
(font-lock-default-fontify-region beg end verbose))
-(defvar diary-fancy-overriding-map (let ((map (make-sparse-keymap)))
- (define-key map "q" 'quit-window)
- map)
+(defvar diary-fancy-overriding-map (make-sparse-keymap)
"Keymap overriding minor-mode maps in `diary-fancy-display-mode'.")
-(define-derived-mode diary-fancy-display-mode fundamental-mode
+(define-derived-mode diary-fancy-display-mode special-mode
"Diary"
"Major mode used while displaying diary entries using Fancy Display."
(set (make-local-variable 'font-lock-defaults)
@@ -2409,7 +2511,6 @@ Fontify the region between BEG and END, quietly unless VERBOSE is non-nil."
t nil nil nil
(font-lock-fontify-region-function
. diary-fancy-font-lock-fontify-region-function)))
- (local-set-key "q" 'quit-window)
(set (make-local-variable 'minor-mode-overriding-map-alist)
(list (cons t diary-fancy-overriding-map)))
(view-mode 1))
@@ -2423,37 +2524,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))
@@ -2481,9 +2572,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)
@@ -2496,15 +2587,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)
@@ -2524,5 +2617,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 028c66d31b6..695f9b92712 100644
--- a/lisp/calendar/holidays.el
+++ b/lisp/calendar/holidays.el
@@ -1,11 +1,12 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1989-1990, 1992-1994, 1997, 2001-2011
+;; 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 +43,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 +71,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 +96,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 +107,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 +118,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 +219,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 +238,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 +260,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 +284,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 +307,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 +330,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.
@@ -461,7 +462,7 @@ The holidays are those in the list `calendar-holidays'."
(sort
(dolist (p calendar-holidays res)
(if (setq h (if calendar-debug-sexp
- (let ((stack-trace-on-error t))
+ (let ((debug-on-error t))
(eval p))
(condition-case nil
(eval p)
@@ -918,5 +919,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 29a515a7d6b..03456ba36f2 100644
--- a/lisp/calendar/icalendar.el
+++ b/lisp/calendar/icalendar.el
@@ -1,12 +1,12 @@
;;; icalendar.el --- iCalendar implementation -*-coding: utf-8 -*-
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Ulf Jasper <ulf.jasper@web.de>
;; Created: August 2002
;; Keywords: calendar
;; Human-Keywords: calendar, diary, iCalendar, vCalendar
+;; Version: 0.19
;; This file is part of GNU Emacs.
@@ -34,6 +34,8 @@
;; week of the year 2000 when they are exported.
;; - Yearly diary entries are assumed to occur the first time in the year
;; 1900 when they are exported.
+;; - Float diary entries are assumed to occur the first time on the
+;; day when they are exported.
;;; History:
@@ -212,15 +214,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
@@ -241,6 +243,7 @@ code for the event, and your personal domain name."
;; all the other libs we need
;; ======================================================================
(require 'calendar)
+(require 'diary-lib)
;; ======================================================================
;; misc
@@ -427,7 +430,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 +747,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
@@ -911,27 +928,30 @@ ENTRY-FULL is the full diary entry string. CONTENTS is the
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"
- (format "%d" icalendar--uid-count)
- uid t t))
- (setq icalendar--uid-count (1+ icalendar--uid-count))
- (setq uid (replace-regexp-in-string
- "%t"
- (format "%d%d%d" (car (current-time))
- (cadr (current-time))
- (car (cddr (current-time))))
- uid t t))
- (setq uid (replace-regexp-in-string
- "%h"
- (format "%d" (abs (sxhash entry-full))) uid t t))
- (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))
- "DTSTART")))
- (setq uid (replace-regexp-in-string "%s" dtstart uid t t)))
+ (if
+ ;; Allow other apps (such as org-mode) to create its own uid
+ (get-text-property 0 'uid entry-full)
+ (setq uid (get-text-property 0 'uid entry-full))
+ (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
+ "%t"
+ (format "%d%d%d" (car (current-time))
+ (cadr (current-time))
+ (car (cddr (current-time))))
+ uid t t))
+ (setq uid (replace-regexp-in-string
+ "%h"
+ (format "%d" (abs (sxhash entry-full))) uid t t))
+ (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))
+ "DTSTART")))
+ (setq uid (replace-regexp-in-string "%s" dtstart uid t t))))
;; Return the UID string
uid))
@@ -1008,7 +1028,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 +1146,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)
@@ -1531,18 +1551,65 @@ entries. ENTRY-MAIN is the first line of the diary entry."
nil))
(defun icalendar--convert-float-to-ical (nonmarker entry-main)
- "Convert float diary entry to icalendar format -- unsupported!
-
-FIXME!
-
-NONMARKER is a regular expression matching the start of non-marking
-entries. ENTRY-MAIN is the first line of the diary entry."
- (if (string-match (concat nonmarker
- "%%(diary-float \\([^)]+\\))\\s-*\\(.*?\\) ?$")
- entry-main)
- (progn
- (icalendar--dmsg "diary-float %s" entry-main)
- (error "`diary-float' is not supported yet"))
+ "Convert float diary entry to icalendar format -- partially unsupported!
+
+ FIXME! DAY from diary-float yet unimplemented.
+
+ NONMARKER is a regular expression matching the start of non-marking
+ entries. ENTRY-MAIN is the first line of the diary entry."
+ (if (string-match (concat nonmarker "%%\\((diary-float .+\\) ?$") entry-main)
+ (with-temp-buffer
+ (insert (match-string 1 entry-main))
+ (goto-char (point-min))
+ (let* ((sexp (read (current-buffer))) ;using `read' here
+ ;easier than regexp
+ ;matching, esp. with
+ ;different forms of
+ ;MONTH
+ (month (nth 1 sexp))
+ (dayname (nth 2 sexp))
+ (n (nth 3 sexp))
+ (day (nth 4 sexp))
+ (summary
+ (replace-regexp-in-string
+ "\\(^\s+\\|\s+$\\)" ""
+ (buffer-substring (point) (point-max)))))
+
+ (when day
+ (progn
+ (icalendar--dmsg "diary-float %s" entry-main)
+ (error "Don't know if or how to implement day in `diary-float'")))
+
+ (list (concat
+ ;;Start today (yes this is an arbitrary choice):
+ "\nDTSTART;VALUE=DATE:"
+ (format-time-string "%Y%m%d" (current-time))
+ ;;BUT remove today if `diary-float'
+ ;;expression does not hold true for today:
+ (when
+ (null (let ((date (calendar-current-date))
+ (entry entry-main))
+ (diary-float month dayname n)))
+ (concat
+ "\nEXDATE;VALUE=DATE:"
+ (format-time-string "%Y%m%d" (current-time))))
+ "\nRRULE:"
+ (if (or (numberp month) (listp month))
+ "FREQ=YEARLY;BYMONTH="
+ "FREQ=MONTHLY")
+ (when
+ (listp month)
+ (mapconcat
+ (lambda (m)
+ (number-to-string m))
+ (cadr month) ","))
+ (when
+ (numberp month)
+ (number-to-string month))
+ ";BYDAY="
+ (number-to-string n)
+ (aref icalendar--weekday-array dayname))
+ summary)))
;; no match
nil))
@@ -2057,39 +2124,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 +2176,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")
@@ -2270,5 +2347,4 @@ the entry."
(provide 'icalendar)
-;; arch-tag: 74fdbe8e-0451-4e38-bb61-4416e822f4fc
;;; icalendar.el ends here
diff --git a/lisp/calendar/lunar.el b/lisp/calendar/lunar.el
index 689f9fb8ed5..e2ec46215be 100644
--- a/lisp/calendar/lunar.el
+++ b/lisp/calendar/lunar.el
@@ -1,12 +1,13 @@
;;; lunar.el --- calendar functions for phases of the moon
-;; Copyright (C) 1992, 1993, 1995, 1997, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992-1993, 1995, 1997, 2001-2011
+;; Free Software Foundation, Inc.
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: moon, lunar phases, calendar, diary
+;; Package: calendar
;; This file is part of GNU Emacs.
@@ -407,5 +408,4 @@ as governed by the values of `calendar-daylight-savings-starts',
(provide 'lunar)
-;; arch-tag: 72f0b8a4-7bcc-4a1b-b67a-ff53c4a1d222
;;; lunar.el ends here
diff --git a/lisp/calendar/parse-time.el b/lisp/calendar/parse-time.el
index 5cc3fcfbd5c..52f13c82f5a 100644
--- a/lisp/calendar/parse-time.el
+++ b/lisp/calendar/parse-time.el
@@ -1,7 +1,6 @@
;;; parse-time.el --- parsing time strings
-;; Copyright (C) 1996, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 2000-2011 Free Software Foundation, Inc.
;; Author: Erik Naggum <erik@naggum.no>
;; Keywords: util
@@ -220,5 +219,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 f021e73efb5..84a1544d709 100644
--- a/lisp/calendar/solar.el
+++ b/lisp/calendar/solar.el
@@ -1,13 +1,14 @@
;;; solar.el --- calendar functions for solar events
-;; Copyright (C) 1992, 1993, 1995, 1997, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992-1993, 1995, 1997, 2001-2011
+;; Free Software Foundation, Inc.
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
;; Denis B. Roegel <Denis.Roegel@loria.fr>
;; 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.
@@ -452,7 +453,7 @@ height (between -180 and 180) are both in degrees."
(st (+ solar-sidereal-time-greenwich-midnight
(* ut 1.00273790935)))
;; Hour angle (in degrees).
- (ah (- (* st 15) (* 15 (car ec)) (* -1 (calendar-longitude))))
+ (ah (- (* st 15) (* 15 (car ec)) (* -1 longitude)))
(de (cadr ec))
(azimuth (solar-atn2 (- (* (solar-cosine-degrees ah)
(solar-sin-degrees latitude))
@@ -770,26 +771,22 @@ day numbers. The values of `calendar-daylight-savings-starts',
`calendar-daylight-savings-starts-time', `calendar-daylight-savings-ends',
`calendar-daylight-savings-ends-time', `calendar-daylight-time-offset',
and `calendar-time-zone' are used to interpret local time."
- (let* ((long)
- (start d)
- (start-long (solar-longitude d))
- (next (mod (* l (1+ (floor (/ start-long l)))) 360))
- (end (+ d (* (/ l 360.0) 400)))
- (end-long (solar-longitude end)))
- (while ; bisection search for nearest minute
- (< 0.00001 (- end start))
- ;; start <= d < end
+ (let ((start d)
+ (next (mod (* l (1+ (floor (/ (solar-longitude d) l)))) 360))
+ (end (+ d (* (/ l 360.0) 400)))
+ long)
+ ;; Bisection search for nearest minute.
+ (while (< 0.00001 (- end start))
+ ;; start <= d < end
;; start-long <= next < end-long when next != 0
- ;; when next = 0, we look for the discontinuity (start-long is near 360
- ;; and end-long is small (less than l).
+ ;; when next = 0, look for the discontinuity (start-long is near 360
+ ;; and end-long is small (less than l)).
(setq d (/ (+ start end) 2.0)
long (solar-longitude d))
(if (or (and (not (zerop next)) (< long next))
(and (zerop next) (< l long)))
- (setq start d
- start-long long)
- (setq end d
- end-long long)))
+ (setq start d)
+ (setq end d)))
(/ (+ start end) 2.0)))
;; FIXME but there already is solar-sunrise-sunset.
@@ -1064,5 +1061,4 @@ Requires floating point."
(provide 'solar)
-;; arch-tag: bc0ff693-df58-4666-bde4-2a7837ccb8fe
;;; solar.el ends here
diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el
index ea4cbc1145b..70d096c4108 100644
--- a/lisp/calendar/time-date.el
+++ b/lisp/calendar/time-date.el
@@ -1,7 +1,6 @@
;;; time-date.el --- Date and time handling functions
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Masanobu Umeda <umerin@mse.kyutech.ac.jp>
@@ -39,9 +38,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 +93,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 +139,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)
@@ -250,8 +243,6 @@ DATE1 and DATE2 should be date-time strings."
TIME should be a time value.
The Gregorian date Sunday, December 31, 1bce is imaginary."
(let* ((tim (decode-time time))
- (month (nth 4 tim))
- (day (nth 3 tim))
(year (nth 5 tim)))
(+ (time-to-day-in-year time) ; Days this year
(* 365 (1- year)) ; + Days in prior years
@@ -259,17 +250,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,13 +306,9 @@ 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
- (or (setq match (assoc-string spec units t))
+ (or (setq match (assoc (downcase spec) units))
(error "Bad format specifier: `%s'" spec))
- (if (assoc-string spec usedunits t)
+ (if (assoc (downcase spec) usedunits)
(error "Multiple instances of specifier: `%s'" spec))
(if (string-equal (car match) "z")
(setq zeroflag t)
@@ -364,5 +349,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 ddc0cbe8539..8fc3f762f29 100644
--- a/lisp/calendar/timeclock.el
+++ b/lisp/calendar/timeclock.el
@@ -1,7 +1,6 @@
;;; timeclock.el --- mode for keeping track of how much you work
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
;; Created: 25 Mar 1999
@@ -543,11 +542,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."
@@ -1029,11 +1025,10 @@ lists:
timeclock-current-debt LOG-DATA
See the documentation for the given function if more info is needed."
- (let* ((log-data (list 0.0 nil nil))
- (now (current-time))
- (todays-date (timeclock-time-to-date now))
- last-date-limited last-date-seconds last-date
- (line 0) last beg day entry event)
+ (let ((log-data (list 0.0 nil nil))
+ (now (current-time))
+ last-date-limited last-date-seconds last-date
+ (line 0) last beg day entry event)
(with-temp-buffer
(insert-file-contents (or filename timeclock-file))
(when recent-only
@@ -1119,7 +1114,7 @@ discrepancy, today's discrepancy, and the time worked today."
(let* ((now (current-time))
(todays-date (timeclock-time-to-date now))
(first t) (accum 0) (elapsed 0)
- event beg last-date avg
+ event beg last-date
last-date-limited last-date-seconds)
(unless timeclock-discrepancy
(when (file-readable-p timeclock-file)
@@ -1419,5 +1414,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 99456be57ad..4c59e2634ae 100644
--- a/lisp/calendar/todo-mode.el
+++ b/lisp/calendar/todo-mode.el
@@ -1,7 +1,6 @@
;;; todo-mode.el --- major mode for editing TODO list files
-;; Copyright (C) 1997, 1999, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 1999, 2001-2011 Free Software Foundation, Inc.
;; Author: Oliver Seidel <privat@os10000.net>
;; Maintainer: Stephen Berman <stephen.berman@gmx.net>
@@ -918,17 +917,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)
@@ -981,5 +972,4 @@ If INCLUDE-SEP is non-nil, return point after the separator."
(provide 'todo-mode)
-;; arch-tag: 6fd91be5-776e-4464-a109-da4ea0e4e497
;;; todo-mode.el ends here
diff --git a/lisp/case-table.el b/lisp/case-table.el
index 4705645ccc8..a1bb862788e 100644
--- a/lisp/case-table.el
+++ b/lisp/case-table.el
@@ -1,11 +1,11 @@
;;; case-table.el --- code to extend the character set and support case tables
-;; Copyright (C) 1988, 1994, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1988, 1994, 2001-2011 Free Software Foundation, Inc.
;; Author: Howard Gayle
;; Maintainer: FSF
;; Keywords: i18n
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -174,5 +174,4 @@ SYNTAX should be \" \", \"w\", \".\" or \"_\"."
(provide 'case-table)
-;; arch-tag: 3c2cf885-2c9a-449a-9972-2e269191896d
;;; case-table.el ends here
diff --git a/lisp/cdl.el b/lisp/cdl.el
index ca7ea59ed5b..8377e7a5796 100644
--- a/lisp/cdl.el
+++ b/lisp/cdl.el
@@ -1,7 +1,6 @@
;;; cdl.el --- Common Data Language (CDL) utility functions for GNU Emacs
-;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2001-2011 Free Software Foundation, Inc.
;; Author: ATAE@spva.physics.imperial.ac.uk (Ata Etemadi)
;; Maintainer: FSF
@@ -45,5 +44,4 @@
(provide 'cdl)
-;; arch-tag: b8e95a6e-2387-4077-ad9a-af54b09b8615
;;; cdl.el ends here
diff --git a/lisp/cedet/ChangeLog b/lisp/cedet/ChangeLog
index d8a4209cc98..7899ed08a5e 100644
--- a/lisp/cedet/ChangeLog
+++ b/lisp/cedet/ChangeLog
@@ -1,4 +1,9 @@
-2011-04-13 Juanma Barranquero <lekktu@gmail.com>
+2011-05-11 Glenn Morris <rgm@gnu.org>
+
+ * semantic/wisent/javascript.el (semantic-get-local-variables):
+ Use define-mode-local-override rather than its obsolete alias.
+
+2011-04-23 Juanma Barranquero <lekktu@gmail.com>
* ede/pconf.el (ede-proj-tweak-autoconf, ede-proj-flush-autoconf):
* ede/proj-comp.el (ede-proj-tweak-autoconf, ede-proj-flush-autoconf):
@@ -10,7 +15,59 @@
* Version 23.3 released.
-2010-10-29 Glenn Morris <rgm@gnu.org>
+2011-02-21 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * semantic/wisent/comp.el (wisent-byte-compile-grammar):
+ Macroexpand before passing to byte-compile-form.
+
+2011-01-13 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * srecode/srt-mode.el (srecode-template-mode): Use define-derived-mode.
+ * semantic/symref/list.el (semantic-symref-results-mode):
+ Use run-mode-hooks.
+
+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):
@@ -18,12 +75,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:
@@ -61,6 +112,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.
@@ -74,8 +133,8 @@
* srecode/texi.el (srecode-texi-insert-tag-as-doc): New function.
(semantic-insert-foreign-tag): Use it.
- * srecode/mode.el (srecode-bind-insert): Call
- srecode-load-tables-for-mode.
+ * srecode/mode.el (srecode-bind-insert):
+ Call srecode-load-tables-for-mode.
(srecode-minor-mode-templates-menu): Do not list templates that
are not in the current project.
(srecode-menu-bar): Add binding for srecode-macro-help.
@@ -128,8 +187,8 @@
compare of built-in templates. Give built-ins lower piority.
Support special variable "project".
(srecode-compile-template-table): Set :project slot of new tables.
- (srecode-compile-one-template-tag): Use
- srecode-create-dictionaries-from-tags.
+ (srecode-compile-one-template-tag):
+ Use srecode-create-dictionaries-from-tags.
2010-09-21 Eric Ludlam <zappo@gnu.org>
@@ -179,8 +238,8 @@
(autoconf-new-automake-string): Deleted.
(autoconf-new-program): Use SRecode to fill an empty file.
- * ede/cpp-root.el (ede-create-lots-of-projects-under-dir): New
- function.
+ * ede/cpp-root.el (ede-create-lots-of-projects-under-dir):
+ New function.
* ede/files.el (ede-flush-project-hash): New command.
(ede-convert-path): Add optional PROJECT arg.
@@ -201,8 +260,8 @@
list whether or not the vars are already in the Makefile.
(ede-pmake-insert-variable-once): New macro.
- * ede/project-am.el (project-am-with-makefile-current): Add
- recentf-exclude.
+ * ede/project-am.el (project-am-with-makefile-current):
+ Add recentf-exclude.
(project-am-load-makefile): Obey an optional suggested name.
(project-am-expand-subdirlist): New function.
(project-am-makefile::project-rescan): Use it. Combine SUBDIRS
@@ -217,16 +276,16 @@
(project-am-extract-package-info): Fix separators.
* ede/proj.el (project-run-target): New method.
- (project-make-dist, project-compile-project): Use
- ede-proj-automake-p to determine which kind of compile to use.
+ (project-make-dist, project-compile-project):
+ Use ede-proj-automake-p to determine which kind of compile to use.
(project-rescan): Call ede-load-project-file.
(ede-buffer-mine): Add more file names that belong to the project.
(ede-proj-compilers): Improve error message.
* ede/proj-obj.el (ede-ld-linker): Use the LDDEPS variable.
(ede-source-c++): Add more C++ extensions.
- (ede-proj-target-makefile-objectcode): Quote initforms. Support
- lex and yacc.
+ (ede-proj-target-makefile-objectcode): Quote initforms.
+ Support lex and yacc.
* ede/proj-prog.el (ede-proj-makefile-insert-rules): Removed.
(ede-proj-makefile-insert-variables): New, add LDDEPS.
@@ -236,8 +295,8 @@
they show up in the same order as in the command line.
(ede-proj-target-makefile-program): Add ldlibs-local slot.
- * ede/proj-shared.el (ede-g++-libtool-shared-compiler): Fix
- inference rule to use cpp files.
+ * ede/proj-shared.el (ede-g++-libtool-shared-compiler):
+ Fix inference rule to use cpp files.
(ede-proj-target-makefile-shared-object): Quote initforms.
* ede/proj-misc.el (ede-proj-target-makefile-miscelaneous):
@@ -296,8 +355,8 @@
(semantic-analyze-scoped-inherited-tag-map): Take the tag we are
looking for as part of the scoped tags list.
- * semantic/html.el (semantic-default-html-setup): Add
- senator-step-at-tag-classes.
+ * semantic/html.el (semantic-default-html-setup):
+ Add senator-step-at-tag-classes.
* semantic/decorate/include.el
(semantic-decoration-on-unknown-includes): Change light bgcolor.
@@ -324,8 +383,8 @@
* semantic/util.el (semantic-hack-search)
(semantic-recursive-find-nonterminal-by-name)
(semantic-current-tag-interactive): Deleted.
- (semantic-describe-buffer): Fix expand-nonterminal. Add
- lex-syntax-mods, type relation separator char, and command
+ (semantic-describe-buffer): Fix expand-nonterminal.
+ Add lex-syntax-mods, type relation separator char, and command
separation char.
(semantic-sanity-check): Only message if called interactively.
@@ -341,8 +400,8 @@
* semantic/idle.el: Add breadcrumbs support.
(semantic-idle-summary-current-symbol-info-default)
(semantic-idle-tag-highlight)
- (semantic-idle-completion-list-default): Use
- semanticdb-without-unloaded-file-searches for speed, and to
+ (semantic-idle-completion-list-default):
+ Use semanticdb-without-unloaded-file-searches for speed, and to
conform to the controls that specify if the idle timer is supposed
to be parsing unparsed includes.
(semantic-idle-symbol-highlight-face)
@@ -417,8 +476,8 @@
(semantic-analyze-find-tag-sequence-default): Be robust to
calculated scopes being nil.
- * semantic/bovine/c.el (semantic-c-describe-environment): Add
- project macro symbol array.
+ * semantic/bovine/c.el (semantic-c-describe-environment):
+ Add project macro symbol array.
(semantic-c-parse-lexical-token): Add recursion limit.
(semantic-ctxt-imported-packages, semanticdb-expand-nested-tag):
New overrides.
@@ -427,8 +486,8 @@
(semantic-expand-c-tag-namelist): Do not split out a typedef'd
inline type if it is an anonymous type.
(semantic-c-reconstitute-token): Use the optional initializers as
- a clue that some function is probably a constructor. When
- defining the type of these constructors, split the parent name,
+ a clue that some function is probably a constructor.
+ When defining the type of these constructors, split the parent name,
and use only the class part, if applicable.
* semantic/bovine/c-by.el:
@@ -449,7 +508,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.
@@ -464,6 +601,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
@@ -478,8 +622,13 @@
* semantic/db-find.el
(semanticdb-find-translate-path-brutish-default):
- * ede/make.el (ede-make-check-version): Use
- with-current-buffer instead of save-excursion.
+ * 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>
@@ -662,8 +811,8 @@
* ede.el (ede-apply-preprocessor-map): Accept lists of
ede-objects as targets.
- * ede/pmake.el (ede-proj-makefile-insert-variables): Output
- a target's object list even if compiler vars are already in the
+ * ede/pmake.el (ede-proj-makefile-insert-variables):
+ Output a target's object list even if compiler vars are already in the
Makefile.
* ede/emacs.el (ede-preprocessor-map): Add config.h to the
@@ -759,8 +908,8 @@
2009-11-08 Chong Yidong <cyd@stupidchicken.com>
- * semantic/ctxt.el (semantic-get-local-variables): Disable
- the progress reporter entirely.
+ * semantic/ctxt.el (semantic-get-local-variables):
+ Disable the progress reporter entirely.
2009-11-03 Stefan Monnier <monnier@iro.umontreal.ca>
@@ -855,8 +1004,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.
@@ -1010,10 +1159,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.
@@ -1341,10 +1486,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.
@@ -1390,15 +1531,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:
@@ -1412,7 +1544,7 @@
;; coding: utf-8
;; End:
- Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 2009-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
diff --git a/lisp/cedet/cedet-cscope.el b/lisp/cedet/cedet-cscope.el
index 90b2277012a..74892533ab6 100644
--- a/lisp/cedet/cedet-cscope.el
+++ b/lisp/cedet/cedet-cscope.el
@@ -1,8 +1,9 @@
;;; cedet-cscope.el --- CScope support for CEDET
-;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
+;; Package: cedet
;; This file is part of GNU Emacs.
@@ -172,5 +173,4 @@ there is already a database in DIR."
(provide 'cedet-cscope)
-;; arch-tag: 9973f1ad-f13b-4399-bc67-7f488478d78d
;;; cedet-cscope.el ends here
diff --git a/lisp/cedet/cedet-files.el b/lisp/cedet/cedet-files.el
index 65112bdab92..ae037028bf7 100644
--- a/lisp/cedet/cedet-files.el
+++ b/lisp/cedet/cedet-files.el
@@ -1,8 +1,9 @@
;;; cedet-files.el --- Common routines dealing with file names.
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
+;; Package: cedet
;; This file is part of GNU Emacs.
@@ -89,5 +90,4 @@ specific conversions during tests."
(provide 'cedet-files)
-;; arch-tag: 4884c616-82c3-475d-ac9f-039e3431a702
;;; cedet-files.el ends here
diff --git a/lisp/cedet/cedet-global.el b/lisp/cedet/cedet-global.el
index 9b270415dc1..d2a9794ec81 100644
--- a/lisp/cedet/cedet-global.el
+++ b/lisp/cedet/cedet-global.el
@@ -1,8 +1,9 @@
;;; cedet-global.el --- GNU Global support for CEDET.
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
+;; Package: cedet
;; This file is part of GNU Emacs.
@@ -185,5 +186,4 @@ If a database already exists, then just update it."
(provide 'cedet-global)
-;; arch-tag: 0d0d3ac2-91ef-4820-bb2b-1d59ccf38392
;;; cedet-global.el ends here
diff --git a/lisp/cedet/cedet-idutils.el b/lisp/cedet/cedet-idutils.el
index 760a85deb3b..e071265c143 100644
--- a/lisp/cedet/cedet-idutils.el
+++ b/lisp/cedet/cedet-idutils.el
@@ -1,10 +1,11 @@
;;; cedet-idutils.el --- ID Utils support for CEDET.
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
;; Version: 0.2
;; Keywords: OO, lisp
+;; Package: cedet
;; This file is part of GNU Emacs.
@@ -199,5 +200,4 @@ IDUtils must start from scratch when updating a database."
(provide 'cedet-idutils)
-;; arch-tag: 663ca082-5b3d-4384-8710-cc74f990b501
;;; cedet-idutils.el ends here
diff --git a/lisp/cedet/cedet.el b/lisp/cedet/cedet.el
index ab5d7cd2132..d2fb066515b 100644
--- a/lisp/cedet/cedet.el
+++ b/lisp/cedet/cedet.el
@@ -1,11 +1,10 @@
;;; cedet.el --- Setup CEDET environment
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; 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.
@@ -132,5 +131,4 @@ if the package has not been loaded."
(provide 'cedet)
-;; arch-tag: ad4b0b63-d1f9-4a41-b003-9bbb2feb5226
;;; cedet.el ends here
diff --git a/lisp/cedet/data-debug.el b/lisp/cedet/data-debug.el
index 084d1899f57..cd910f35a6a 100644
--- a/lisp/cedet/data-debug.el
+++ b/lisp/cedet/data-debug.el
@@ -1,10 +1,11 @@
;;; data-debug.el --- Datastructure Debugger
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 0.2
;; Keywords: OO, lisp
+;; Package: cedet
;; This file is part of GNU Emacs.
@@ -1082,5 +1083,4 @@ If the result is a list or vector, then use the data debugger to display it."
(if (featurep 'eieio)
(require 'eieio-datadebug))
-;; arch-tag: 4807227d-08e7-45c4-8ea5-9e4595c3bfb1
;;; data-debug.el ends here
diff --git a/lisp/cedet/ede.el b/lisp/cedet/ede.el
index f0450d539a3..307ccfdadd7 100644
--- a/lisp/cedet/ede.el
+++ b/lisp/cedet/ede.el
@@ -1,10 +1,10 @@
;;; ede.el --- Emacs Development Environment gloss
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2005, 2007-2011 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 +55,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")
@@ -80,7 +80,7 @@ project file, all targets are queried to see if it should be added.
If the value is 'always, then the new file is added to the first
target encountered. If the value is 'multi-ask, then if more than one
target wants the file, the user is asked. If only one target wants
-the file, then then it is automatically added to that target. If the
+the file, then it is automatically added to that target. If the
value is 'ask, then the user is always asked, unless there is no
target willing to take the file. 'never means never perform the check."
:group 'ede
@@ -1277,5 +1277,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/auto.el b/lisp/cedet/ede/auto.el
index 36f902d4e1c..09535ffce6b 100644
--- a/lisp/cedet/ede/auto.el
+++ b/lisp/cedet/ede/auto.el
@@ -1,6 +1,6 @@
;;; ede/auto.el --- Autoload features for EDE
-;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
diff --git a/lisp/cedet/ede/autoconf-edit.el b/lisp/cedet/ede/autoconf-edit.el
index 5af44a56f9c..bd4a5a627a9 100644
--- a/lisp/cedet/ede/autoconf-edit.el
+++ b/lisp/cedet/ede/autoconf-edit.el
@@ -1,6 +1,6 @@
;;; ede/autoconf-edit.el --- Keymap for autoconf
-;; Copyright (C) 1998, 1999, 2000, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2000, 2009-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project
@@ -381,9 +381,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 +415,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/base.el b/lisp/cedet/ede/base.el
index d53505726a1..da36919b23a 100644
--- a/lisp/cedet/ede/base.el
+++ b/lisp/cedet/ede/base.el
@@ -1,6 +1,6 @@
;;; ede/base.el --- Baseclasses for EDE.
-;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
diff --git a/lisp/cedet/ede/cpp-root.el b/lisp/cedet/ede/cpp-root.el
index 5665d283844..7586522355e 100644
--- a/lisp/cedet/ede/cpp-root.el
+++ b/lisp/cedet/ede/cpp-root.el
@@ -1,6 +1,6 @@
;;; ede/cpp-root.el --- A simple way to wrap a C++ project with a single root
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -538,5 +538,4 @@ Note: This needs some work."
;; generated-autoload-load-name: "ede/cpp-root"
;; End:
-;; arch-tag: c3ac8160-cba6-447e-8b9c-accb7e2d942e
;;; ede/cpp-root.el ends here
diff --git a/lisp/cedet/ede/custom.el b/lisp/cedet/ede/custom.el
index 5a179341352..a7470547cc2 100644
--- a/lisp/cedet/ede/custom.el
+++ b/lisp/cedet/ede/custom.el
@@ -1,6 +1,6 @@
;;; ede.el --- customization of EDE projects.
-;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
diff --git a/lisp/cedet/ede/dired.el b/lisp/cedet/ede/dired.el
index af9ff274351..b7a98271ff3 100644
--- a/lisp/cedet/ede/dired.el
+++ b/lisp/cedet/ede/dired.el
@@ -1,7 +1,6 @@
;;; ede/dired.el --- EDE extensions to dired.
-;; Copyright (C) 1998, 1999, 2000, 2003, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1998-2000, 2003, 2009-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 0.4
@@ -27,57 +26,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,26 +73,14 @@ 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)
-;; arch-tag: 95d3e0a7-a8b7-43a9-b7df-ba647e4c56f6
;;; ede/dired.el ends here
diff --git a/lisp/cedet/ede/emacs.el b/lisp/cedet/ede/emacs.el
index 1ea35ea8c2a..b8759dd06ee 100644
--- a/lisp/cedet/ede/emacs.el
+++ b/lisp/cedet/ede/emacs.el
@@ -1,6 +1,6 @@
;;; ede/emacs.el --- Special project for Emacs
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -299,5 +299,4 @@ Knows about how the Emacs source tree is organized."
;; generated-autoload-load-name: "ede/emacs"
;; End:
-;; arch-tag: 7cd0be95-663d-4101-8799-2f8216fd8233
;;; ede/emacs.el ends here
diff --git a/lisp/cedet/ede/files.el b/lisp/cedet/ede/files.el
index 595845a1907..3d165c39016 100644
--- a/lisp/cedet/ede/files.el
+++ b/lisp/cedet/ede/files.el
@@ -1,6 +1,6 @@
;;; ede/files.el --- Associate projects with files and directories.
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -501,5 +501,4 @@ Argument DIR is the directory to trim upwards."
;; generated-autoload-load-name: "ede/files"
;; End:
-;; arch-tag: 28e17358-0208-4678-828c-23fb0e783fd6
;;; ede/files.el ends here
diff --git a/lisp/cedet/ede/generic.el b/lisp/cedet/ede/generic.el
index 46ea6743819..360b15499ca 100644
--- a/lisp/cedet/ede/generic.el
+++ b/lisp/cedet/ede/generic.el
@@ -1,6 +1,6 @@
;;; ede/generic.el --- Base Support for generic build systems
-;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
diff --git a/lisp/cedet/ede/linux.el b/lisp/cedet/ede/linux.el
index a9f87f3dcf6..e11286c710e 100644
--- a/lisp/cedet/ede/linux.el
+++ b/lisp/cedet/ede/linux.el
@@ -1,6 +1,6 @@
;;; ede/linux.el --- Special project for Linux
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -245,5 +245,4 @@ Knows about how the Linux source tree is organized."
;; generated-autoload-load-name: "ede/linux"
;; End:
-;; arch-tag: 41f310c8-b169-4259-8a2d-0ff4bd0a736d
;;; ede/linux.el ends here
diff --git a/lisp/cedet/ede/locate.el b/lisp/cedet/ede/locate.el
index 79f6d636154..427b87d2bc0 100644
--- a/lisp/cedet/ede/locate.el
+++ b/lisp/cedet/ede/locate.el
@@ -1,6 +1,6 @@
;;; ede/locate.el --- Locate support
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -348,5 +348,4 @@ that created this EDE locate object."
;; generated-autoload-load-name: "ede/locate"
;; End:
-;; arch-tag: a04cb356-d11c-4f69-bd72-5a8a2aff708c
;;; ede/locate.el ends here
diff --git a/lisp/cedet/ede/make.el b/lisp/cedet/ede/make.el
index fc1e7cc8a15..1c1bcd47d75 100644
--- a/lisp/cedet/ede/make.el
+++ b/lisp/cedet/ede/make.el
@@ -1,6 +1,6 @@
;;; ede/make.el --- General information about "make"
-;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -105,5 +105,4 @@ If NOERROR is nil, then throw an error on failure. Return t otherwise."
;; generated-autoload-load-name: "ede/make"
;; End:
-;; arch-tag: cc54abdb-7ca5-4902-9735-eda3c6a77852
;;; ede/make.el ends here
diff --git a/lisp/cedet/ede/makefile-edit.el b/lisp/cedet/ede/makefile-edit.el
index 56c4c072364..63991c54e7f 100644
--- a/lisp/cedet/ede/makefile-edit.el
+++ b/lisp/cedet/ede/makefile-edit.el
@@ -1,6 +1,6 @@
;;; makefile-edit.el --- Makefile editing/scanning commands.
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -126,5 +126,4 @@ Return nil if it isn't a variable."
(provide 'ede/makefile-edit)
-;; arch-tag: aba26b5f-4306-40d9-b63c-84a9590ac986
;;; ede/makefile-edit.el ends here
diff --git a/lisp/cedet/ede/pconf.el b/lisp/cedet/ede/pconf.el
index 77299c7eb39..08fc98728e1 100644
--- a/lisp/cedet/ede/pconf.el
+++ b/lisp/cedet/ede/pconf.el
@@ -1,7 +1,6 @@
;;; ede/pconf.el --- configure.ac maintenance for EDE
-;;; Copyright (C) 1998, 1999, 2000, 2005, 2008, 2009, 2010, 2011
-;;; Free Software Foundation, Inc.
+;;; Copyright (C) 1998-2000, 2005, 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project
@@ -184,5 +183,4 @@ Results in --add-missing being passed to automake."
(provide 'ede/pconf)
-;; arch-tag: 8d514f68-2abe-4b35-8b4e-bea4fd0c3eab
;;; ede/pconf.el ends here
diff --git a/lisp/cedet/ede/pmake.el b/lisp/cedet/ede/pmake.el
index 45660566234..d78e95af27f 100644
--- a/lisp/cedet/ede/pmake.el
+++ b/lisp/cedet/ede/pmake.el
@@ -1,7 +1,6 @@
;;; ede-pmake.el --- EDE Generic Project Makefile code generator.
-;;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2005, 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make
@@ -479,7 +478,7 @@ These are removed with make clean."
(defmethod ede-proj-makefile-garbage-patterns ((this ede-proj-target))
"Return a list of patterns that are considered garbage to THIS.
These are removed with make clean."
- ;; Get the the source object from THIS, and use the specified garbage.
+ ;; Get the source object from THIS, and use the specified garbage.
(let ((src (ede-target-sourcecode this))
(garb nil))
(while src
@@ -565,10 +564,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 +689,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-archive.el b/lisp/cedet/ede/proj-archive.el
index 58499dfe8e1..23d3aa05000 100644
--- a/lisp/cedet/ede/proj-archive.el
+++ b/lisp/cedet/ede/proj-archive.el
@@ -1,6 +1,6 @@
;;; ede/proj-archive.el --- EDE Generic Project archive support
-;; Copyright (C) 1998, 1999, 2000, 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2001, 2009-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make
@@ -61,5 +61,4 @@ This makes sure that the archive is removed with 'make clean'."
(provide 'ede/proj-archive)
-;; arch-tag: a0b2cfe8-0d11-4a4f-8e47-ebfb11b6ac33
;;; ede/proj-archive.el ends here
diff --git a/lisp/cedet/ede/proj-aux.el b/lisp/cedet/ede/proj-aux.el
index 7d469fe0971..2a8f1de65e2 100644
--- a/lisp/cedet/ede/proj-aux.el
+++ b/lisp/cedet/ede/proj-aux.el
@@ -1,6 +1,6 @@
;;; ede/proj-aux.el --- EDE Generic Project auxiliary file support
-;; Copyright (C) 1998, 1999, 2000, 2007, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2000, 2007, 2009-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make
@@ -44,5 +44,4 @@
(provide 'ede/proj-aux)
-;; arch-tag: 668e96e0-2b30-474e-ba3c-9fa4fa696922
;;; ede/proj-aux.el ends here
diff --git a/lisp/cedet/ede/proj-comp.el b/lisp/cedet/ede/proj-comp.el
index 8757a6a1403..401ea15d0d6 100644
--- a/lisp/cedet/ede/proj-comp.el
+++ b/lisp/cedet/ede/proj-comp.el
@@ -1,6 +1,6 @@
;;; ede/proj-comp.el --- EDE Generic Project compiler/rule driver
-;; Copyright (C) 1999, 2000, 2001, 2004, 2005, 2007, 2009, 2010, 2011
+;; Copyright (C) 1999-2001, 2004-2005, 2007, 2009-2011
;; Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -355,5 +355,4 @@ compiler it decides to use after inserting in the rule."
(provide 'ede/proj-comp)
-;; arch-tag: ade67766-1a5d-467a-826a-93e95594d717
;;; ede/proj-comp.el ends here
diff --git a/lisp/cedet/ede/proj-elisp.el b/lisp/cedet/ede/proj-elisp.el
index 1182c41128c..42a20cc4a1a 100644
--- a/lisp/cedet/ede/proj-elisp.el
+++ b/lisp/cedet/ede/proj-elisp.el
@@ -1,7 +1,6 @@
;;; ede-proj-elisp.el --- EDE Generic Project Emacs Lisp support
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2005, 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make
@@ -129,18 +128,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 +244,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 +381,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/proj-info.el b/lisp/cedet/ede/proj-info.el
index da2264ffe8a..d943e609528 100644
--- a/lisp/cedet/ede/proj-info.el
+++ b/lisp/cedet/ede/proj-info.el
@@ -1,7 +1,6 @@
;;; ede-proj-info.el --- EDE Generic Project texinfo support
-;;; Copyright (C) 1998, 1999, 2000, 2001, 2004, 2007, 2008, 2009, 2010, 2011
-;;; Free Software Foundation, Inc.
+;;; Copyright (C) 1998-2001, 2004, 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make
@@ -183,5 +182,4 @@ files in the project."
(provide 'ede/proj-info)
-;; arch-tag: e4b7ce51-ae46-4d7c-a5fb-073f435cdcbf
;;; ede/proj-info.el ends here
diff --git a/lisp/cedet/ede/proj-misc.el b/lisp/cedet/ede/proj-misc.el
index 9b35d44daad..4d68e1544a7 100644
--- a/lisp/cedet/ede/proj-misc.el
+++ b/lisp/cedet/ede/proj-misc.el
@@ -1,7 +1,6 @@
;;; ede-proj-misc.el --- EDE Generic Project Emacs Lisp support
-;; Copyright (C) 1998, 1999, 2000, 2001, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1998-2001, 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make
@@ -93,5 +92,4 @@ All listed sources are included in the distribution.")
(provide 'ede/proj-misc)
-;; arch-tag: e5e5f8d2-9897-4a1b-8a29-5944ec5a892d
;;; ede/proj-misc.el ends here
diff --git a/lisp/cedet/ede/proj-obj.el b/lisp/cedet/ede/proj-obj.el
index 897f3731859..7e7d289a59a 100644
--- a/lisp/cedet/ede/proj-obj.el
+++ b/lisp/cedet/ede/proj-obj.el
@@ -1,7 +1,6 @@
;;; ede/proj-obj.el --- EDE Generic Project Object code generation support
-;;; Copyright (C) 1998, 1999, 2000, 2005, 2008, 2009, 2010, 2011
-;;; Free Software Foundation, Inc.
+;;; Copyright (C) 1998-2000, 2005, 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make
@@ -320,5 +319,4 @@ Optional argument MORESOURCE is not used."
(provide 'ede/proj-obj)
-;; arch-tag: f521b89f-1a3f-4910-ba81-65de3f421698
;;; ede/proj-obj.el ends here
diff --git a/lisp/cedet/ede/proj-prog.el b/lisp/cedet/ede/proj-prog.el
index e68606f33ab..f33f5327beb 100644
--- a/lisp/cedet/ede/proj-prog.el
+++ b/lisp/cedet/ede/proj-prog.el
@@ -1,7 +1,6 @@
;;; ede-proj-prog.el --- EDE Generic Project program support
-;; Copyright (C) 1998, 1999, 2000, 2001, 2005, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1998-2001, 2005, 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make
@@ -141,5 +140,4 @@ Optional COMMAND is the command to run in place of asking the user."
(provide 'ede/proj-prog)
-;; arch-tag: 0bfa9364-f385-4745-a846-462146a79a25
;;; ede/proj-prog.el ends here
diff --git a/lisp/cedet/ede/proj-scheme.el b/lisp/cedet/ede/proj-scheme.el
index e3d99129d31..6a08d4fadd1 100644
--- a/lisp/cedet/ede/proj-scheme.el
+++ b/lisp/cedet/ede/proj-scheme.el
@@ -1,6 +1,6 @@
;;; ede/proj-scheme.el --- EDE Generic Project scheme (guile) support
-;; Copyright (C) 1998, 1999, 2000, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2000, 2009-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make, scheme
@@ -46,5 +46,4 @@
(provide 'ede/proj-scheme)
-;; arch-tag: 451081e6-0d45-4560-9821-8ee03e8401ab
;;; ede/proj-scheme.el ends here
diff --git a/lisp/cedet/ede/proj-shared.el b/lisp/cedet/ede/proj-shared.el
index 2e422c640fb..ec514194e33 100644
--- a/lisp/cedet/ede/proj-shared.el
+++ b/lisp/cedet/ede/proj-shared.el
@@ -1,6 +1,6 @@
;;; ede-proj-shared.el --- EDE Generic Project shared library support
-;;; Copyright (C) 1998, 1999, 2000, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 1998-2000, 2009-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make
@@ -207,5 +207,4 @@ We need to override -program which has an LDADD element."
(provide 'ede/proj-shared)
-;; arch-tag: 05f22c3e-b269-4411-9425-65e8fe4ab74a
;;; ede/proj-shared.el ends here
diff --git a/lisp/cedet/ede/proj.el b/lisp/cedet/ede/proj.el
index 36a73e02e7c..40e6165251c 100644
--- a/lisp/cedet/ede/proj.el
+++ b/lisp/cedet/ede/proj.el
@@ -1,7 +1,6 @@
;;; ede/proj.el --- EDE Generic Project file driver
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1998-2003, 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make
@@ -676,5 +675,4 @@ Optional argument FORCE will force items to be regenerated."
(provide 'ede/proj)
-;; arch-tag: eb8a40f8-0d2c-41c4-b273-af04101d1cdf
;;; ede/proj.el ends here
diff --git a/lisp/cedet/ede/project-am.el b/lisp/cedet/ede/project-am.el
index c5042ca3a9a..88cf67e22ed 100644
--- a/lisp/cedet/ede/project-am.el
+++ b/lisp/cedet/ede/project-am.el
@@ -1,6 +1,6 @@
;;; project-am.el --- A project management scheme based on automake files.
-;; Copyright (C) 1998, 1999, 2000, 2003, 2005, 2007, 2008, 2009, 2010, 2011
+;; Copyright (C) 1998-2000, 2003, 2005, 2007-2011
;; Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -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)
@@ -1018,5 +1020,4 @@ per file or in .dir-locals.el or similar."
(provide 'ede/project-am)
-;; arch-tag: 528db935-f186-4240-b647-e305c5b784a2
;;; ede/project-am.el ends here
diff --git a/lisp/cedet/ede/shell.el b/lisp/cedet/ede/shell.el
index c13ce392da9..194b7285a0b 100644
--- a/lisp/cedet/ede/shell.el
+++ b/lisp/cedet/ede/shell.el
@@ -1,6 +1,6 @@
;;; ede/shell.el --- A shell controlled by EDE.
;;
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
;;
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -79,5 +79,4 @@ COMMAND is a text string representing the thing to be run."
;; generated-autoload-load-name: "ede/shell"
;; End:
-;; arch-tag: 71bb9dc4-ad1c-4ba3-a95e-531a90500ca9
;;; ede/shell.el ends here
diff --git a/lisp/cedet/ede/simple.el b/lisp/cedet/ede/simple.el
index 14b3a043a6d..8d77cea6529 100644
--- a/lisp/cedet/ede/simple.el
+++ b/lisp/cedet/ede/simple.el
@@ -1,6 +1,6 @@
;;; ede/simple.el --- Overlay an EDE structure on an existing project
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -117,5 +117,4 @@ Each directory needs a project file to control it.")
(provide 'ede/simple)
-;; arch-tag: a0c4264a-89ce-4364-afab-2512acd3b22a
;;; ede/simple.el ends here
diff --git a/lisp/cedet/ede/source.el b/lisp/cedet/ede/source.el
index fa555c13faf..e5dc12d064f 100644
--- a/lisp/cedet/ede/source.el
+++ b/lisp/cedet/ede/source.el
@@ -1,6 +1,6 @@
;; ede/source.el --- EDE source code object
-;; Copyright (C) 2000, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000, 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make
@@ -170,5 +170,4 @@ Used to guess header files, but uses the auxsource regular expression."
(provide 'ede/source)
-;; arch-tag: 60165fe2-920e-4adf-8531-25655388467d
;;; ede/source.el ends here
diff --git a/lisp/cedet/ede/speedbar.el b/lisp/cedet/ede/speedbar.el
index 11c3bd8b7e5..252ce47df67 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, 2011
-;;; Free Software Foundation, Inc.
+;; Copyright (C) 1998-2001, 2003, 2005, 2007-2011
+;; 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/ede/srecode.el b/lisp/cedet/ede/srecode.el
index 6cd288b534e..f7428bae04f 100644
--- a/lisp/cedet/ede/srecode.el
+++ b/lisp/cedet/ede/srecode.el
@@ -1,6 +1,6 @@
;;; ede/srecode.el --- EDE utilities on top of SRecoder
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -91,5 +91,4 @@ Note: Just like `srecode-insert', but templates found in 'ede app."
(provide 'ede/srecode)
-;; arch-tag: 75bec542-7cc8-41a4-b5a0-8fb247609f03
;;; ede/srecode.el ends here
diff --git a/lisp/cedet/ede/system.el b/lisp/cedet/ede/system.el
index e10e4686fd9..b69938af4ab 100644
--- a/lisp/cedet/ede/system.el
+++ b/lisp/cedet/ede/system.el
@@ -1,6 +1,6 @@
;;; ede-system.el --- EDE working with the system (VC, FTP, ETC)
-;; Copyright (C) 2001, 2002, 2003, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001-2003, 2009-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make, vc
@@ -143,5 +143,4 @@ Download tramp, and use /r:machine: for names on remote sites w/out FTP access."
;; generated-autoload-load-name: "ede/system"
;; End:
-;; arch-tag: a974ea44-151e-488b-b5d4-df2c05be6fe6
;;; ede/system.el ends here
diff --git a/lisp/cedet/ede/util.el b/lisp/cedet/ede/util.el
index 749fbd51fa1..fc4536ba88a 100644
--- a/lisp/cedet/ede/util.el
+++ b/lisp/cedet/ede/util.el
@@ -1,6 +1,6 @@
;;; ede/util.el --- EDE utilities
-;; Copyright (C) 2000, 2005, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000, 2005, 2009-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make
@@ -101,5 +101,4 @@ If BUFFER isn't specified, use the current buffer."
;; generated-autoload-load-name: "ede/util"
;; End:
-;; arch-tag: 3cddf449-7f6a-4c76-86dd-04142c60eba2
;;; ede/util.el ends here
diff --git a/lisp/cedet/inversion.el b/lisp/cedet/inversion.el
index 24f87ff3226..71960ddecd4 100644
--- a/lisp/cedet/inversion.el
+++ b/lisp/cedet/inversion.el
@@ -1,7 +1,6 @@
;;; inversion.el --- When you need something in version XX.XX
-;;; Copyright (C) 2002, 2003, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;;; Free Software Foundation, Inc.
+;;; Copyright (C) 2002-2003, 2005-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 0.2
@@ -538,5 +537,4 @@ The package should have VERSION available for download."
(provide 'inversion)
-;; arch-tag: 7239729c-3051-4d85-bb09-dcf92363aa3b
;;; inversion.el ends here
diff --git a/lisp/cedet/mode-local.el b/lisp/cedet/mode-local.el
index 9b87191ee19..d077dd95f3c 100644
--- a/lisp/cedet/mode-local.el
+++ b/lisp/cedet/mode-local.el
@@ -1,7 +1,6 @@
;;; mode-local.el --- Support for mode local facilities
;;
-;; Copyright (C) 2004, 2005, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2005, 2007-2011 Free Software Foundation, Inc.
;;
;; Author: David Ponce <david@dponce.com>
;; Maintainer: David Ponce <david@dponce.com>
diff --git a/lisp/cedet/pulse.el b/lisp/cedet/pulse.el
index f74cd5d2f3a..74dc1ecde31 100644
--- a/lisp/cedet/pulse.el
+++ b/lisp/cedet/pulse.el
@@ -1,6 +1,6 @@
;;; pulse.el --- Pulsing Overlays
-;;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
;; Version: 1.0
@@ -255,5 +255,4 @@ Only pulses the line if `pulse-command-advice-flag' is non-nil."
(provide 'pulse)
-;; arch-tag: 6e2f78c1-65b3-4164-a141-872cb1552959
;;; pulse.el ends here
diff --git a/lisp/cedet/semantic.el b/lisp/cedet/semantic.el
index 889b12da054..c899988dc36 100644
--- a/lisp/cedet/semantic.el
+++ b/lisp/cedet/semantic.el
@@ -1,7 +1,6 @@
;;; semantic.el --- Semantic buffer evaluator.
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: syntax tools
@@ -1153,5 +1152,4 @@ minor mode is enabled." t nil)
;; (require 'semantic/load)
-;; arch-tag: 31583e10-6508-41a9-be40-f83d0ae0a4ed
;;; semantic.el ends here
diff --git a/lisp/cedet/semantic/analyze.el b/lisp/cedet/semantic/analyze.el
index 2d4d551a1ad..5cdd1577a6e 100644
--- a/lisp/cedet/semantic/analyze.el
+++ b/lisp/cedet/semantic/analyze.el
@@ -1,7 +1,6 @@
;;; semantic/analyze.el --- Analyze semantic tags against local context
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2000-2005, 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -795,5 +794,4 @@ CONTEXT's content is described in `semantic-analyze-current-context'."
;; generated-autoload-load-name: "semantic/analyze"
;; End:
-;; arch-tag: 1102143a-1c05-4631-83e8-45aafc6b4a59
;;; semantic/analyze.el ends here
diff --git a/lisp/cedet/semantic/analyze/complete.el b/lisp/cedet/semantic/analyze/complete.el
index 66d923d5796..bbe87f34172 100644
--- a/lisp/cedet/semantic/analyze/complete.el
+++ b/lisp/cedet/semantic/analyze/complete.el
@@ -1,6 +1,6 @@
;;; semantic/analyze/complete.el --- Smart Completions
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -276,5 +276,4 @@ FLAGS can be any number of:
;; generated-autoload-load-name: "semantic/analyze/complete"
;; End:
-;; arch-tag: 97071c7e-2459-4e7a-8875-8cc5bbbc1f4d
;;; semantic/analyze/complete.el ends here
diff --git a/lisp/cedet/semantic/analyze/debug.el b/lisp/cedet/semantic/analyze/debug.el
index 6499f61781e..b02358b7243 100644
--- a/lisp/cedet/semantic/analyze/debug.el
+++ b/lisp/cedet/semantic/analyze/debug.el
@@ -1,6 +1,6 @@
;;; semantic/analyze/debug.el --- Debug the analyzer
-;;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
diff --git a/lisp/cedet/semantic/analyze/fcn.el b/lisp/cedet/semantic/analyze/fcn.el
index 9542c328997..eae6d013400 100644
--- a/lisp/cedet/semantic/analyze/fcn.el
+++ b/lisp/cedet/semantic/analyze/fcn.el
@@ -1,6 +1,6 @@
;;; semantic/analyze/fcn.el --- Analyzer support functions.
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -334,5 +334,4 @@ SCOPE is the current scope."
(provide 'semantic/analyze/fcn)
-;; arch-tag: 32525305-515e-4b96-ad11-216d3a99f829
;;; semantic/analyze/fcn.el ends here
diff --git a/lisp/cedet/semantic/analyze/refs.el b/lisp/cedet/semantic/analyze/refs.el
index 65cea0e52f3..9a4459f037f 100644
--- a/lisp/cedet/semantic/analyze/refs.el
+++ b/lisp/cedet/semantic/analyze/refs.el
@@ -1,6 +1,6 @@
;;; semantic/analyze/refs.el --- Analysis of the references between tags.
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -350,5 +350,4 @@ Only works for tags in the global namespace."
;; generated-autoload-load-name: "semantic/analyze/refs"
;; End:
-;; arch-tag: f8c59a91-1829-42b3-b083-437c6881841c
;;; semantic/analyze/refs.el ends here
diff --git a/lisp/cedet/semantic/bovine.el b/lisp/cedet/semantic/bovine.el
index 82f9108c2c7..1dfbb72d416 100644
--- a/lisp/cedet/semantic/bovine.el
+++ b/lisp/cedet/semantic/bovine.el
@@ -1,6 +1,6 @@
;;; semantic/bovine.el --- LL Parser/Analyzer core.
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2009, 2010, 2011
+;; Copyright (C) 1999-2004, 2006-2007, 2009-2011
;; Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -293,5 +293,4 @@ list of semantic tokens found."
;; generated-autoload-load-name: "semantic/bovine"
;; End:
-;; arch-tag: 1e820899-2a26-499a-b0c0-57301365a6b0
;;; semantic/bovine.el ends here
diff --git a/lisp/cedet/semantic/bovine/c-by.el b/lisp/cedet/semantic/bovine/c-by.el
index 0308ace619b..8e1fe8d3617 100644
--- a/lisp/cedet/semantic/bovine/c-by.el
+++ b/lisp/cedet/semantic/bovine/c-by.el
@@ -1,7 +1,6 @@
;;; semantic/bovine/c-by.el --- Generated parser support file
-;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
@@ -2194,5 +2193,4 @@
(provide 'semantic/bovine/c-by)
-;; arch-tag: 27da9f71-d2ef-473f-92a7-b0006b1a8491
;;; semantic/bovine/c-by.el ends here
diff --git a/lisp/cedet/semantic/bovine/c.el b/lisp/cedet/semantic/bovine/c.el
index 166543c73cb..0b3e6881891 100644
--- a/lisp/cedet/semantic/bovine/c.el
+++ b/lisp/cedet/semantic/bovine/c.el
@@ -1,7 +1,6 @@
;;; semantic/bovine/c.el --- Semantic details for C
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -94,8 +93,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 +1001,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 +1565,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 +1839,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 +1870,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/bovine/debug.el b/lisp/cedet/semantic/bovine/debug.el
index 7b2affe1515..9ca7409e335 100644
--- a/lisp/cedet/semantic/bovine/debug.el
+++ b/lisp/cedet/semantic/bovine/debug.el
@@ -1,6 +1,6 @@
;;; semantic/bovine/debug.el --- Debugger support for bovinator
-;; Copyright (C) 2003, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2009-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -144,5 +144,4 @@ Argument CONDITION is the thrown error condition."
(provide 'semantic/bovine/debug)
-;; arch-tag: d1bf98b3-faeb-4dc3-ac34-cac6264fd94e
;;; semantic/bovine/debug.el ends here
diff --git a/lisp/cedet/semantic/bovine/el.el b/lisp/cedet/semantic/bovine/el.el
index 62169156059..cfdd4cf6f6c 100644
--- a/lisp/cedet/semantic/bovine/el.el
+++ b/lisp/cedet/semantic/bovine/el.el
@@ -1,7 +1,6 @@
;;; semantic/bovine/el.el --- Semantic details for Emacs Lisp
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2005, 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -963,5 +962,4 @@ ELisp variables can be pretty long, so track this one too.")
(provide 'semantic/bovine/el)
-;; arch-tag: d634cbab-9610-4510-9fce-048ae1eb7aa6
;;; semantic/bovine/el.el ends here
diff --git a/lisp/cedet/semantic/bovine/gcc.el b/lisp/cedet/semantic/bovine/gcc.el
index 8c1f6f52f19..acbbb13170e 100644
--- a/lisp/cedet/semantic/bovine/gcc.el
+++ b/lisp/cedet/semantic/bovine/gcc.el
@@ -1,6 +1,6 @@
;;; semantic/bovine/gcc.el --- gcc querying special code for the C parser
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -221,5 +221,4 @@ It should also include other symbols GCC was compiled with.")
;; generated-autoload-load-name: "semantic/bovine/gcc"
;; End:
-;; arch-tag: 7086f4a0-1ce8-48e2-9783-d750d3765186
;;; semantic/bovine/gcc.el ends here
diff --git a/lisp/cedet/semantic/bovine/make-by.el b/lisp/cedet/semantic/bovine/make-by.el
index 1db454f6ea8..3cc4e5b23a3 100644
--- a/lisp/cedet/semantic/bovine/make-by.el
+++ b/lisp/cedet/semantic/bovine/make-by.el
@@ -1,7 +1,6 @@
;;; semantic/bovine/make-by.el --- Generated parser support file
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1999-2004, 2008-2011 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
@@ -384,5 +383,4 @@
(provide 'semantic/bovine/make-by)
-;; arch-tag: 8c3749b8-7b19-46e0-af01-2a4d02fd0352
;;; semantic/bovine/make-by.el ends here
diff --git a/lisp/cedet/semantic/bovine/make.el b/lisp/cedet/semantic/bovine/make.el
index d51f9e21401..e132b48441a 100644
--- a/lisp/cedet/semantic/bovine/make.el
+++ b/lisp/cedet/semantic/bovine/make.el
@@ -1,7 +1,6 @@
;;; semantic/bovine/make.el --- Makefile parsing rules.
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2000-2004, 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -238,5 +237,4 @@ Uses default implementation, and also gets a list of filenames."
;; generated-autoload-load-name: "semantic/bovine/make"
;; End:
-;; arch-tag: 8122d1f5-d4b7-4f6e-b909-d61ac65ef118
;;; semantic/bovine/make.el ends here
diff --git a/lisp/cedet/semantic/bovine/scm-by.el b/lisp/cedet/semantic/bovine/scm-by.el
index ac8211bfc8c..87efe747a4c 100644
--- a/lisp/cedet/semantic/bovine/scm-by.el
+++ b/lisp/cedet/semantic/bovine/scm-by.el
@@ -1,6 +1,6 @@
;;; semantic-scm-by.el --- Generated parser support file
-;; Copyright (C) 2001, 2003, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2003, 2009-2011 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
@@ -188,5 +188,4 @@
(provide 'semantic/bovine/scm-by)
-;; arch-tag: 945749cc-a039-434f-bf95-bf2480a506c3
;;; semantic/bovine/scm-by.el ends here
diff --git a/lisp/cedet/semantic/bovine/scm.el b/lisp/cedet/semantic/bovine/scm.el
index 92b61129fb5..0bdd8722db1 100644
--- a/lisp/cedet/semantic/bovine/scm.el
+++ b/lisp/cedet/semantic/bovine/scm.el
@@ -1,7 +1,6 @@
;;; semantic/bovine/scm.el --- Semantic details for Scheme (guile)
-;;; Copyright (C) 2001, 2002, 2003, 2004, 2008, 2009, 2010, 2011
-;;; Free Software Foundation, Inc.
+;;; Copyright (C) 2001-2004, 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -115,5 +114,4 @@ syntax as specified by the syntax table."
;; generated-autoload-load-name: "semantic/bovine/scm"
;; End:
-;; arch-tag: 4f929838-b817-447d-848c-d47789ff140f
;;; semantic/bovine/scm.el ends here
diff --git a/lisp/cedet/semantic/chart.el b/lisp/cedet/semantic/chart.el
index f4d08a7c6ce..1c08cb04d15 100644
--- a/lisp/cedet/semantic/chart.el
+++ b/lisp/cedet/semantic/chart.el
@@ -1,6 +1,6 @@
;;; semantic/chart.el --- Utilities for use with semantic tag tables
-;; Copyright (C) 1999, 2000, 2001, 2003, 2005, 2008, 2009, 2010, 2011
+;; Copyright (C) 1999-2001, 2003, 2005, 2008-2011
;; Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -171,5 +171,4 @@ items are charted. TAGTABLE is passed to
(provide 'semantic/chart)
-;; arch-tag: 026573b1-f4f1-4dda-ae77-b6451283ff23
;;; semantic/chart.el ends here
diff --git a/lisp/cedet/semantic/complete.el b/lisp/cedet/semantic/complete.el
index 13947970efd..18c7b5a1a50 100644
--- a/lisp/cedet/semantic/complete.el
+++ b/lisp/cedet/semantic/complete.el
@@ -1,7 +1,6 @@
;;; semantic/complete.el --- Routines for performing tag completion
-;; Copyright (C) 2003, 2004, 2005, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2003-2005, 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: syntax
@@ -1826,7 +1825,7 @@ HISTORY is a symbol representing a variable to store the history in."
initial-input
history)
"Ask for a tag by name from the local type members.
-Available tags are from the the current scope.
+Available tags are from the current scope.
Completion options are presented in a traditional way, with highlighting
to resolve same-name collisions.
PROMPT is a string to prompt with.
@@ -2159,5 +2158,4 @@ use `semantic-complete-analyze-inline' to complete."
;; generated-autoload-load-name: "semantic/complete"
;; End:
-;; arch-tag: a07c8f71-e53b-416e-9704-3a99ef101b09
;;; semantic/complete.el ends here
diff --git a/lisp/cedet/semantic/ctxt.el b/lisp/cedet/semantic/ctxt.el
index 2608dfb0927..08049201756 100644
--- a/lisp/cedet/semantic/ctxt.el
+++ b/lisp/cedet/semantic/ctxt.el
@@ -1,7 +1,6 @@
;;; semantic/ctxt.el --- Context calculations for Semantic tools.
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: syntax
@@ -619,5 +618,4 @@ means that the first symbol might be:
;; generated-autoload-load-name: "semantic/ctxt"
;; End:
-;; arch-tag: 04f3ae3c-78bb-40ca-b112-ba77f5e4ea88
;;; semantic/ctxt.el ends here
diff --git a/lisp/cedet/semantic/db-debug.el b/lisp/cedet/semantic/db-debug.el
index 09e7064069f..7d1abe11dd1 100644
--- a/lisp/cedet/semantic/db-debug.el
+++ b/lisp/cedet/semantic/db-debug.el
@@ -1,6 +1,6 @@
;;; semantic/db-debug.el --- Extra level debugging routines for Semantic
-;;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -107,5 +107,4 @@
(provide 'semantic/db-debug)
-;; arch-tag: 9bdc11bd-fb76-4a32-9545-78ed143b7184
;;; semantic/db-debug.el ends here
diff --git a/lisp/cedet/semantic/db-ebrowse.el b/lisp/cedet/semantic/db-ebrowse.el
index e931c40aff6..d719fde3174 100644
--- a/lisp/cedet/semantic/db-ebrowse.el
+++ b/lisp/cedet/semantic/db-ebrowse.el
@@ -1,7 +1,6 @@
;;; semantic/db-ebrowse.el --- Semanticdb backend using ebrowse.
-;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2005-2011 Free Software Foundation, Inc.
;; Authors: Eric M. Ludlam <zappo@gnu.org>
;; Joakim Verona
@@ -661,5 +660,4 @@ Return a list of tags."
(provide 'semantic/db-ebrowse)
-;; arch-tag: e7d15223-6074-4c87-baf0-98fdd22ff873
;;; semantic/db-ebrowse.el ends here
diff --git a/lisp/cedet/semantic/db-el.el b/lisp/cedet/semantic/db-el.el
index c842ff61d73..0cbff54fd1d 100644
--- a/lisp/cedet/semantic/db-el.el
+++ b/lisp/cedet/semantic/db-el.el
@@ -1,7 +1,6 @@
;;; semantic/db-el.el --- Semantic database extensions for Emacs Lisp
-;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;;; Free Software Foundation, Inc.
+;;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: tags
@@ -343,5 +342,4 @@ Return a list of tags."
(provide 'semantic/db-el)
-;; arch-tag: e54f556e-fa3f-4bc5-9b15-744a659a6e65
;;; semantic/db-el.el ends here
diff --git a/lisp/cedet/semantic/db-file.el b/lisp/cedet/semantic/db-file.el
index 35281c51903..661bc8d6841 100644
--- a/lisp/cedet/semantic/db-file.el
+++ b/lisp/cedet/semantic/db-file.el
@@ -1,7 +1,6 @@
;;; semantic/db-file.el --- Save a semanticdb to a cache file.
-;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010, 2011
-;;; Free Software Foundation, Inc.
+;;; Copyright (C) 2000-2005, 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: tags
@@ -452,5 +451,4 @@ Optional NOERROR prevents errors from being displayed."
;; generated-autoload-load-name: "semantic/db-file"
;; End:
-;; arch-tag: f4a0d9de-6c25-4bf3-aff3-a10c58fd575d
;;; semantic/db-file.el ends here
diff --git a/lisp/cedet/semantic/db-find.el b/lisp/cedet/semantic/db-find.el
index 47182bd8a0f..a7335d642be 100644
--- a/lisp/cedet/semantic/db-find.el
+++ b/lisp/cedet/semantic/db-find.el
@@ -1,7 +1,6 @@
;;; semantic/db-find.el --- Searching through semantic databases.
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: tags
@@ -1369,5 +1368,4 @@ Return a table of all matching tags."
;; generated-autoload-load-name: "semantic/db-find"
;; End:
-;; arch-tag: 5d4162f5-5092-46d7-beed-55c78aab4116
;;; semantic/db-find.el ends here
diff --git a/lisp/cedet/semantic/db-global.el b/lisp/cedet/semantic/db-global.el
index ddcfde86689..7f3d616203e 100644
--- a/lisp/cedet/semantic/db-global.el
+++ b/lisp/cedet/semantic/db-global.el
@@ -1,7 +1,6 @@
;;; semantic/db-global.el --- Semantic database extensions for GLOBAL
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2006, 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: tags
@@ -220,5 +219,4 @@ Like `semanticdb-find-tags-for-completion-method' for global."
;; generated-autoload-load-name: "semantic/db-global"
;; End:
-;; arch-tag: ec0edab2-26c2-438f-a3d2-0d953364f8cc
;;; semantic/db-global.el ends here
diff --git a/lisp/cedet/semantic/db-javascript.el b/lisp/cedet/semantic/db-javascript.el
index 40b49195d8e..213216cee1a 100644
--- a/lisp/cedet/semantic/db-javascript.el
+++ b/lisp/cedet/semantic/db-javascript.el
@@ -1,7 +1,6 @@
;;; semantic/db-javascript.el --- Semantic database extensions for javascript
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Joakim Verona
@@ -307,5 +306,4 @@ Return a list of tags."
(provide 'semantic/db-javascript)
-;; arch-tag: 69cf8ad1-7ea9-41af-851c-41f24c873374
;;; semantic/db-javascript.el ends here
diff --git a/lisp/cedet/semantic/db-mode.el b/lisp/cedet/semantic/db-mode.el
index bbe117a25a0..8b656592603 100644
--- a/lisp/cedet/semantic/db-mode.el
+++ b/lisp/cedet/semantic/db-mode.el
@@ -1,6 +1,6 @@
;;; semantic/db-mode.el --- Semanticdb Minor Mode
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -217,5 +217,4 @@ Argument NEW-TABLE is the new table of tags."
;; generated-autoload-load-name: "semantic/db-mode"
;; End:
-;; arch-tag: f5da903d-2d34-4adf-8572-e60340e1ad59
;;; semantic/db-mode.el ends here
diff --git a/lisp/cedet/semantic/db-ref.el b/lisp/cedet/semantic/db-ref.el
index 0ca49510d36..6f5489ef7ef 100644
--- a/lisp/cedet/semantic/db-ref.el
+++ b/lisp/cedet/semantic/db-ref.el
@@ -1,6 +1,6 @@
;;; semantic/db-ref.el --- Handle cross-db file references
-;;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -171,5 +171,4 @@ refreshed before dumping the result."
(provide 'semantic/db-ref)
-;; arch-tag: bea73e70-dbbe-4c30-a58d-289dc3a40172
;;; semantic/db-ref.el ends here
diff --git a/lisp/cedet/semantic/db-typecache.el b/lisp/cedet/semantic/db-typecache.el
index b4308674b81..2a78576092a 100644
--- a/lisp/cedet/semantic/db-typecache.el
+++ b/lisp/cedet/semantic/db-typecache.el
@@ -1,6 +1,6 @@
;;; db-typecache.el --- Manage Datatypes
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -622,5 +622,4 @@ If there isn't one, create it.
;; generated-autoload-load-name: "semantic/db-typecache"
;; End:
-;; arch-tag: cd7c37a8-2006-4ead-a037-977ffe7e7624
;;; semanticdb-typecache.el ends here
diff --git a/lisp/cedet/semantic/db.el b/lisp/cedet/semantic/db.el
index 1d54d2df4fb..fa8de392b62 100644
--- a/lisp/cedet/semantic/db.el
+++ b/lisp/cedet/semantic/db.el
@@ -1,7 +1,6 @@
;;; semantic/db.el --- Semantic tag database manager
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: tags
@@ -1040,5 +1039,4 @@ If file does not have tags available, then load the file, and create them."
;; generated-autoload-load-name: "semantic/db"
;; End:
-;; arch-tag: d9f75280-737d-494f-9f70-09a649d27433
;;; semantic/db.el ends here
diff --git a/lisp/cedet/semantic/debug.el b/lisp/cedet/semantic/debug.el
index 2271c602b09..ecab73a80dc 100644
--- a/lisp/cedet/semantic/debug.el
+++ b/lisp/cedet/semantic/debug.el
@@ -1,6 +1,6 @@
;;; semantic/debug.el --- Language Debugger framework
-;; Copyright (C) 2003, 2004, 2005, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003-2005, 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -566,5 +566,4 @@ A frame is of the form:
;; generated-autoload-load-name: "semantic/debug"
;; End:
-;; arch-tag: 6f189d2d-8a65-45a5-a7f0-9894625eb860
;;; semantic/debug.el ends here
diff --git a/lisp/cedet/semantic/decorate.el b/lisp/cedet/semantic/decorate.el
index 8690e08806a..ee356ad3a9e 100644
--- a/lisp/cedet/semantic/decorate.el
+++ b/lisp/cedet/semantic/decorate.el
@@ -1,6 +1,6 @@
;;; semantic/decorate.el --- Utilities for decorating/highlighting tokens.
-;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2005, 2006, 2007, 2009, 2010, 2011
+;;; Copyright (C) 1999-2003, 2005-2007, 2009-2011
;;; Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -296,5 +296,4 @@ OVERLAY is passed in by isearch."
(provide 'semantic/decorate)
-;; arch-tag: 30e5b6cb-dba0-41cd-920a-bc1dce267ad8
;;; semantic/decorate.el ends here
diff --git a/lisp/cedet/semantic/decorate/include.el b/lisp/cedet/semantic/decorate/include.el
index af4e4463fd1..0e0a8849d78 100644
--- a/lisp/cedet/semantic/decorate/include.el
+++ b/lisp/cedet/semantic/decorate/include.el
@@ -1,6 +1,6 @@
;;; semantic/decorate/include.el --- Decoration modes for include statements
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -773,5 +773,4 @@ If TABLE is not in a buffer, do nothing."
;; generated-autoload-load-name: "semantic/decorate/include"
;; End:
-;; arch-tag: c3277137-be3f-43e2-af89-3b14b9bd7479
;;; semantic/decorate/include.el ends here
diff --git a/lisp/cedet/semantic/decorate/mode.el b/lisp/cedet/semantic/decorate/mode.el
index cfe5d407eee..ea4df472afd 100644
--- a/lisp/cedet/semantic/decorate/mode.el
+++ b/lisp/cedet/semantic/decorate/mode.el
@@ -1,7 +1,6 @@
;;; semantic/decorate/mode.el --- Minor mode for decorating tags
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2005, 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: syntax
@@ -224,46 +223,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 +267,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 +276,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.
@@ -564,5 +519,4 @@ Use a primary decoration."
;; generated-autoload-load-name: "semantic/decorate/mode"
;; End:
-;; arch-tag: c1ac7888-e323-4467-96d6-18eb2820ed58
;;; semantic/decorate/mode.el ends here
diff --git a/lisp/cedet/semantic/dep.el b/lisp/cedet/semantic/dep.el
index 03a0a2b099e..e47f82f391f 100644
--- a/lisp/cedet/semantic/dep.el
+++ b/lisp/cedet/semantic/dep.el
@@ -1,6 +1,6 @@
;;; semantic/dep.el --- Methods for tracking dependencies (include files)
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: syntax
@@ -231,5 +231,4 @@ provided mode, not from the current major mode."
;; generated-autoload-load-name: "semantic/dep"
;; End:
-;; arch-tag: f6975d6a-845f-44c5-9a22-5dfeee46dce2
;;; semantic/dep.el ends here
diff --git a/lisp/cedet/semantic/doc.el b/lisp/cedet/semantic/doc.el
index c19b1e39bb1..e5579d09113 100644
--- a/lisp/cedet/semantic/doc.el
+++ b/lisp/cedet/semantic/doc.el
@@ -1,7 +1,6 @@
;;; semantic/doc.el --- Routines for documentation strings
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2005, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1999-2003, 2005, 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: syntax
@@ -127,5 +126,4 @@ If NOSNARF is 'lex, then return the lex token."
;; generated-autoload-load-name: "semantic/doc"
;; End:
-;; arch-tag: fe6e965b-4a81-4304-aab8-22ca113194ca
;;; semantic/doc.el ends here
diff --git a/lisp/cedet/semantic/ede-grammar.el b/lisp/cedet/semantic/ede-grammar.el
index 8623998cc30..a4361053174 100644
--- a/lisp/cedet/semantic/ede-grammar.el
+++ b/lisp/cedet/semantic/ede-grammar.el
@@ -1,6 +1,6 @@
;;; semantic/ede-grammar.el --- EDE support for Semantic Grammar Files
-;;; Copyright (C) 2003, 2004, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003-2004, 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make
@@ -133,11 +133,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 +194,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/edit.el b/lisp/cedet/semantic/edit.el
index f9fe4282188..7f7e82a95c2 100644
--- a/lisp/cedet/semantic/edit.el
+++ b/lisp/cedet/semantic/edit.el
@@ -1,7 +1,6 @@
;;; semantic/edit.el --- Edit Management for Semantic
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -966,5 +965,4 @@ lost if not transferred into NEWTAG."
;; generated-autoload-load-name: "semantic/edit"
;; End:
-;; arch-tag: 91c7fbf0-a418-4220-a90a-b58c74b450e3
;;; semantic/edit.el ends here
diff --git a/lisp/cedet/semantic/find.el b/lisp/cedet/semantic/find.el
index 207c8b05619..c62ed818945 100644
--- a/lisp/cedet/semantic/find.el
+++ b/lisp/cedet/semantic/find.el
@@ -1,7 +1,6 @@
;;; semantic/find.el --- Search routines for Semantic
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1999-2005, 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: syntax
@@ -700,5 +699,4 @@ details are available of findable."
;; generated-autoload-load-name: "semantic/find"
;; End:
-;; arch-tag: db00c93e-e561-4bd6-942b-96eca5aaa9a6
;;; semantic/find.el ends here
diff --git a/lisp/cedet/semantic/format.el b/lisp/cedet/semantic/format.el
index 2f1bfdbed85..fa6e7517624 100644
--- a/lisp/cedet/semantic/format.el
+++ b/lisp/cedet/semantic/format.el
@@ -1,7 +1,6 @@
;;; semantic/format.el --- Routines for formatting tags
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2005, 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: syntax
@@ -720,5 +719,4 @@ Optional argument COLOR means highlight the prototype with font-lock colors."
;; generated-autoload-load-name: "semantic/format"
;; End:
-;; arch-tag: deae500e-20b6-437e-8856-884f6c46bc3e
;;; semantic/format.el ends here
diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el
index 5e0eac28a37..ca3015c5941 100644
--- a/lisp/cedet/semantic/fw.el
+++ b/lisp/cedet/semantic/fw.el
@@ -1,7 +1,6 @@
;;; semantic/fw.el --- Framework for Semantic
-;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -395,5 +394,4 @@ FILE, NOWARN, RAWFILE, and WILDCARDS are passed into `find-file-noselect'"
(provide 'semantic/fw)
-;; arch-tag: e7eeffbf-112b-4665-92fc-5f69479ca2c4
;;; semantic/fw.el ends here
diff --git a/lisp/cedet/semantic/grammar-wy.el b/lisp/cedet/semantic/grammar-wy.el
index 58f7f9900e2..acaad49f6af 100644
--- a/lisp/cedet/semantic/grammar-wy.el
+++ b/lisp/cedet/semantic/grammar-wy.el
@@ -1,6 +1,6 @@
;;; semantic/grammar-wy.el --- Generated parser support file
-;; Copyright (C) 2002, 2003, 2004, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2004, 2009-2011 Free Software Foundation, Inc.
;; Author: David Ponce <david@dponce.com>
;; Keywords: syntax
@@ -475,5 +475,4 @@
(provide 'semantic/grammar-wy)
-;; arch-tag: dd050eb7-84a8-421c-b734-478dd2bd55bc
;;; semantic/grammar-wy.el ends here
diff --git a/lisp/cedet/semantic/grammar.el b/lisp/cedet/semantic/grammar.el
index 182a2f7978f..270668e2959 100644
--- a/lisp/cedet/semantic/grammar.el
+++ b/lisp/cedet/semantic/grammar.el
@@ -1,7 +1,6 @@
;;; semantic/grammar.el --- Major mode framework for Semantic grammars
-;; Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2005, 2007-2011 Free Software Foundation, Inc.
;; Author: David Ponce <david@dponce.com>
;; Maintainer: David Ponce <david@dponce.com>
@@ -248,10 +247,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 +1893,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/html.el b/lisp/cedet/semantic/html.el
index 7da4d409ff2..80c0a0ddb95 100644
--- a/lisp/cedet/semantic/html.el
+++ b/lisp/cedet/semantic/html.el
@@ -1,6 +1,6 @@
;;; semantic/html.el --- Semantic details for html files
-;; Copyright (C) 2004, 2005, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2004-2005, 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -262,5 +262,4 @@ tag with greater section value than LEVEL is found."
;; generated-autoload-load-name: "semantic/html"
;; End:
-;; arch-tag: 2a088b99-4585-46d5-bce8-3a5a8ec5eb2e
;;; semantic/html.el ends here
diff --git a/lisp/cedet/semantic/ia-sb.el b/lisp/cedet/semantic/ia-sb.el
index 0e9c6456ac3..57067936a90 100644
--- a/lisp/cedet/semantic/ia-sb.el
+++ b/lisp/cedet/semantic/ia-sb.el
@@ -1,7 +1,6 @@
;;; semantic/ia-sb.el --- Speedbar analysis display interactor
-;;; Copyright (C) 2002, 2003, 2004, 2006, 2008, 2009, 2010, 2011
-;;; Free Software Foundation, Inc.
+;;; Copyright (C) 2002-2004, 2006, 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: syntax
@@ -367,5 +366,4 @@ TEXT TAG and INDENT are the details."
;; generated-autoload-load-name: "semantic/ia-sb"
;; End:
-;; arch-tag: 4ab9f509-6978-415f-9938-9266edad9886
;;; semantic/ia-sb.el ends here
diff --git a/lisp/cedet/semantic/ia.el b/lisp/cedet/semantic/ia.el
index feb6abe5ee1..69b1dba0bcf 100644
--- a/lisp/cedet/semantic/ia.el
+++ b/lisp/cedet/semantic/ia.el
@@ -1,7 +1,6 @@
;;; semantic/ia.el --- Interactive Analysis functions
-;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: syntax
@@ -445,5 +444,4 @@ parts of the parent classes are displayed."
;; generated-autoload-load-name: "semantic/ia"
;; End:
-;; arch-tag: ceeed1f2-e5b6-4f7c-a85a-a2f8ee0193ca
;;; semantic/ia.el ends here
diff --git a/lisp/cedet/semantic/idle.el b/lisp/cedet/semantic/idle.el
index 4d93a5c4a3c..f17a5471d75 100644
--- a/lisp/cedet/semantic/idle.el
+++ b/lisp/cedet/semantic/idle.el
@@ -1,7 +1,6 @@
;;; idle.el --- Schedule parsing tasks in idle time
-;; Copyright (C) 2003, 2004, 2005, 2006, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2003-2006, 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: syntax
@@ -129,16 +128,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 +157,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 +169,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 +557,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 +584,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 +595,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 +760,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 +773,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 +899,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
@@ -1392,5 +1314,4 @@ mouse-3: popup context menu"
;; generated-autoload-load-name: "semantic/idle"
;; End:
-;; arch-tag: 4bfd54da-5023-4cc1-91ae-e1fefc1a8d1b
;;; semantic-idle.el ends here
diff --git a/lisp/cedet/semantic/imenu.el b/lisp/cedet/semantic/imenu.el
index e652d5bfdaa..e7e1da55ce3 100644
--- a/lisp/cedet/semantic/imenu.el
+++ b/lisp/cedet/semantic/imenu.el
@@ -1,6 +1,6 @@
;;; semantic/imenu.el --- Use Semantic as an imenu tag generator
-;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2010, 2011
+;;; Copyright (C) 2000-2005, 2007-2008, 2010-2011
;; Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
diff --git a/lisp/cedet/semantic/java.el b/lisp/cedet/semantic/java.el
index 53e3f14f6c6..71a205386db 100644
--- a/lisp/cedet/semantic/java.el
+++ b/lisp/cedet/semantic/java.el
@@ -1,7 +1,6 @@
;;; semantic/java.el --- Semantic functions for Java
-;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: David Ponce <david@dponce.com>
@@ -459,5 +458,4 @@ removed from the result list."
(provide 'semantic/java)
-;; arch-tag: ca14cb88-9343-48a9-9aa0-14d05be8d49f
;;; semantic/java.el ends here
diff --git a/lisp/cedet/semantic/lex-spp.el b/lisp/cedet/semantic/lex-spp.el
index 9c4d4ecff15..de4cb7a9c62 100644
--- a/lisp/cedet/semantic/lex-spp.el
+++ b/lisp/cedet/semantic/lex-spp.el
@@ -1,6 +1,6 @@
;;; lex-spp.el --- Semantic Lexical Pre-processor
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -1230,5 +1230,4 @@ If BUFFER is not provided, use the current buffer."
;; generated-autoload-load-name: "semantic/lex-spp"
;; End:
-;; arch-tag: 8877d83e-07ea-4d86-a960-e3562138d8a5
;;; semantic-lex-spp.el ends here
diff --git a/lisp/cedet/semantic/lex.el b/lisp/cedet/semantic/lex.el
index cc7a9ca8885..d6b8e1a8bf5 100644
--- a/lisp/cedet/semantic/lex.el
+++ b/lisp/cedet/semantic/lex.el
@@ -1,7 +1,6 @@
;;; semantic/lex.el --- Lexical Analyzer builder
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -1427,10 +1426,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 +1806,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 +1993,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 +2042,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 bdb21adf12b..47915e8ad58 100644
--- a/lisp/cedet/semantic/mru-bookmark.el
+++ b/lisp/cedet/semantic/mru-bookmark.el
@@ -1,6 +1,6 @@
;;; semantic/mru-bookmark.el --- Automatic bookmark tracking
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -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
;;
@@ -432,5 +401,4 @@ Useful for debugging mrub problems."
;; generated-autoload-load-name: "semantic/mru-bookmark"
;; End:
-;; arch-tag: 297fa190-2942-460b-941d-f117db4e1fbf
;;; semantic/mru-bookmark.el ends here
diff --git a/lisp/cedet/semantic/sb.el b/lisp/cedet/semantic/sb.el
index b6efb030947..88b0cc33d43 100644
--- a/lisp/cedet/semantic/sb.el
+++ b/lisp/cedet/semantic/sb.el
@@ -1,7 +1,6 @@
;;; semantic/sb.el --- Semantic tag display for speedbar
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: syntax
@@ -416,5 +415,4 @@ Returns the tag list, or t for an error."
(provide 'semantic/sb)
-;; arch-tag: 82aa0570-9e27-41a3-a834-2641dbb2f829
;;; semantic/sb.el ends here
diff --git a/lisp/cedet/semantic/scope.el b/lisp/cedet/semantic/scope.el
index 8e121264d6f..78a1fd049f0 100644
--- a/lisp/cedet/semantic/scope.el
+++ b/lisp/cedet/semantic/scope.el
@@ -1,6 +1,6 @@
;;; semantic/scope.el --- Analyzer Scope Calculations
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -814,5 +814,4 @@ hits in order, with the first tag being in the closest scope."
;; generated-autoload-load-name: "semantic/scope"
;; End:
-;; arch-tag: 056ab514-3e28-4d6e-84ed-9283dce5a01e
;;; semantic/scope.el ends here
diff --git a/lisp/cedet/semantic/senator.el b/lisp/cedet/semantic/senator.el
index fd2989adbeb..5399d4d5649 100644
--- a/lisp/cedet/semantic/senator.el
+++ b/lisp/cedet/semantic/senator.el
@@ -1,7 +1,6 @@
;;; semantic/senator.el --- SEmantic NAvigaTOR
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Author: David Ponce <david@dponce.com>
;; Maintainer: FSF
@@ -861,5 +860,4 @@ Use a senator search function when semantic isearch mode is enabled."
;; generated-autoload-load-name: "semantic/senator"
;; End:
-;; arch-tag: 397100d0-e2db-467e-8c19-d8d4d99d51f1
;;; semantic/senator.el ends here
diff --git a/lisp/cedet/semantic/sort.el b/lisp/cedet/semantic/sort.el
index 9ac87187c9b..d62c3bb17d9 100644
--- a/lisp/cedet/semantic/sort.el
+++ b/lisp/cedet/semantic/sort.el
@@ -1,7 +1,6 @@
;;; sort.el --- Utilities for sorting and re-arranging tag tables.
-;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
-;;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 1999-2005, 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: syntax
@@ -566,5 +565,4 @@ See `semantic-tag-external-class' for details."
;; generated-autoload-load-name: "semantic/sort"
;; End:
-;; arch-tag: 9231c8e7-ac7f-4b35-9302-651a02e5fef0
;;; semantic-sort.el ends here
diff --git a/lisp/cedet/semantic/symref.el b/lisp/cedet/semantic/symref.el
index 60ad734f84f..61006802c0d 100644
--- a/lisp/cedet/semantic/symref.el
+++ b/lisp/cedet/semantic/symref.el
@@ -1,6 +1,6 @@
;;; semantic/symref.el --- Symbol Reference API
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -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 ed11b473d6c..b74b0501c28 100644
--- a/lisp/cedet/semantic/symref/cscope.el
+++ b/lisp/cedet/semantic/symref/cscope.el
@@ -1,6 +1,6 @@
;;; semantic/symref/cscope.el --- Semantic-symref support via cscope.
-;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -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/symref/filter.el b/lisp/cedet/semantic/symref/filter.el
index 068f8595126..1676e0764d9 100644
--- a/lisp/cedet/semantic/symref/filter.el
+++ b/lisp/cedet/semantic/symref/filter.el
@@ -1,6 +1,6 @@
;;; semantic/symref/filter.el --- Filter symbol reference hits for accuracy.
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -137,5 +137,4 @@ Depends on the SRecode Field editing API."
(provide 'semantic/symref/filter)
-;; arch-tag: 14b9e795-02bf-408b-b375-c3f8ff6a4e38
;;; semantic/symref/filter.el ends here
diff --git a/lisp/cedet/semantic/symref/global.el b/lisp/cedet/semantic/symref/global.el
index 7658ed7db09..5af42a96581 100644
--- a/lisp/cedet/semantic/symref/global.el
+++ b/lisp/cedet/semantic/symref/global.el
@@ -1,6 +1,6 @@
;;; semantic/symref/global.el --- Use GNU Global for symbol references
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -70,5 +70,4 @@ Moves cursor to end of the match."
;; generated-autoload-load-name: "semantic/symref/global"
;; End:
-;; arch-tag: 1f061cc0-d8dd-44b1-9de3-3d00cb6e8abe
;;; semantic/symref/global.el ends here
diff --git a/lisp/cedet/semantic/symref/grep.el b/lisp/cedet/semantic/symref/grep.el
index f7f1834a59f..1571622b29a 100644
--- a/lisp/cedet/semantic/symref/grep.el
+++ b/lisp/cedet/semantic/symref/grep.el
@@ -1,6 +1,6 @@
;;; semantic/symref/grep.el --- Symref implementation using find/grep
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -187,5 +187,4 @@ Moves cursor to end of the match."
;; generated-autoload-load-name: "semantic/symref/grep"
;; End:
-;; arch-tag: 43d4469d-963c-4094-ac6f-99f7490973ce
;;; semantic/symref/grep.el ends here
diff --git a/lisp/cedet/semantic/symref/idutils.el b/lisp/cedet/semantic/symref/idutils.el
index b859db073ee..6098f0265ef 100644
--- a/lisp/cedet/semantic/symref/idutils.el
+++ b/lisp/cedet/semantic/symref/idutils.el
@@ -1,6 +1,6 @@
;;; semantic/symref/idutils.el --- Symref implementation for idutils
-;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -72,5 +72,4 @@ Moves cursor to end of the match."
;; generated-autoload-load-name: "semantic/symref/idutils"
;; End:
-;; arch-tag: 7e872652-cbe2-4083-a4d3-2a7c88c4c65c
;;; semantic/symref/idutils.el ends here
diff --git a/lisp/cedet/semantic/symref/list.el b/lisp/cedet/semantic/symref/list.el
index 8f887c7b398..a09928c7dfc 100644
--- a/lisp/cedet/semantic/symref/list.el
+++ b/lisp/cedet/semantic/symref/list.el
@@ -1,6 +1,6 @@
;;; semantic/symref/list.el --- Symref Output List UI.
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -189,6 +189,7 @@ Display the references in`semantic-symref-results-mode'."
"The current results in a results mode buffer.")
(defun semantic-symref-results-mode (results)
+ ;; FIXME: Use define-derived-mode.
"Major-mode for displaying Semantic Symbol Reference RESULTS.
RESULTS is an object of class `semantic-symref-results'."
(interactive)
@@ -204,7 +205,7 @@ RESULTS is an object of class `semantic-symref-results'."
(buffer-disable-undo)
(set (make-local-variable 'font-lock-global-modes) nil)
(font-lock-mode -1)
- (run-hooks 'semantic-symref-results-mode-hook)
+ (run-mode-hooks 'semantic-symref-results-mode-hook)
)
(defun semantic-symref-hide-buffer ()
diff --git a/lisp/cedet/semantic/tag-file.el b/lisp/cedet/semantic/tag-file.el
index 2fea7b66f7a..17fd3b45356 100644
--- a/lisp/cedet/semantic/tag-file.el
+++ b/lisp/cedet/semantic/tag-file.el
@@ -1,7 +1,6 @@
;;; semantic/tag-file.el --- Routines that find files based on tags.
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2005, 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: syntax
@@ -32,7 +31,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 +213,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/tag-ls.el b/lisp/cedet/semantic/tag-ls.el
index 7127a7c206f..8f54698d506 100644
--- a/lisp/cedet/semantic/tag-ls.el
+++ b/lisp/cedet/semantic/tag-ls.el
@@ -1,7 +1,6 @@
;;; semantic/tag-ls.el --- Language Specific override functions for tags
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2004, 2006-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -251,5 +250,4 @@ Return the name of TAG found in the toplevel STREAM."
;; generated-autoload-load-name: "semantic/tag-ls"
;; End:
-;; arch-tag: 06041439-e4bf-46f9-ab30-7805888d4464
;;; semantic/tag-ls.el ends here
diff --git a/lisp/cedet/semantic/tag-write.el b/lisp/cedet/semantic/tag-write.el
index 737cd79664f..d54d007f221 100644
--- a/lisp/cedet/semantic/tag-write.el
+++ b/lisp/cedet/semantic/tag-write.el
@@ -1,6 +1,6 @@
;;; semantic/tag-write.el --- Write tags to a text stream
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -175,5 +175,4 @@ The VALUE is a list of tags."
;; generated-autoload-load-name: "semantic/tag-write"
;; End:
-;; arch-tag: aa2301b3-f0c5-4d73-b456-43eaba5b2198
;;; semantic/tag-write.el ends here
diff --git a/lisp/cedet/semantic/tag.el b/lisp/cedet/semantic/tag.el
index 267f3b93515..cf3f5b603c8 100644
--- a/lisp/cedet/semantic/tag.el
+++ b/lisp/cedet/semantic/tag.el
@@ -1,7 +1,6 @@
;;; semantic/tag.el --- tag creation and access
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2005, 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -1369,5 +1368,4 @@ and `semantic-tag-type-interfaces' instead" "23.2")
;; generated-autoload-load-name: "semantic/tag"
;; End:
-;; arch-tag: f7813634-c4f0-4817-a487-cbaa84333353
;;; semantic/tag.el ends here
diff --git a/lisp/cedet/semantic/texi.el b/lisp/cedet/semantic/texi.el
index 4959f065077..66327cbe2ff 100644
--- a/lisp/cedet/semantic/texi.el
+++ b/lisp/cedet/semantic/texi.el
@@ -1,7 +1,6 @@
;;; semantic/texi.el --- Semantic details for Texinfo files
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001-2005, 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -688,5 +687,4 @@ If TAG is nil, it is derived from the deffn under POINT."
(provide 'semantic/texi)
-;; arch-tag: a8649049-46da-407b-a620-d175c1fedca6
;;; semantic/texi.el ends here
diff --git a/lisp/cedet/semantic/util-modes.el b/lisp/cedet/semantic/util-modes.el
index 6027165faae..a08f4a31b30 100644
--- a/lisp/cedet/semantic/util-modes.el
+++ b/lisp/cedet/semantic/util-modes.el
@@ -1,7 +1,6 @@
;;; semantic/util-modes.el --- Semantic minor modes
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2000-2005, 2007-2011 Free Software Foundation, Inc.
;; Authors: Eric M. Ludlam <zappo@gnu.org>
;; David Ponce <david@dponce.com>
@@ -28,6 +27,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 +52,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 +62,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 +124,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 +202,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 +223,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 +352,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 +391,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 +409,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 +429,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 +486,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 +508,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 +538,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 +546,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 +556,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 +611,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 +695,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 +727,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 +735,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 +828,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 +840,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 +912,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 +925,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 +941,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 +1001,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)
@@ -1246,5 +1010,4 @@ function was called, move the overlay."
;; generated-autoload-load-name: "semantic/util-modes"
;; End:
-;; arch-tag: 18f5a3d8-1fd7-4c17-b149-a313c126987d
;;; semantic/util-modes.el ends here
diff --git a/lisp/cedet/semantic/util.el b/lisp/cedet/semantic/util.el
index 2775153e553..acf5f95a217 100644
--- a/lisp/cedet/semantic/util.el
+++ b/lisp/cedet/semantic/util.el
@@ -1,7 +1,6 @@
;;; semantic/util.el --- Utilities for use with semantic tag tables
-;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
-;;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 1999-2005, 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: syntax
@@ -436,5 +435,4 @@ determining which symbols are considered."
;;
(require 'semantic/util-modes)
-;; arch-tag: eaa7808d-83b9-43fe-adf0-4fb742dcb956
;;; semantic/util.el ends here
diff --git a/lisp/cedet/semantic/wisent.el b/lisp/cedet/semantic/wisent.el
index 36c36989432..04669b99660 100644
--- a/lisp/cedet/semantic/wisent.el
+++ b/lisp/cedet/semantic/wisent.el
@@ -1,7 +1,6 @@
;;; semantic/wisent.el --- Wisent - Semantic gateway
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001-2007, 2009-2011 Free Software Foundation, Inc.
;; Author: David Ponce <david@dponce.com>
;; Maintainer: David Ponce <david@dponce.com>
@@ -343,5 +342,4 @@ the standard function `semantic-parse-region'."
(provide 'semantic/wisent)
-;; arch-tag: c24ddd69-d41c-4604-8221-29a93fc4fa79
;;; semantic/wisent.el ends here
diff --git a/lisp/cedet/semantic/wisent/comp.el b/lisp/cedet/semantic/wisent/comp.el
index 8fd1a1df5eb..f92ae88c14e 100644
--- a/lisp/cedet/semantic/wisent/comp.el
+++ b/lisp/cedet/semantic/wisent/comp.el
@@ -1,7 +1,7 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1984, 1986, 1989, 1992, 1995, 2000-2007, 2009-2011
+;; Free Software Foundation, Inc.
;; Author: David Ponce <david@dponce.com>
;; Maintainer: David Ponce <david@dponce.com>
@@ -160,12 +160,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 +199,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."
@@ -3458,15 +3452,13 @@ where:
(if (wisent-automaton-p grammar)
grammar ;; Grammar already compiled just return it
(wisent-with-context compile-grammar
- (let* ((gc-cons-threshold 1000000)
- automaton)
+ (let* ((gc-cons-threshold 1000000))
(garbage-collect)
(setq wisent-new-log-flag t)
;; Parse input grammar
(wisent-parse-grammar grammar start-list)
;; Generate the LALR(1) automaton
- (setq automaton (wisent-parser-automaton))
- automaton))))
+ (wisent-parser-automaton)))))
;;;; --------------------------
;;;; Byte compile input grammar
@@ -3482,8 +3474,19 @@ Automatically called by the Emacs Lisp byte compiler as a
;; automaton internal data structure. Then, because the internal
;; data structure contains an obarray, convert it to a lisp form so
;; it can be byte-compiled.
- (byte-compile-form (wisent-automaton-lisp-form (eval form))))
-
+ (byte-compile-form
+ ;; FIXME: we macroexpand here since `byte-compile-form' expects
+ ;; macroexpanded code, but that's just a workaround: for lexical-binding
+ ;; the lisp form should have to pass through closure-conversion and
+ ;; `wisent-byte-compile-grammar' is called much too late for that.
+ ;; Why isn't this `wisent-automaton-lisp-form' performed at
+ ;; macroexpansion time? --Stef
+ (macroexpand-all
+ (wisent-automaton-lisp-form (eval form)))))
+
+;; FIXME: We shouldn't use a `byte-compile' handler. Maybe using a hash-table
+;; instead of an obarray would work around the problem that obarrays
+;; aren't printable. Then (put 'wisent-compile-grammar 'side-effect-free t).
(put 'wisent-compile-grammar 'byte-compile 'wisent-byte-compile-grammar)
(defun wisent-automaton-lisp-form (automaton)
@@ -3536,5 +3539,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/semantic/wisent/java-tags.el b/lisp/cedet/semantic/wisent/java-tags.el
index b8362c3c55b..d0647d8e271 100644
--- a/lisp/cedet/semantic/wisent/java-tags.el
+++ b/lisp/cedet/semantic/wisent/java-tags.el
@@ -1,7 +1,6 @@
;;; semantic/wisent/java-tags.el --- Java LALR parser for Emacs
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001-2006, 2009-2011 Free Software Foundation, Inc.
;; Author: David Ponce <david@dponce.com>
;; Maintainer: David Ponce <david@dponce.com>
@@ -121,5 +120,4 @@ Use the alternate LALR(1) parser."
;; generated-autoload-load-name: "semantic/wisent/java-tags"
;; End:
-;; arch-tag: 4125e018-58db-4456-b878-e58c602f4add
;;; semantic/wisent/java-tags.el ends here
diff --git a/lisp/cedet/semantic/wisent/javascript.el b/lisp/cedet/semantic/wisent/javascript.el
index 6731715d12c..16b729f3925 100644
--- a/lisp/cedet/semantic/wisent/javascript.el
+++ b/lisp/cedet/semantic/wisent/javascript.el
@@ -1,6 +1,6 @@
;;; semantic/wisent/javascript.el --- javascript parser support
-;; Copyright (C) 2005, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2005, 2009-2011 Free Software Foundation, Inc.
;; Author: Eric Ludlam <zappo@gnu.org>
;; Keywords: syntax
@@ -63,7 +63,7 @@ to this variable NAME."
;; These methods override aspects of how semantic-tools can access
;; the tags created by the javascript parser.
;; Local context
-(define-mode-overload-implementation semantic-get-local-variables
+(define-mode-local-override semantic-get-local-variables
javascript-mode ()
"Get local values from a specific context.
This function overrides `get-local-variables'."
@@ -102,5 +102,4 @@ This function overrides `get-local-variables'."
;; generated-autoload-load-name: "semantic/wisent/javascript"
;; End:
-;; arch-tag: 15416a3a-84ca-4b3b-a13c-e7a1891ec3ea
;;; semantic/wisent/javascript-jv.el ends here
diff --git a/lisp/cedet/semantic/wisent/javat-wy.el b/lisp/cedet/semantic/wisent/javat-wy.el
index 258b1ac4af7..adea4ef6932 100644
--- a/lisp/cedet/semantic/wisent/javat-wy.el
+++ b/lisp/cedet/semantic/wisent/javat-wy.el
@@ -1,6 +1,6 @@
;;; semantic/wisent/javat-wy.el --- Generated parser support file
-;; Copyright (C) 2002, 2007, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002, 2007, 2009-2011 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
@@ -679,5 +679,4 @@ It ignores whitespaces, newlines and comments."
(provide 'semantic/wisent/javat-wy)
-;; arch-tag: b035ba00-e014-4c71-9bc7-a9dbf3d5b911
;;; semantic/wisent/javat-wy.el ends here
diff --git a/lisp/cedet/semantic/wisent/js-wy.el b/lisp/cedet/semantic/wisent/js-wy.el
index 021002059f8..e982caf4485 100644
--- a/lisp/cedet/semantic/wisent/js-wy.el
+++ b/lisp/cedet/semantic/wisent/js-wy.el
@@ -1,6 +1,6 @@
;;; semantic/wisent/js-wy.el --- Generated parser support file
-;; Copyright (C) 2005, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2005, 2009-2011 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
@@ -488,5 +488,4 @@
(provide 'semantic/wisent/js-wy)
-;; arch-tag: ff9ecf05-18e6-46a6-a3bb-e7f43f04640f
;;; semantic/wisent/js-wy.el ends here
diff --git a/lisp/cedet/semantic/wisent/python-wy.el b/lisp/cedet/semantic/wisent/python-wy.el
index 32466a31cec..3a69078b02c 100644
--- a/lisp/cedet/semantic/wisent/python-wy.el
+++ b/lisp/cedet/semantic/wisent/python-wy.el
@@ -1,7 +1,6 @@
;;; semantic/wisent/python-wy.el --- Generated parser support file
-;; Copyright (C) 2002, 2003, 2004, 2007, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2004, 2007, 2010-2011 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
diff --git a/lisp/cedet/semantic/wisent/python.el b/lisp/cedet/semantic/wisent/python.el
index cd952d2c305..095a817f08d 100644
--- a/lisp/cedet/semantic/wisent/python.el
+++ b/lisp/cedet/semantic/wisent/python.el
@@ -1,7 +1,6 @@
;;; wisent-python.el --- Semantic support for Python
-;; Copyright (C) 2002, 2004, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002, 2004, 2006-2011 Free Software Foundation, Inc.
;; Author: Richard Kim <emacs18@gmail.com>
;; Maintainer: Richard Kim <emacs18@gmail.com>
diff --git a/lisp/cedet/semantic/wisent/wisent.el b/lisp/cedet/semantic/wisent/wisent.el
index 32eb638548d..8c17d4ccab4 100644
--- a/lisp/cedet/semantic/wisent/wisent.el
+++ b/lisp/cedet/semantic/wisent/wisent.el
@@ -1,7 +1,6 @@
;;; semantic/wisent/wisent.el --- GNU Bison for Emacs - Runtime
-;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2009, 2010, 2011
-;;; Free Software Foundation, Inc.
+;;; Copyright (C) 2002-2007, 2009-2011 Free Software Foundation, Inc.
;; Author: David Ponce <david@dponce.com>
;; Maintainer: David Ponce <david@dponce.com>
@@ -476,5 +475,4 @@ automaton has only one entry point."
(provide 'semantic/wisent/wisent)
-;; arch-tag: c299c5a4-d96f-4f1c-8307-ef2af3c8bdcb
;;; semantic/wisent/wisent.el ends here
diff --git a/lisp/cedet/srecode.el b/lisp/cedet/srecode.el
index 373c14c6244..7b499d1a5e7 100644
--- a/lisp/cedet/srecode.el
+++ b/lisp/cedet/srecode.el
@@ -1,9 +1,10 @@
;;; srecode.el --- Semantic buffer evaluator.
-;;; Copyright (C) 2005, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 2005, 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: codegeneration
+;; Version: 1.0pre7
;; This file is part of GNU Emacs.
@@ -51,5 +52,4 @@
(provide 'srecode)
-;; arch-tag: 6c671a1c-40e5-4ed3-ab05-84249c3afdaf
;;; srecode.el ends here
diff --git a/lisp/cedet/srecode/args.el b/lisp/cedet/srecode/args.el
index 0d2f017e6b9..d8e02f978b2 100644
--- a/lisp/cedet/srecode/args.el
+++ b/lisp/cedet/srecode/args.el
@@ -1,6 +1,6 @@
;;; srecode/args.el --- Provide some simple template arguments
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -186,4 +186,3 @@ do not contain any text from preceding or following text."
;;; srecode/args.el ends here
-;; arch-tag: 645fc31e-30a9-469b-9215-fb320a46ee96
diff --git a/lisp/cedet/srecode/compile.el b/lisp/cedet/srecode/compile.el
index b404c4a8123..0a117bad9bc 100644
--- a/lisp/cedet/srecode/compile.el
+++ b/lisp/cedet/srecode/compile.el
@@ -1,6 +1,6 @@
;;; srecode/compile --- Compilation of srecode template files.
-;; Copyright (C) 2005, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2005, 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: codegeneration
@@ -654,5 +654,4 @@ Argument INDENT specifies the indentation level for the list."
;; generated-autoload-load-name: "srecode/compile"
;; End:
-;; arch-tag: d993ffab-2704-4bb2-bd92-eafe803af3be
;;; srecode/compile.el ends here
diff --git a/lisp/cedet/srecode/cpp.el b/lisp/cedet/srecode/cpp.el
index ab9d4a5fe6d..a46e8369c6c 100644
--- a/lisp/cedet/srecode/cpp.el
+++ b/lisp/cedet/srecode/cpp.el
@@ -1,6 +1,6 @@
;;; srecode/cpp.el --- C++ specific handlers for Semantic Recoder
-;; Copyright (C) 2007, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007, 2009-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
;; Jan Moringen <scymtym@users.sourceforge.net>
@@ -213,5 +213,4 @@ special behavior for tag of classes include, using and function."
;; generated-autoload-load-name: "srecode/cpp"
;; End:
-;; arch-tag: 4659755c-88b4-405e-818f-bb1f776a8e82
;;; srecode/cpp.el ends here
diff --git a/lisp/cedet/srecode/ctxt.el b/lisp/cedet/srecode/ctxt.el
index b951788bec3..cae52428e75 100644
--- a/lisp/cedet/srecode/ctxt.el
+++ b/lisp/cedet/srecode/ctxt.el
@@ -1,6 +1,6 @@
;;; srecode/ctxt.el --- Derive a context from the source buffer.
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -244,5 +244,4 @@ This might add the following:
(provide 'srecode/ctxt)
-;; arch-tag: 5a004702-28e5-4e26-9b14-8a78eae49865
;;; srecode/ctxt.el ends here
diff --git a/lisp/cedet/srecode/dictionary.el b/lisp/cedet/srecode/dictionary.el
index e04aad33065..06496160b8c 100644
--- a/lisp/cedet/srecode/dictionary.el
+++ b/lisp/cedet/srecode/dictionary.el
@@ -1,6 +1,6 @@
;;; srecode-dictionary.el --- Dictionary code for the semantic recoder.
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -708,5 +708,4 @@ STATE is the current compiler state."
(provide 'srecode/dictionary)
-;; arch-tag: c664179c-171c-4709-9b56-d5a2fd30e457
;;; srecode/dictionary.el ends here
diff --git a/lisp/cedet/srecode/document.el b/lisp/cedet/srecode/document.el
index 6d4231f3967..bccc85fb82b 100644
--- a/lisp/cedet/srecode/document.el
+++ b/lisp/cedet/srecode/document.el
@@ -1,6 +1,6 @@
;;; srecode/document.el --- Documentation (comment) generation
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -837,5 +837,4 @@ not account for verb parts."
;; generated-autoload-load-name: "srecode/document"
;; End:
-;; arch-tag: 5ce9b30b-7862-4ab8-b3f8-a4df37a2e0fe
;;; srecode/document.el ends here
diff --git a/lisp/cedet/srecode/el.el b/lisp/cedet/srecode/el.el
index e8c585cca6c..03ea9773666 100644
--- a/lisp/cedet/srecode/el.el
+++ b/lisp/cedet/srecode/el.el
@@ -1,6 +1,6 @@
;;; srecode/el.el --- Emacs Lisp specific arguments
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -109,5 +109,4 @@ Calls `srecode-semantic-apply-tag-to-dict-default' first."
;; generated-autoload-load-name: "srecode/el"
;; End:
-;; arch-tag: c1852a36-d45b-4263-8f3e-03f4f3c795d9
;;; srecode/el.el ends here
diff --git a/lisp/cedet/srecode/expandproto.el b/lisp/cedet/srecode/expandproto.el
index 92c5326a85a..89dc9adcefc 100644
--- a/lisp/cedet/srecode/expandproto.el
+++ b/lisp/cedet/srecode/expandproto.el
@@ -1,6 +1,6 @@
;;; srecode/expandproto.el --- Expanding prototypes.
-;; Copyright (C) 2007, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007, 2009-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -129,5 +129,4 @@
;; generated-autoload-load-name: "srecode/expandproto"
;; End:
-;; arch-tag: f0371b5f-9bec-46a1-9b5d-8dff0e897426
;;; srecode/expandproto.el ends here
diff --git a/lisp/cedet/srecode/extract.el b/lisp/cedet/srecode/extract.el
index df556b29e0e..dba4b876edb 100644
--- a/lisp/cedet/srecode/extract.el
+++ b/lisp/cedet/srecode/extract.el
@@ -1,6 +1,6 @@
;;; srecode/extract.el --- Extract content from previously inserted macro.
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -239,5 +239,4 @@ Return nil if nothing was extracted."
(provide 'srecode/extract)
-;; arch-tag: 051f5901-46ae-4319-8c84-16daf971e226
;;; srecode/extract.el ends here
diff --git a/lisp/cedet/srecode/fields.el b/lisp/cedet/srecode/fields.el
index 817bb93d2fd..088781cfb53 100644
--- a/lisp/cedet/srecode/fields.el
+++ b/lisp/cedet/srecode/fields.el
@@ -1,6 +1,6 @@
;;; srecode/fields.el --- Handling type-in fields in a buffer.
;;
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
;;
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -447,5 +447,4 @@ PRE-LEN is used in the after mode for the length of the changed text."
(provide 'srecode/fields)
-;; arch-tag: 00cea6f0-42ac-4b15-b778-46e6db0bfcb5
;;; srecode/fields.el ends here
diff --git a/lisp/cedet/srecode/filters.el b/lisp/cedet/srecode/filters.el
index 0afd32bbb41..cc942e53ffd 100644
--- a/lisp/cedet/srecode/filters.el
+++ b/lisp/cedet/srecode/filters.el
@@ -1,6 +1,6 @@
;;; srecode/filters.el --- Filters for use in template variables.
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -54,4 +54,3 @@
;;; srecode/filters.el ends here
-;; arch-tag: fcc95ddc-8d9a-4b15-bb51-2707ead986c7
diff --git a/lisp/cedet/srecode/find.el b/lisp/cedet/srecode/find.el
index 39b7656d007..fdca64a7da1 100644
--- a/lisp/cedet/srecode/find.el
+++ b/lisp/cedet/srecode/find.el
@@ -1,6 +1,6 @@
;;;; srecode/find.el --- Tools for finding templates in the database.
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -278,5 +278,4 @@ DEFAULT is what to use if the user presses RET."
(provide 'srecode/find)
-;; arch-tag: 49d18e58-45a0-48f5-92e1-4a1dcd4e36a6
;;; srecode/find.el ends here
diff --git a/lisp/cedet/srecode/getset.el b/lisp/cedet/srecode/getset.el
index bf1a684c19a..a582d4ff59e 100644
--- a/lisp/cedet/srecode/getset.el
+++ b/lisp/cedet/srecode/getset.el
@@ -1,6 +1,6 @@
;;; srecode/getset.el --- Package for inserting new get/set methods.
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -363,5 +363,4 @@ Base selection on the field related to POINT."
;; generated-autoload-load-name: "srecode/getset"
;; End:
-;; arch-tag: c2098b7a-df7f-4e8a-a9e3-2be8798a7554
;;; srecode/getset.el ends here
diff --git a/lisp/cedet/srecode/insert.el b/lisp/cedet/srecode/insert.el
index 1df08d2c74c..931d0b3d73e 100644
--- a/lisp/cedet/srecode/insert.el
+++ b/lisp/cedet/srecode/insert.el
@@ -1,6 +1,6 @@
;;; srecode/insert --- Insert srecode templates to an output stream.
-;; Copyright (C) 2005, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2005, 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -1020,5 +1020,4 @@ template where a ^ inserter occurs."
;; generated-autoload-load-name: "srecode/insert"
;; End:
-;; arch-tag: a5aa3401-924a-4617-8513-2f0f01256872
;;; srecode/insert.el ends here
diff --git a/lisp/cedet/srecode/java.el b/lisp/cedet/srecode/java.el
index 97f4eb34597..69534e053f1 100644
--- a/lisp/cedet/srecode/java.el
+++ b/lisp/cedet/srecode/java.el
@@ -1,6 +1,6 @@
;;; srecode-java.el --- Srecode Java support
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -58,5 +58,4 @@ FILENAME_AS_CLASS - file converted to a Java class name."
;; generated-autoload-load-name: "srecode/java"
;; End:
-;; arch-tag: d796b86c-3a0e-457c-a346-9f1ccfdc5e2c
;;; srecode/java.el ends here
diff --git a/lisp/cedet/srecode/map.el b/lisp/cedet/srecode/map.el
index e3f78ed9978..126f41eb7f7 100644
--- a/lisp/cedet/srecode/map.el
+++ b/lisp/cedet/srecode/map.el
@@ -1,6 +1,6 @@
;;; srecode/map.el --- Manage a template file map
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -415,5 +415,4 @@ Return non-nil if the map changed."
;; generated-autoload-load-name: "srecode/map"
;; End:
-;; arch-tag: dc90c737-1e87-455a-bbd1-6b72cdbfb7fd
;;; srecode/map.el ends here
diff --git a/lisp/cedet/srecode/mode.el b/lisp/cedet/srecode/mode.el
index 08da334767d..6ca0cefe9a7 100644
--- a/lisp/cedet/srecode/mode.el
+++ b/lisp/cedet/srecode/mode.el
@@ -1,6 +1,6 @@
;;; srecode/mode.el --- Minor mode for managing and using SRecode templates
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -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
;;
@@ -423,5 +396,4 @@ programming modes."
;; generated-autoload-load-name: "srecode/mode"
;; End:
-;; arch-tag: 56ad9d6b-899b-4a68-8636-1432b6bc149b
;;; srecode/mode.el ends here
diff --git a/lisp/cedet/srecode/semantic.el b/lisp/cedet/srecode/semantic.el
index 0926ccf4da7..4a1a15c1d12 100644
--- a/lisp/cedet/srecode/semantic.el
+++ b/lisp/cedet/srecode/semantic.el
@@ -1,6 +1,6 @@
;;; srecode/semantic.el --- Semantic specific extensions to SRecode.
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -428,5 +428,4 @@ as `function' will leave point where code might be inserted."
(provide 'srecode/semantic)
-;; arch-tag: b87ccbd6-bd87-48bc-8182-1043a9052d79
;;; srecode/semantic.el ends here
diff --git a/lisp/cedet/srecode/srt-mode.el b/lisp/cedet/srecode/srt-mode.el
index dd2c062ca69..5a407aad135 100644
--- a/lisp/cedet/srecode/srt-mode.el
+++ b/lisp/cedet/srecode/srt-mode.el
@@ -1,6 +1,6 @@
;;; srecode/srt-mode.el --- Major mode for writing screcode macros
-;; Copyright (C) 2005, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2005, 2007-2011 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
@@ -183,27 +183,20 @@ we can tell font lock about them.")
"Keymap used in srecode mode.")
;;;###autoload
-(defun srecode-template-mode ()
+(define-derived-mode srecode-template-mode fundamental-mode "SRecorder"
"Major-mode for writing SRecode macros."
- (interactive)
- (kill-all-local-variables)
- (setq major-mode 'srecode-template-mode
- mode-name "SRecoder"
- comment-start ";;"
+ (setq comment-start ";;"
comment-end "")
(set (make-local-variable 'parse-sexp-ignore-comments) t)
(set (make-local-variable 'comment-start-skip)
"\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
- (set-syntax-table srecode-template-mode-syntax-table)
- (use-local-map srecode-template-mode-map)
(set (make-local-variable 'font-lock-defaults)
'(srecode-font-lock-keywords
nil ;; perform string/comment fontification
nil ;; keywords are case sensitive.
;; This puts _ & - as a word constituant,
;; simplifying our keywords significantly
- ((?_ . "w") (?- . "w"))))
- (run-hooks 'srecode-template-mode-hook))
+ ((?_ . "w") (?- . "w")))))
;;;###autoload
(defalias 'srt-mode 'srecode-template-mode)
@@ -747,5 +740,4 @@ When optional BUFFER is provided, search that buffer."
;; generated-autoload-load-name: "srecode/srt-mode"
;; End:
-;; arch-tag: 9c613c25-d885-417a-8f0d-1824b26b22a5
;;; srecode/srt-mode.el ends here
diff --git a/lisp/cedet/srecode/srt-wy.el b/lisp/cedet/srecode/srt-wy.el
index 3dde065c2a6..2fb8e7665e9 100644
--- a/lisp/cedet/srecode/srt-wy.el
+++ b/lisp/cedet/srecode/srt-wy.el
@@ -1,6 +1,6 @@
;;; srecode/srt-wy.el --- Generated parser support file
-;; Copyright (C) 2005, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2005, 2007-2011 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
@@ -274,5 +274,4 @@ It ignores whitespace, newlines and comments."
(provide 'srecode/srt-wy)
-;; arch-tag: 1be4c0bc-2a79-4f75-a07a-1ac518f41271
;;; srecode/srt-wy.el ends here
diff --git a/lisp/cedet/srecode/srt.el b/lisp/cedet/srecode/srt.el
index 3fc5f4cb907..4ea554f1def 100644
--- a/lisp/cedet/srecode/srt.el
+++ b/lisp/cedet/srecode/srt.el
@@ -1,6 +1,6 @@
;;; srecode/srt.el --- argument handlers for SRT files
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -104,5 +104,4 @@ MODE - The mode of this buffer. If not declared yet, guess."
(provide 'srecode/srt)
-;; arch-tag: fb69da04-0bd6-48fe-b935-f8668420ecaf
;;; srecode/srt.el ends here
diff --git a/lisp/cedet/srecode/table.el b/lisp/cedet/srecode/table.el
index 8cba7aff7f3..52a7765c857 100644
--- a/lisp/cedet/srecode/table.el
+++ b/lisp/cedet/srecode/table.el
@@ -1,6 +1,6 @@
;;; srecode/table.el --- Tables of Semantic Recoders
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -259,4 +259,3 @@ Use PREDICATE is the same as for the `sort' function."
;;; srecode/table.el ends here
-;; arch-tag: 547d2f1d-2694-49b3-ab13-b2cda6b25b4d
diff --git a/lisp/cedet/srecode/template.el b/lisp/cedet/srecode/template.el
index d127375fbff..e0cf42b75df 100644
--- a/lisp/cedet/srecode/template.el
+++ b/lisp/cedet/srecode/template.el
@@ -1,6 +1,6 @@
;;; srecode-template.el --- SRecoder template language parser support.
-;; Copyright (C) 2005, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2005, 2007-2011 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
@@ -72,5 +72,4 @@
;; generated-autoload-load-name: "srecode/template"
;; End:
-;; arch-tag: 037fbca7-e846-4521-b801-3463f50c3080
;;; srecode/template.el ends here
diff --git a/lisp/cedet/srecode/texi.el b/lisp/cedet/srecode/texi.el
index 2ac2a240c01..38d8e765d41 100644
--- a/lisp/cedet/srecode/texi.el
+++ b/lisp/cedet/srecode/texi.el
@@ -1,6 +1,6 @@
;;; srecode-texi.el --- Srecode texinfo support.
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
@@ -285,5 +285,4 @@ that class.
;; generated-autoload-load-name: "srecode/texi"
;; End:
-;; arch-tag: 6f0e7f45-2281-49e4-b73c-680cba477094
;;; srecode/texi.el ends here
diff --git a/lisp/chistory.el b/lisp/chistory.el
index 9cc6d866052..09f6e205cdd 100644
--- a/lisp/chistory.el
+++ b/lisp/chistory.el
@@ -1,7 +1,6 @@
;;; chistory.el --- list command history
-;; Copyright (C) 1985, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 2001-2011 Free Software Foundation, Inc.
;; Author: K. Shane Hartman
;; Maintainer: FSF
@@ -189,5 +188,4 @@ and runs the normal hook `command-history-hook'."
(provide 'chistory)
-;; arch-tag: c201a0cd-89f2-4d39-a532-4cb309391dbd
;;; chistory.el ends here
diff --git a/lisp/cmuscheme.el b/lisp/cmuscheme.el
index be3401ce5b9..f4d15689885 100644
--- a/lisp/cmuscheme.el
+++ b/lisp/cmuscheme.el
@@ -1,7 +1,6 @@
;;; cmuscheme.el --- Scheme process in a buffer. Adapted from tea.el
-;; Copyright (C) 1988, 1994, 1997, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1988, 1994, 1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Olin Shivers <olin.shivers@cs.cmu.edu>
;; Maintainer: FSF
@@ -504,7 +503,7 @@ See variable `scheme-buffer'."
(current-buffer)
scheme-buffer)))
-(defun scheme-interactively-start-process (&optional cmd)
+(defun scheme-interactively-start-process (&optional _cmd)
"Start an inferior Scheme process. Return the process started.
Since this command is run implicitly, always ask the user for the
command to run."
@@ -523,5 +522,4 @@ This is a good place to put keybindings."
(provide 'cmuscheme)
-;; arch-tag: e8795f4a-c496-45a2-97b4-8e0f2a2c57d2
;;; cmuscheme.el ends here
diff --git a/lisp/color.el b/lisp/color.el
new file mode 100644
index 00000000000..5b67eb58a63
--- /dev/null
+++ b/lisp/color.el
@@ -0,0 +1,315 @@
+;;; color.el --- Color manipulation library -*- coding: utf-8; -*-
+
+;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
+
+;; Authors: Julien Danjou <julien@danjou.info>
+;; Drew Adams <drew.adams@oracle.com>
+;; Keywords: lisp, faces, color, hex, rgb, hsv, hsl, cie-lab, background
+
+;; 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 functions for manipulating colors, including
+;; converting between color representations, computing color
+;; complements, and computing CIEDE2000 color distances.
+;;
+;; Supported color representations include RGB (red, green, blue), HSV
+;; (hue, saturation, value), HSL (hue, saturation, luminence), sRGB,
+;; CIE XYZ, and CIE L*a*b* color components.
+
+;;; 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...).")))
+
+;;;###autoload
+(defun color-name-to-rgb (color &optional frame)
+ "Convert COLOR string to a list of normalized RGB components.
+COLOR should be a color name (e.g. \"white\") or an RGB triplet
+string (e.g. \"#ff12ec\").
+
+Normally the return value is a list of three floating-point
+numbers, (RED GREEN BLUE), each between 0.0 and 1.0 inclusive.
+
+Optional arg FRAME specifies the frame where the color is to be
+displayed. If FRAME is omitted or nil, use the selected frame.
+If FRAME cannot display COLOR, return nil."
+ (mapcar (lambda (x) (/ x 65535.0)) (color-values color frame)))
+
+(defun color-rgb-to-hex (red green blue)
+ "Return hexadecimal notation for the color RED GREEN BLUE.
+RED GREEN BLUE must be numbers between 0.0 and 1.0 inclusive."
+ (format "#%02x%02x%02x"
+ (* red 255) (* green 255) (* blue 255)))
+
+(defun color-complement (color-name)
+ "Return the color that is the complement of COLOR-NAME.
+COLOR-NAME should be a string naming a color (e.g. \"white\"), or
+a string specifying a color's RGB components (e.g. \"#ff12ec\")."
+ (let ((color (color-name-to-rgb color-name)))
+ (list (- 1.0 (car color))
+ (- 1.0 (cadr color))
+ (- 1.0 (caddr color)))))
+
+(defun color-gradient (start stop step-number)
+ "Return a list with STEP-NUMBER colors from START to STOP.
+The color list builds a color gradient starting at color START to
+color STOP. It does not include the START and STOP color in the
+resulting list."
+ (let* ((r (nth 0 start))
+ (g (nth 1 start))
+ (b (nth 2 start))
+ (r-step (/ (- (nth 0 stop) r) (1+ step-number)))
+ (g-step (/ (- (nth 1 stop) g) (1+ step-number)))
+ (b-step (/ (- (nth 2 stop) b) (1+ step-number)))
+ result)
+ (dotimes (n step-number)
+ (push (list (setq r (+ r r-step))
+ (setq g (+ g g-step))
+ (setq b (+ b b-step)))
+ result))
+ (nreverse result)))
+
+(defun color-complement-hex (color)
+ "Return the color that is the complement of COLOR, in hexadecimal format."
+ (apply 'color-rgb-to-hex (color-complement color)))
+
+(defun color-rgb-to-hsv (red green blue)
+ "Convert RED, GREEN, and BLUE color components to HSV.
+RED, GREEN, and BLUE should each be numbers between 0.0 and 1.0,
+inclusive. Return a list (HUE, SATURATION, VALUE), where HUE is
+in radians and both SATURATION and VALUE are between 0.0 and 1.0,
+inclusive."
+ (let* ((r (float red))
+ (g (float green))
+ (b (float blue))
+ (max (max r g b))
+ (min (min r g b)))
+ (if (< (- max min) 1e-8)
+ (list 0.0 0.0 0.0)
+ (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-to-hsl (red green blue)
+ "Convert RED GREEN BLUE colors to their HSL representation.
+RED, GREEN, and BLUE should each be numbers between 0.0 and 1.0,
+inclusive.
+
+Return a list (HUE, SATURATION, LUMINENCE), where HUE is in radians
+and both SATURATION and LUMINENCE are between 0.0 and 1.0,
+inclusive."
+ (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) 1e-8)
+ 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-to-xyz (red green blue)
+ "Convert RED GREEN BLUE colors from the sRGB color space to CIE XYZ.
+RED, BLUE and GREEN must be between 0 and 1, inclusive."
+ (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-to-srgb (X Y Z)
+ "Convert 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-to-lab (X Y Z &optional white-point)
+ "Convert CIE XYZ to CIE L*a*b*.
+WHITE-POINT specifies the (X Y Z) white point for the
+conversion. If omitted or nil, use `color-d65-xyz'."
+ (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-to-xyz (L a b &optional white-point)
+ "Convert CIE L*a*b* to CIE XYZ.
+WHITE-POINT specifies the (X Y Z) white point for the
+conversion. If omitted or nil, use `color-d65-xyz'."
+ (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-to-lab (red green blue)
+ "Convert RGB to CIE L*a*b*."
+ (apply 'color-xyz-to-lab (color-srgb-to-xyz red green blue)))
+
+(defun color-lab-to-srgb (L a b)
+ "Convert CIE L*a*b* to RGB."
+ (apply 'color-xyz-to-srgb (color-lab-to-xyz L a b)))
+
+(defun color-cie-de2000 (color1 color2 &optional kL kC kH)
+ "Return the CIEDE2000 color distance between COLOR1 and COLOR2.
+Both COLOR1 and COLOR2 should be in CIE L*a*b* format, as
+returned by `color-srgb-to-lab' or `color-xyz-to-lab'."
+ (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/comint.el b/lisp/comint.el
index 895bdb46171..8608c0d31e9 100644
--- a/lisp/comint.el
+++ b/lisp/comint.el
@@ -1,13 +1,12 @@
-;;; comint.el --- general command interpreter in a window stuff
+;;; comint.el --- general command interpreter in a window stuff -*- lexical-binding: t -*-
-;; Copyright (C) 1988, 1990, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1988, 1990, 1992-2011 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.
@@ -102,6 +101,7 @@
;;; Code:
+(eval-when-compile (require 'cl))
(require 'ring)
;; Buffer Local Variables:
@@ -226,9 +226,7 @@ This variable is buffer-local."
:group 'comint)
(defface comint-highlight-prompt
- '((((min-colors 88) (background dark)) (:foreground "cyan1"))
- (((background dark)) (:foreground "cyan"))
- (t (:foreground "dark blue")))
+ '((t :inherit minibuffer-prompt))
"Face to use to highlight prompts."
:group 'comint)
@@ -243,8 +241,8 @@ This variable is buffer-local."
(defcustom comint-input-ring-file-name nil
"If non-nil, name of the file to read/write input history.
See also `comint-read-input-ring' and `comint-write-input-ring'.
-
-This variable is buffer-local, and is a good thing to set in mode hooks."
+`comint-mode' makes this a buffer-local variable. You probably want
+to set this in a mode hook, rather than customize the default value."
:type '(choice (const :tag "nil" nil)
file)
:group 'comint)
@@ -309,7 +307,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 +336,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)
@@ -362,9 +367,9 @@ text matching `comint-prompt-regexp', depending on the value of
`comint-use-prompt-regexp'.")
(defvar comint-dynamic-complete-functions
- '(comint-replace-by-expanded-history comint-dynamic-complete-filename)
+ '(comint-c-a-p-replace-by-expanded-history comint-filename-completion)
"List of functions called to perform completion.
-Functions should return non-nil if completion was performed.
+Works like `completion-at-point-functions'.
See also `comint-dynamic-complete'.
This is a good thing to set in mode hooks.")
@@ -410,6 +415,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 +430,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."
@@ -490,7 +493,7 @@ executed once when the buffer is created."
(define-key map [menu-bar completion complete-file]
'("Complete File Name" . comint-dynamic-complete-filename))
(define-key map [menu-bar completion complete]
- '("Complete Before Point" . comint-dynamic-complete))
+ '("Complete at Point" . completion-at-point))
;; Input history:
(define-key map [menu-bar inout]
(cons "In/Out" (make-sparse-keymap "In/Out")))
@@ -671,12 +674,16 @@ 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)
(setq font-lock-defaults '(nil t))
(add-hook 'change-major-mode-hook 'font-lock-defontify nil t)
(add-hook 'isearch-mode-hook 'comint-history-isearch-setup nil t)
+ (add-hook 'completion-at-point-functions 'comint-completion-at-point nil t)
;; This behavior is not useful in comint buffers, and is annoying
(set (make-local-variable 'next-line-add-newlines) nil))
@@ -912,41 +919,36 @@ See also `comint-input-ignoredups' and `comint-write-input-ring'."
(message "Cannot read history file %s"
comint-input-ring-file-name)))
(t
- (let* ((history-buf (get-buffer-create " *temp*"))
- (file comint-input-ring-file-name)
+ (let* ((file comint-input-ring-file-name)
(count 0)
(size comint-input-ring-size)
(ring (make-ring size)))
- (unwind-protect
- (with-current-buffer history-buf
- (widen)
- (erase-buffer)
- (insert-file-contents file)
- ;; Save restriction in case file is already visited...
- ;; Watch for those date stamps in history files!
- (goto-char (point-max))
- (let (start end history)
- (while (and (< count size)
- (re-search-backward comint-input-ring-separator
- nil t)
- (setq end (match-beginning 0)))
- (setq start
- (if (re-search-backward comint-input-ring-separator
- nil t)
- (match-end 0)
- (point-min)))
- (setq history (buffer-substring start end))
- (goto-char start)
- (if (and (not (string-match comint-input-history-ignore
- history))
- (or (null comint-input-ignoredups)
- (ring-empty-p ring)
- (not (string-equal (ring-ref ring 0)
- history))))
- (progn
- (ring-insert-at-beginning ring history)
- (setq count (1+ count)))))))
- (kill-buffer history-buf))
+ (with-temp-buffer
+ (insert-file-contents file)
+ ;; Save restriction in case file is already visited...
+ ;; Watch for those date stamps in history files!
+ (goto-char (point-max))
+ (let (start end history)
+ (while (and (< count size)
+ (re-search-backward comint-input-ring-separator
+ nil t)
+ (setq end (match-beginning 0)))
+ (setq start
+ (if (re-search-backward comint-input-ring-separator
+ nil t)
+ (match-end 0)
+ (point-min)))
+ (setq history (buffer-substring start end))
+ (goto-char start)
+ (if (and (not (string-match comint-input-history-ignore
+ history))
+ (or (null comint-input-ignoredups)
+ (ring-empty-p ring)
+ (not (string-equal (ring-ref ring 0)
+ history))))
+ (progn
+ (ring-insert-at-beginning ring history)
+ (setq count (1+ count)))))))
(setq comint-input-ring ring
comint-input-ring-index nil)))))
@@ -1008,7 +1010,6 @@ See also `comint-read-input-ring'."
(message "No history")
(let ((history nil)
(history-buffer " *Input History*")
- (index (1- (ring-length comint-input-ring)))
(conf (current-window-configuration)))
;; We have to build up a list ourselves from the ring vector.
(dotimes (index (ring-length comint-input-ring))
@@ -1231,6 +1232,12 @@ See `comint-magic-space' and `comint-replace-by-expanded-history-before-point'.
Returns t if successful."
(interactive)
+ (let ((f (comint-c-a-p-replace-by-expanded-history silent start)))
+ (if f (funcall f))))
+
+(defun comint-c-a-p-replace-by-expanded-history (&optional silent start)
+ "Expand input command history at point.
+For use on `completion-at-point-functions'."
(if (and comint-input-autoexpand
(if comint-use-prompt-regexp
;; Use comint-prompt-regexp
@@ -1240,20 +1247,28 @@ Returns t if successful."
;; Use input fields. User input that hasn't been entered
;; yet, at the end of the buffer, has a nil `field' property.
(and (null (get-char-property (point) 'field))
- (string-match "!\\|^\\^" (field-string)))))
- ;; Looks like there might be history references in the command.
- (let ((previous-modified-tick (buffer-modified-tick)))
- (comint-replace-by-expanded-history-before-point silent start)
- (/= previous-modified-tick (buffer-modified-tick)))))
-
-
-(defun comint-replace-by-expanded-history-before-point (silent &optional start)
+ (string-match "!\\|^\\^" (field-string))))
+ (catch 'dry-run
+ (comint-replace-by-expanded-history-before-point
+ silent start 'dry-run)))
+ (lambda ()
+ ;; Looks like there might be history references in the command.
+ (let ((previous-modified-tick (buffer-modified-tick)))
+ (comint-replace-by-expanded-history-before-point silent start)
+ (/= previous-modified-tick (buffer-modified-tick))))))
+
+
+(defun comint-replace-by-expanded-history-before-point
+ (silent &optional start dry-run)
"Expand directory stack reference before point.
See `comint-replace-by-expanded-history'. Returns t if successful.
If the optional argument START is non-nil, that specifies the
start of the text to scan for history references, rather
-than the logical beginning of line."
+than the logical beginning of line.
+
+If DRY-RUN is non-nil, throw to DRY-RUN before performing any
+actual side-effect."
(save-excursion
(let ((toend (- (line-end-position) (point)))
(start (or start (comint-line-beginning-position))))
@@ -1274,10 +1289,12 @@ than the logical beginning of line."
(goto-char (1+ (point))))
((looking-at "![0-9]+\\($\\|[^-]\\)")
;; We cannot know the interpreter's idea of input line numbers.
+ (if dry-run (throw dry-run 'message))
(goto-char (match-end 0))
(message "Absolute reference cannot be expanded"))
((looking-at "!-\\([0-9]+\\)\\(:?[0-9^$*-]+\\)?")
;; Just a number of args from `number' lines backward.
+ (if dry-run (throw dry-run 'history))
(let ((number (1- (string-to-number
(buffer-substring (match-beginning 1)
(match-end 1))))))
@@ -1293,6 +1310,7 @@ than the logical beginning of line."
(message "Relative reference exceeds input history size"))))
((or (looking-at "!!?:?\\([0-9^$*-]+\\)") (looking-at "!!"))
;; Just a number of args from the previous input line.
+ (if dry-run (throw dry-run 'expand))
(replace-match (comint-args (comint-previous-input-string 0)
(match-beginning 1) (match-end 1))
t t)
@@ -1301,6 +1319,7 @@ than the logical beginning of line."
"!\\??\\({\\(.+\\)}\\|\\(\\sw+\\)\\)\\(:?[0-9^$*-]+\\)?")
;; Most recent input starting with or containing (possibly
;; protected) string, maybe just a number of args. Phew.
+ (if dry-run (throw dry-run 'expand))
(let* ((mb1 (match-beginning 1)) (me1 (match-end 1))
(mb2 (match-beginning 2)) (me2 (match-end 2))
(exp (buffer-substring (or mb2 mb1) (or me2 me1)))
@@ -1322,6 +1341,7 @@ than the logical beginning of line."
(message "History item: %d" (1+ pos)))))
((looking-at "\\^\\([^^]+\\)\\^?\\([^^]*\\)\\^?")
;; Quick substitution on the previous input line.
+ (if dry-run (throw dry-run 'expand))
(let ((old (buffer-substring (match-beginning 1) (match-end 1)))
(new (buffer-substring (match-beginning 2) (match-end 2)))
(pos nil))
@@ -1334,7 +1354,8 @@ than the logical beginning of line."
(replace-match new t t)
(message "History item: substituted"))))
(t
- (forward-char 1)))))))
+ (forward-char 1)))))
+ nil))
(defun comint-magic-space (arg)
@@ -1530,7 +1551,7 @@ in the search status stack."
`(lambda (cmd)
(comint-history-isearch-pop-state cmd ,comint-input-ring-index)))
-(defun comint-history-isearch-pop-state (cmd hist-pos)
+(defun comint-history-isearch-pop-state (_cmd hist-pos)
"Restore the input history search state.
Go to the history element by the absolute history position HIST-POS."
(comint-goto-input hist-pos))
@@ -1740,9 +1761,9 @@ Similarly for Soar, Scheme, etc."
(insert copy)
copy)))
(input (if (not (eq comint-input-autoexpand 'input))
- ;; Just whatever's already there
+ ;; Just whatever's already there.
intxt
- ;; Expand and leave it visible in buffer
+ ;; Expand and leave it visible in buffer.
(comint-replace-by-expanded-history t pmark)
(buffer-substring pmark (point))))
(history (if (not (eq comint-input-autoexpand 'history))
@@ -2054,7 +2075,7 @@ This function should be a pre-command hook."
(select-window selected))))
nil t))))))
-(defun comint-postoutput-scroll-to-bottom (string)
+(defun comint-postoutput-scroll-to-bottom (_string)
"Go to the end of buffer in some or all windows showing it.
Does not scroll if the current line is the last line in the buffer.
Depends on the value of `comint-move-point-for-output' and
@@ -2091,7 +2112,7 @@ This function should be in the list `comint-output-filter-functions'."
nil t))
(set-buffer current))))
-(defun comint-truncate-buffer (&optional string)
+(defun comint-truncate-buffer (&optional _string)
"Truncate the buffer to `comint-buffer-maximum-size'.
This function could be on `comint-output-filter-functions' or bound to a key."
(interactive)
@@ -2102,7 +2123,7 @@ This function could be on `comint-output-filter-functions' or bound to a key."
(let ((inhibit-read-only t))
(delete-region (point-min) (point)))))
-(defun comint-strip-ctrl-m (&optional string)
+(defun comint-strip-ctrl-m (&optional _string)
"Strip trailing `^M' characters from the current output group.
This function could be on `comint-output-filter-functions' or bound to a key."
(interactive)
@@ -2208,7 +2229,7 @@ a buffer local variable."
(goto-char (comint-line-beginning-position))))
;; For compatibility.
-(defun comint-read-noecho (prompt &optional ignore)
+(defun comint-read-noecho (prompt &optional _ignore)
(read-passwd prompt))
;; These three functions are for entering text you don't want echoed or
@@ -2293,8 +2314,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.
@@ -2834,10 +2853,9 @@ its response can be seen."
;; comint-dynamic-list-filename-completions List completions in help buffer.
;; comint-replace-by-expanded-filename Expand and complete filename at point;
;; replace with expanded/completed name.
-;; comint-dynamic-simple-complete Complete stub given candidates.
-;; These are not installed in the comint-mode keymap. But they are
-;; available for people who want them. Shell-mode installs them:
+;; These are not installed in the comint-mode keymap. But they are
+;; available for people who want them. Shell-mode installs them:
;; (define-key shell-mode-map "\t" 'comint-dynamic-complete)
;; (define-key shell-mode-map "\M-?"
;; 'comint-dynamic-list-filename-completions)))
@@ -2852,14 +2870,16 @@ This mirrors the optional behavior of tcsh."
:group 'comint-completion)
(defcustom comint-completion-addsuffix t
- "If non-nil, add a `/' to completed directories, ` ' to file names.
-If a cons pair, it should be of the form (DIRSUFFIX . FILESUFFIX) where
-DIRSUFFIX and FILESUFFIX are strings added on unambiguous or exact completion.
+ "If non-nil, add ` ' to file names.
+It can either be a string FILESUFFIX or a cons (DIRSUFFIX . FILESUFFIX)
+where DIRSUFFIX is ignored and FILESUFFIX is a string added on unambiguous
+or exact completion.
This mirrors the optional behavior of tcsh."
:type '(choice (const :tag "None" nil)
- (const :tag "Add /" t)
- (cons :tag "Suffix pair"
- (string :tag "Directory suffix")
+ (const :tag "Add SPC" t)
+ (string :tag "File suffix")
+ (cons :tag "Obsolete suffix pair"
+ (string :tag "Ignored")
(string :tag "File suffix")))
:group 'comint-completion)
@@ -2936,7 +2956,7 @@ inside of a \"[...]\" (see `skip-chars-forward'), plus all non-ASCII characters.
(defun comint-substitute-in-file-name (filename)
"Return FILENAME with environment variables substituted.
Supports additional environment variable syntax of the command
-interpreter (e.g., the percent notation of cmd.exe on NT)."
+interpreter (e.g., the percent notation of cmd.exe on Windows)."
(let ((name (substitute-in-file-name filename)))
(if (memq system-type '(ms-dos windows-nt))
(let (env-var-name
@@ -2948,13 +2968,22 @@ interpreter (e.g., the percent notation of cmd.exe on NT)."
(setq name (replace-match env-var-val t t name))))))
name))
+(defun comint--match-partial-filename ()
+ "Return the filename at point as-is, or nil if none is found.
+See `comint-word'."
+ (comint-word comint-file-name-chars))
+
+(defun comint--unquote&expand-filename (filename)
+ ;; FIXME: The code below does unquote-then-expand which means that "\\$HOME"
+ ;; gets expanded to the same as "$HOME"
+ (comint-substitute-in-file-name
+ (comint-unquote-filename filename)))
+
(defun comint-match-partial-filename ()
- "Return the filename at point, or nil if none is found.
+ "Return the unquoted&expanded filename at point, or nil if none is found.
Environment variables are substituted. See `comint-word'."
- (let ((filename (comint-word comint-file-name-chars)))
- (and filename (comint-substitute-in-file-name
- (comint-unquote-filename filename)))))
-
+ (let ((filename (comint--match-partial-filename)))
+ (and filename (comint--unquote&expand-filename filename))))
(defun comint-quote-filename (filename)
"Return FILENAME with magic characters quoted.
@@ -2982,20 +3011,16 @@ Magic characters are those in `comint-file-name-quote-list'."
(setq i (+ 1 (match-beginning 0)))))
filename)))
-
-(defun comint-dynamic-complete ()
- "Dynamically perform completion at point.
-Calls the functions in `comint-dynamic-complete-functions' to perform
-completion until a function returns non-nil, at which point completion is
-assumed to have occurred."
- (interactive)
+(defun comint-completion-at-point ()
(run-hook-with-args-until-success 'comint-dynamic-complete-functions))
+(define-obsolete-function-alias
+ 'comint-dynamic-complete
+ 'completion-at-point "24.1")
(defun comint-dynamic-complete-filename ()
"Dynamically complete the filename at point.
-Completes if after a filename. See `comint-match-partial-filename' and
-`comint-dynamic-complete-as-filename'.
+Completes if after a filename.
This function is similar to `comint-replace-by-expanded-filename', except that
it won't change parts of the filename already entered in the buffer; it just
adds completion characters to the end of the filename. A completions listing
@@ -3007,82 +3032,128 @@ completions listing is dependent on the value of `comint-completion-autolist'.
Returns t if successful."
(interactive)
- (when (comint-match-partial-filename)
+ (when (comint--match-partial-filename)
(unless (window-minibuffer-p (selected-window))
(message "Completing file name..."))
- (comint-dynamic-complete-as-filename)))
+ (apply #'completion-in-region (comint--complete-file-name-data))))
+
+(defun comint-filename-completion ()
+ "Return completion data for filename at point, if any."
+ (when (comint--match-partial-filename)
+ (comint--complete-file-name-data)))
+
+;; FIXME: comint--common-suffix, comint--common-quoted-suffix, and
+;; comint--table-subvert copied from pcomplete. And they don't fully solve
+;; the problem, since selecting a file from *Completions* won't quote it.
+
+(defun comint--common-suffix (s1 s2)
+ (assert (not (or (string-match "\n" s1) (string-match "\n" s2))))
+ ;; Since S2 is expected to be the "unquoted/expanded" version of S1,
+ ;; there shouldn't be any case difference, even if the completion is
+ ;; case-insensitive.
+ (let ((case-fold-search nil))
+ (string-match ".*?\\(.*\\)\n.*\\1\\'" (concat s1 "\n" s2))
+ (- (match-end 1) (match-beginning 1))))
+
+(defun comint--common-quoted-suffix (s1 s2)
+ "Find the common suffix between S1 and S2 where S1 is the expanded S2.
+S1 is expected to be the unquoted and expanded version of S1.
+Returns (PS1 . PS2), i.e. the shortest prefixes of S1 and S2, such that
+S1 = (concat PS1 SS1) and S2 = (concat PS2 SS2) and
+SS1 = (unquote SS2)."
+ (let* ((cs (comint--common-suffix s1 s2))
+ (ss1 (substring s1 (- (length s1) cs)))
+ (qss1 (comint-quote-filename ss1))
+ qc)
+ (if (and (not (equal ss1 qss1))
+ (setq qc (comint-quote-filename (substring ss1 0 1)))
+ (eq t (compare-strings s2 (- (length s2) cs (length qc) -1)
+ (- (length s2) cs -1)
+ qc nil nil)))
+ ;; The difference found is just that one char is quoted in S2
+ ;; but not in S1, keep looking before this difference.
+ (comint--common-quoted-suffix
+ (substring s1 0 (- (length s1) cs))
+ (substring s2 0 (- (length s2) cs (length qc) -1)))
+ (cons (substring s1 0 (- (length s1) cs))
+ (substring s2 0 (- (length s2) cs))))))
+
+(defun comint--table-subvert (table s1 s2 string pred action)
+ "Completion table that replaces the prefix S1 with S2 in STRING.
+When TABLE, S1 and S2 are provided by `apply-partially', the result
+is a completion table which completes strings of the form (concat S1 S)
+in the same way as TABLE completes strings of the form (concat S2 S)."
+ (let* ((str (if (eq t (compare-strings string 0 (length s1) s1 nil nil
+ completion-ignore-case))
+ (concat s2 (comint-unquote-filename
+ (substring string (length s1))))))
+ (res (if str (complete-with-action action table str pred))))
+ (when res
+ (cond
+ ((and (eq (car-safe action) 'boundaries))
+ (let ((beg (or (and (eq (car-safe res) 'boundaries) (cadr res)) 0)))
+ (list* 'boundaries
+ (max (length s1)
+ ;; FIXME: Adjust because of quoting/unquoting.
+ (+ beg (- (length s1) (length s2))))
+ (and (eq (car-safe res) 'boundaries) (cddr res)))))
+ ((stringp res)
+ (if (eq t (compare-strings res 0 (length s2) s2 nil nil
+ completion-ignore-case))
+ (concat s1 (comint-quote-filename
+ (substring res (length s2))))))
+ ((eq action t)
+ (let ((bounds (completion-boundaries str table pred "")))
+ (if (>= (car bounds) (length s2))
+ res
+ (let ((re (concat "\\`"
+ (regexp-quote (substring s2 (car bounds))))))
+ (delq nil
+ (mapcar (lambda (c)
+ (if (string-match re c)
+ (substring c (match-end 0))))
+ res))))))
+ ;; E.g. action=nil and it's the only completion.
+ (res)))))
+
+(defun comint--complete-file-name-data ()
+ "Return the completion data for file name at point."
+ (let* ((filesuffix (cond ((not comint-completion-addsuffix) "")
+ ((stringp comint-completion-addsuffix)
+ comint-completion-addsuffix)
+ ((not (consp comint-completion-addsuffix)) " ")
+ (t (cdr comint-completion-addsuffix))))
+ (filename (comint--match-partial-filename))
+ (filename-beg (if filename (match-beginning 0) (point)))
+ (filename-end (if filename (match-end 0) (point)))
+ (unquoted (if filename (comint--unquote&expand-filename filename) ""))
+ (table
+ (let ((prefixes (comint--common-quoted-suffix
+ unquoted filename)))
+ (apply-partially
+ #'comint--table-subvert
+ #'completion-file-name-table
+ (cdr prefixes) (car prefixes)))))
+ (list
+ filename-beg filename-end
+ (lambda (string pred action)
+ (let ((completion-ignore-case read-file-name-completion-ignore-case)
+ (completion-ignored-extensions comint-completion-fignore))
+ (if (zerop (length filesuffix))
+ (complete-with-action action table string pred)
+ ;; Add a space at the end of completion. Use a terminator-regexp
+ ;; that never matches since the terminator cannot appear
+ ;; within the completion field anyway.
+ (completion-table-with-terminator
+ (cons filesuffix "\\`a\\`")
+ table string pred action)))))))
(defun comint-dynamic-complete-as-filename ()
"Dynamically complete at point as a filename.
See `comint-dynamic-complete-filename'. Returns t if successful."
- (let* ((completion-ignore-case read-file-name-completion-ignore-case)
- (completion-ignored-extensions comint-completion-fignore)
- ;; If we bind this, it breaks remote directory tracking in rlogin.el.
- ;; I think it was originally bound to solve file completion problems,
- ;; but subsequent changes may have made this unnecessary. sm.
- ;;(file-name-handler-alist nil)
- (minibuffer-p (window-minibuffer-p (selected-window)))
- (success t)
- (dirsuffix (cond ((not comint-completion-addsuffix)
- "")
- ((not (consp comint-completion-addsuffix))
- "/")
- (t
- (car comint-completion-addsuffix))))
- (filesuffix (cond ((not comint-completion-addsuffix)
- "")
- ((not (consp comint-completion-addsuffix))
- " ")
- (t
- (cdr comint-completion-addsuffix))))
- (filename (comint-match-partial-filename))
- (filename-beg (if filename (match-beginning 0) (point)))
- (filename-end (if filename (match-end 0) (point)))
- (filename (or filename ""))
- (filedir (file-name-directory filename))
- (filenondir (file-name-nondirectory filename))
- (directory (if filedir (comint-directory filedir) default-directory))
- (completion (file-name-completion filenondir directory)))
- (cond ((null completion)
- (if minibuffer-p
- (minibuffer-message "No completions of %s" filename)
- (message "No completions of %s" filename))
- (setq success nil))
- ((eq completion t) ; Means already completed "file".
- (insert filesuffix)
- (unless minibuffer-p
- (message "Sole completion")))
- ((string-equal completion "") ; Means completion on "directory/".
- (comint-dynamic-list-filename-completions))
- (t ; Completion string returned.
- (let ((file (concat (file-name-as-directory directory) completion)))
- ;; Insert completion. Note that the completion string
- ;; may have a different case than what's in the prompt,
- ;; if read-file-name-completion-ignore-case is non-nil,
- (delete-region filename-beg filename-end)
- (if filedir (insert (comint-quote-filename filedir)))
- (insert (comint-quote-filename (directory-file-name completion)))
- (cond ((symbolp (file-name-completion completion directory))
- ;; We inserted a unique completion.
- (insert (if (file-directory-p file) dirsuffix filesuffix))
- (unless minibuffer-p
- (message "Completed")))
- ((and comint-completion-recexact comint-completion-addsuffix
- (string-equal filenondir completion)
- (file-exists-p file))
- ;; It's not unique, but user wants shortest match.
- (insert (if (file-directory-p file) dirsuffix filesuffix))
- (unless minibuffer-p
- (message "Completed shortest")))
- ((or comint-completion-autolist
- (string-equal filenondir completion))
- ;; It's not unique, list possible completions.
- (comint-dynamic-list-filename-completions))
- (t
- (unless minibuffer-p
- (message "Partially completed")))))))
- success))
-
+ (apply #'completion-in-region (comint--complete-file-name-data)))
+(make-obsolete 'comint-dynamic-complete-as-filename
+ 'comint-filename-completion "24.1")
(defun comint-replace-by-expanded-filename ()
"Dynamically expand and complete the filename at point.
@@ -3155,28 +3226,20 @@ See also `comint-dynamic-complete-filename'."
(unless minibuffer-p
(message "Partially completed"))
'partial)))))))
+(make-obsolete 'comint-dynamic-simple-complete 'completion-in-region "24.1")
(defun comint-dynamic-list-filename-completions ()
"Display a list of possible completions for the filename at point."
(interactive)
- (let* ((completion-ignore-case read-file-name-completion-ignore-case)
- ;; If we bind this, it breaks remote directory tracking in rlogin.el.
- ;; I think it was originally bound to solve file completion problems,
- ;; but subsequent changes may have made this unnecessary. sm.
- ;;(file-name-handler-alist nil)
- (filename (or (comint-match-partial-filename) ""))
- (filedir (file-name-directory filename))
- (filenondir (file-name-nondirectory filename))
- (directory (if filedir (comint-directory filedir) default-directory))
- (completions (file-name-all-completions filenondir directory)))
- (if (not completions)
- (if (window-minibuffer-p (selected-window))
- (minibuffer-message "No completions of %s" filename)
- (message "No completions of %s" filename))
- (comint-dynamic-list-completions
- (mapcar 'comint-quote-filename completions)
- (comint-quote-filename filenondir)))))
+ (let* ((data (comint--complete-file-name-data))
+ (minibuffer-completion-table (nth 2 data))
+ (minibuffer-completion-predicate nil)
+ (ol (make-overlay (nth 0 data) (nth 1 data) nil nil t)))
+ (overlay-put ol 'field 'completion)
+ (unwind-protect
+ (call-interactively 'minibuffer-completion-help)
+ (delete-overlay ol))))
;; This is bound locally in a *Completions* buffer to the list of
@@ -3244,7 +3307,6 @@ Typing SPC flushes the completions buffer."
(if (eq first ?\s)
(set-window-configuration comint-dynamic-list-completions-config)
(setq unread-command-events (listify-key-sequence key)))))))
-
(defun comint-get-next-from-history ()
"After fetching a line from input history, this fetches the following line.
@@ -3742,9 +3804,8 @@ REGEXP-GROUP is the regular expression group in REGEXP to use."
;;
;; For modes that use comint-mode, comint-dynamic-complete-functions is the
;; hook to add completion functions to. Functions on this list should return
-;; non-nil if completion occurs (i.e., further completion should not occur).
-;; You could use comint-dynamic-simple-complete to do the bulk of the
-;; completion job.
+;; the completion data according to the documentation of
+;; `completion-at-point-functions'
(provide 'comint)
diff --git a/lisp/completion.el b/lisp/completion.el
index b0e2c404485..ad7e781bb7a 100644
--- a/lisp/completion.el
+++ b/lisp/completion.el
@@ -1,7 +1,7 @@
;;; completion.el --- dynamic word-completion code
-;; Copyright (C) 1990, 1993, 1995, 1997, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990, 1993, 1995, 1997, 2001-2011
+;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: abbrev convenience
@@ -695,7 +695,7 @@ Returns nil if there isn't one longer than `completion-min-length'."
;; Conditionalizing code on *record-cmpl-statistics-p*
;;-----------------------------------------------
;; All statistics code outside this block should use this
-(defmacro cmpl-statistics-block (&rest body))
+(defmacro cmpl-statistics-block (&rest _body))
;; "Only executes body if we are recording statistics."
;; (list 'cond
;; (list* '*record-cmpl-statistics-p* body)
@@ -1751,7 +1751,7 @@ Prefix args ::
(save-excursion
(goto-char (point-min))
(let (string)
- (condition-case e
+ (condition-case nil
(while t
(search-forward "\177")
(backward-char 3)
@@ -1788,7 +1788,7 @@ Prefix args ::
(let (string)
(save-excursion
(goto-char (point-min))
- (condition-case e
+ (condition-case nil
(while t
(re-search-forward *lisp-def-regexp*)
(and (setq string (symbol-under-point))
@@ -2042,7 +2042,7 @@ If file name is not specified, use `save-completions-file-name'."
last-use-time)) "\n"))))
;; write the buffer
- (condition-case e
+ (condition-case nil
(let ((file-exists-p (file-exists-p filename)))
(if file-exists-p
(progn
@@ -2108,7 +2108,7 @@ If file is not specified, then use `save-completions-file-name'."
(aref completion-add-count-vector cmpl-source-file-parsing)))
(total-in-file 0) (total-perm 0))
;; insert the file into a buffer
- (condition-case e
+ (condition-case nil
(progn (insert-file-contents filename t)
(setq insert-okay-p t))
@@ -2120,7 +2120,7 @@ If file is not specified, then use `save-completions-file-name'."
(progn
(goto-char (point-min))
- (condition-case e
+ (condition-case nil
(while t
(setq entry (read buffer))
(setq total-in-file (1+ total-in-file))
@@ -2470,5 +2470,4 @@ TYPE is the type of the wrapper to be added. Can be :before or :under."
(provide 'completion)
-;; arch-tag: 6990dafe-4abd-4a1f-8c42-ffb25e120f5e
;;; completion.el ends here
diff --git a/lisp/composite.el b/lisp/composite.el
index 8b72dc49952..11a3d5ba388 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.")
@@ -286,9 +289,7 @@ A composition rule is a cons of glyph reference points of the form
(let (str components)
(if (consp (car (cdr args)))
;; Rule-base composition.
- (let ((len (length args))
- (tail (encode-composition-components args 'nocopy)))
-
+ (let ((tail (encode-composition-components args 'nocopy)))
(while tail
(setq str (cons (car tail) str))
(setq tail (nthcdr 2 tail)))
@@ -410,27 +411,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))
@@ -466,8 +446,8 @@ after a sequence of character events."
(defun lgstring-insert-glyph (gstring idx glyph)
(let ((nglyphs (lgstring-glyph-len gstring))
- (i idx) g)
- (while (and (< i nglyphs) (setq g (lgstring-glyph gstring i)))
+ (i idx))
+ (while (and (< i nglyphs) (lgstring-glyph gstring i))
(setq i (1+ i)))
(if (= i nglyphs)
(setq gstring (vconcat gstring (vector glyph)))
@@ -481,8 +461,7 @@ after a sequence of character events."
(defun compose-glyph-string (gstring from to)
(let ((glyph (lgstring-glyph gstring from))
- from-pos to-pos
- ascent descent lbearing rbearing)
+ from-pos to-pos)
(setq from-pos (lglyph-from glyph)
to-pos (lglyph-to (lgstring-glyph gstring (1- to))))
(lglyph-set-from-to glyph from-pos to-pos)
@@ -500,7 +479,7 @@ after a sequence of character events."
(let ((font-object (lgstring-font gstring))
(glyph (lgstring-glyph gstring from))
from-pos to-pos
- ascent descent lbearing rbearing)
+ ascent descent)
(if gap
(setq gap (floor (* (font-get font-object :size) gap)))
(setq gap 0))
@@ -515,7 +494,7 @@ after a sequence of character events."
(lglyph-set-from-to glyph from-pos to-pos)
(let ((this-ascent (lglyph-ascent glyph))
(this-descent (lglyph-descent glyph))
- xoff yoff wadjust)
+ xoff yoff)
(setq xoff (if (<= (lglyph-rbearing glyph) 0) 0
(- (lglyph-width glyph))))
(if (> this-ascent 0)
@@ -532,24 +511,23 @@ 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))
- (nglyphs (lgstring-glyph-len gstring))
- (glyph (lgstring-glyph gstring 0)))
+ (let ((nchars (lgstring-char-len gstring))
+ (nglyphs (lgstring-glyph-len gstring))
+ (glyph (lgstring-glyph gstring 0)))
(cond
;; A non-spacing character not following a proper base character.
((= nchars 1)
(let ((lbearing (lglyph-lbearing glyph))
(rbearing (lglyph-rbearing glyph))
(width (lglyph-width glyph))
- xoff wadjust)
+ xoff)
(if (< lbearing 0)
(setq xoff (- lbearing))
(setq xoff 0 lbearing 0))
@@ -579,8 +557,7 @@ All non-spacing characters has this function in
(rbearing (lglyph-rbearing glyph))
(lbearing (lglyph-lbearing glyph))
(center (/ (+ lbearing rbearing) 2))
- (gap (round (* (font-get (lgstring-font gstring) :size) 0.1)))
- xoff yoff)
+ (gap (round (* (font-get (lgstring-font gstring) :size) 0.1))))
(dotimes (i nchars)
(setq glyph (lgstring-glyph gstring i))
(when (> i 0)
@@ -660,22 +637,20 @@ 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."
- (let* ((header (lgstring-header gstring))
- (nchars (lgstring-char-len gstring))
- (nglyphs (lgstring-glyph-len gstring))
- (i 0)
- (coding (lgstring-font gstring))
- glyph)
+prepending a space before it."
+ (let ((nglyphs (lgstring-glyph-len gstring))
+ (i 0)
+ (coding (lgstring-font gstring))
+ glyph)
(while (and (< i nglyphs)
(setq glyph (lgstring-glyph gstring i)))
(if (not (char-charset (lglyph-char glyph) coding))
@@ -745,14 +720,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 +737,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 93462bd5ade..5e74c68978f 100644
--- a/lisp/cus-dep.el
+++ b/lisp/cus-dep.el
@@ -1,10 +1,10 @@
;;; cus-dep.el --- find customization dependencies
;;
-;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2001-2011 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -171,5 +171,4 @@ Usage: emacs -batch -l ./cus-dep.el -f custom-make-dependencies DIRS"
-;; arch-tag: b7b6421a-bf7a-44fd-a382-6f44976bdf68
;;; cus-dep.el ends here
diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el
index 9e20be9297c..f14c055d7a8 100644
--- a/lisp/cus-edit.el
+++ b/lisp/cus-edit.el
@@ -1,11 +1,11 @@
;;; cus-edit.el --- tools for customizing Emacs and Lisp packages
;;
-;; Copyright (C) 1996, 1997, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1997, 1999-2011 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Maintainer: FSF
;; Keywords: help, faces
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -166,10 +166,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 +203,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 +242,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 +288,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 +314,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 +323,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 +438,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 +669,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 +734,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."
@@ -796,7 +792,7 @@ and `yes-or-no-p' otherwise."
(message "Aborted")
nil))
-(defun Custom-set (&rest ignore)
+(defun Custom-set (&rest _ignore)
"Set the current value of all edited settings in the buffer."
(interactive)
(custom-command-apply
@@ -805,7 +801,7 @@ and `yes-or-no-p' otherwise."
(widget-apply child :custom-set)))
"Set all values according to this buffer? "))
-(defun Custom-save (&rest ignore)
+(defun Custom-save (&rest _ignore)
"Set all edited settings, then save all settings that have been set.
If a setting was edited and set before, this saves it. If a
setting was merely edited before, this sets it then saves it."
@@ -821,7 +817,7 @@ setting was merely edited before, this sets it then saves it."
(dolist (child custom-options)
(widget-apply child :custom-state-set-and-redraw))))
-(defun custom-reset (widget &optional event)
+(defun custom-reset (_widget &optional event)
"Select item from reset menu."
(let* ((completion-ignore-case t)
(answer (widget-choose "Reset settings"
@@ -830,7 +826,7 @@ setting was merely edited before, this sets it then saves it."
(if answer
(funcall answer))))
-(defun Custom-reset-current (&rest ignore)
+(defun Custom-reset-current (&rest _ignore)
"Reset all edited settings in the buffer to show their current values."
(interactive)
(custom-command-apply
@@ -839,7 +835,7 @@ setting was merely edited before, this sets it then saves it."
(widget-apply widget :custom-reset-current)))
"Reset all settings' buffer text to show current values? "))
-(defun Custom-reset-saved (&rest ignore)
+(defun Custom-reset-saved (&rest _ignore)
"Reset all edited or set settings in the buffer to their saved value.
This also shows the saved values in the buffer."
(interactive)
@@ -880,7 +876,6 @@ This also shows the saved values in the buffer."
(unless (eq widget t)
(let* ((symbol (widget-value widget))
(child (car (widget-get widget :children)))
- (value (get symbol 'face-defface-spec))
(comment-widget (widget-get widget :comment-widget)))
(put symbol 'face-comment nil)
(widget-value-set child
@@ -892,7 +887,7 @@ This also shows the saved values in the buffer."
(custom-face-state-set widget)
(custom-redraw-magic widget))))))
-(defun Custom-reset-standard (&rest ignore)
+(defun Custom-reset-standard (&rest _ignore)
"Erase all customizations (either current or saved) in current buffer.
The immediate result is to restore them to their standard values.
This operation eliminates any saved values for the group members,
@@ -924,6 +919,8 @@ it were the arg to `interactive' (which see) to interactively read the value.
If the variable has a `custom-type' property, it must be a widget and the
`:prompt-value' property of that widget will be used for reading the value.
+If the variable also has a `custom-get' property, that is used for finding
+the current value of the variable, otherwise `symbol-value' is used.
If optional COMMENT argument is non-nil, also prompt for a comment and return
it as the third element in the list."
@@ -945,7 +942,9 @@ it as the third element in the list."
(widget-prompt-value type
prompt
(if (boundp var)
- (symbol-value var))
+ (funcall
+ (or (get var 'custom-get) 'symbol-value)
+ var))
(not (boundp var))))
(t
(eval-minibuffer prompt))))))
@@ -1136,7 +1135,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 +1381,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)
+ (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*"))))
@@ -1526,7 +1535,7 @@ This button will have a menu with all three reset operations."
:type 'boolean
:group 'custom-buffer)
-(defun Custom-buffer-done (&rest ignore)
+(defun Custom-buffer-done (&rest _ignore)
"Exit current Custom buffer according to `custom-buffer-done-kill'."
(interactive)
(quit-window custom-buffer-done-kill))
@@ -1540,6 +1549,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.
@@ -1558,19 +1573,14 @@ Otherwise use brackets."
'custom-button-pressed
'custom-button-pressed-unraised))))
-(defun custom-buffer-create-internal (options &optional description)
+(defun custom-buffer-create-internal (options &optional _description)
(Custom-mode)
(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 +1592,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 (split-string (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 +1619,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
@@ -1713,7 +1742,7 @@ item in another window.\n\n"))
:format "%[[%t]%]"
:action 'custom-browse-visibility-action)
-(defun custom-browse-visibility-action (widget &rest ignore)
+(defun custom-browse-visibility-action (widget &rest _ignore)
(let ((custom-buffer-style 'tree))
(custom-toggle-parent widget)))
@@ -1723,7 +1752,7 @@ item in another window.\n\n"))
:tag-glyph "folder"
:action 'custom-browse-group-tag-action)
-(defun custom-browse-group-tag-action (widget &rest ignore)
+(defun custom-browse-group-tag-action (widget &rest _ignore)
(let ((parent (widget-get widget :parent)))
(customize-group-other-window (widget-value parent))))
@@ -1733,7 +1762,7 @@ item in another window.\n\n"))
:tag-glyph "option"
:action 'custom-browse-variable-tag-action)
-(defun custom-browse-variable-tag-action (widget &rest ignore)
+(defun custom-browse-variable-tag-action (widget &rest _ignore)
(let ((parent (widget-get widget :parent)))
(customize-variable-other-window (widget-value parent))))
@@ -1743,7 +1772,7 @@ item in another window.\n\n"))
:tag-glyph "face"
:action 'custom-browse-face-tag-action)
-(defun custom-browse-face-tag-action (widget &rest ignore)
+(defun custom-browse-face-tag-action (widget &rest _ignore)
(let ((parent (widget-get widget :parent)))
(customize-face-other-window (widget-value parent))))
@@ -1779,7 +1808,7 @@ item in another window.\n\n"))
(widget-put (get 'item 'widget-type) :custom-show t)
(widget-put (get 'editable-field 'widget-type)
- :custom-show (lambda (widget value)
+ :custom-show (lambda (_widget value)
(let ((pp (pp-to-string value)))
(cond ((string-match "\n" pp)
nil)
@@ -1884,7 +1913,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." "\
@@ -1968,7 +1997,7 @@ and `face'."
:value-create 'custom-magic-value-create
:value-delete 'widget-children-value-delete)
-(defun widget-magic-mouse-down-action (widget &optional event)
+(defun widget-magic-mouse-down-action (widget &optional _event)
;; Non-nil unless hidden.
(not (eq (widget-get (widget-get (widget-get widget :parent) :parent)
:custom-state)
@@ -1988,68 +2017,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.
@@ -2150,7 +2181,7 @@ and `face'."
:value-delete 'widget-children-value-delete
:value-get 'widget-value-value-get
:validate 'widget-children-validate
- :match (lambda (widget value) (symbolp value)))
+ :match (lambda (_widget value) (symbolp value)))
(defun custom-convert-widget (widget)
"Initialize :value and :tag from :args in WIDGET."
@@ -2206,12 +2237,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."
@@ -2253,7 +2281,7 @@ and `face'."
(custom-redraw widget)
(widget-setup)))
-(defun custom-toggle-parent (widget &rest ignore)
+(defun custom-toggle-parent (widget &rest _ignore)
"Toggle visibility of parent of WIDGET."
(custom-toggle-hide (widget-get widget :parent)))
@@ -2289,8 +2317,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 +2336,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 +2410,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 +2454,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 +2515,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 +2522,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 +2551,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-glyph "down"
+ :on "Hide"
+ :off-glyph "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-glyph "down"
+ :off-glyph "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 +2591,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 +2600,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-glyph "down"
+ :off-glyph "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 +2627,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 +2636,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 +2661,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 +2674,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 +2709,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 +3057,9 @@ to switch between two values."
:button-face 'custom-visibility
:pressed-face 'custom-visibility
:mouse-face 'highlight
- :pressed-face 'highlight)
+ :pressed-face 'highlight
+ :on-glyph nil
+ :off-glyph nil)
(defface custom-visibility
'((t :height 0.8 :inherit link))
@@ -3009,48 +3070,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-fix-value (widget value)
+(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-glyph nil :off-glyph 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 +3155,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 +3169,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 +3312,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 +3360,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 +3401,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-glyph "down" :off-glyph "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 +3634,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 +3690,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 +3712,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 "")
@@ -3689,7 +3829,7 @@ restoring it to the state of a face that has never been customized."
:value 'default
:sample-face-get 'widget-face-sample-face-get
:notify 'widget-face-notify
- :match (lambda (widget value) (facep value))
+ :match (lambda (_widget value) (facep value))
:complete-function (lambda ()
(interactive)
(lisp-complete-symbol 'facep))
@@ -3719,7 +3859,7 @@ restoring it to the state of a face that has never been customized."
(define-widget 'hook 'list
"An Emacs Lisp hook."
- :value-to-internal (lambda (widget value)
+ :value-to-internal (lambda (_widget value)
(if (and value (symbolp value))
(list value)
value))
@@ -3764,7 +3904,7 @@ restoring it to the state of a face that has never been customized."
:follow-link 'mouse-face
:action 'custom-group-link-action)
-(defun custom-group-link-action (widget &rest ignore)
+(defun custom-group-link-action (widget &rest _ignore)
(customize-group (widget-value widget)))
;;; The `custom-group' Widget.
@@ -3920,8 +4060,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 +4122,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 +4156,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 +4182,49 @@ 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)))
+ (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
@@ -4360,6 +4508,8 @@ This function does not save the buffer."
(setq pos (line-beginning-position))))
(goto-char pos)))))
+(defvar sort-fold-case) ; defined in sort.el
+
(defun custom-save-variables ()
"Save all customized variables in `custom-file'."
(save-excursion
@@ -4379,10 +4529,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))
@@ -4455,10 +4605,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))
@@ -4498,13 +4648,13 @@ This function does not save the buffer."
:type 'integer
:group 'custom-menu)
-(defun custom-face-menu-create (widget symbol)
+(defun custom-face-menu-create (_widget symbol)
"Ignoring WIDGET, create a menu entry for customization face SYMBOL."
(vector (custom-unlispify-menu-entry symbol)
`(customize-face ',symbol)
t))
-(defun custom-variable-menu-create (widget symbol)
+(defun custom-variable-menu-create (_widget symbol)
"Ignoring WIDGET, create a menu entry for customization variable SYMBOL."
(let ((type (get symbol 'custom-type)))
(unless (listp type)
@@ -4517,13 +4667,13 @@ This function does not save the buffer."
;; Add checkboxes to boolean variable entries.
(widget-put (get 'boolean 'widget-type)
- :custom-menu (lambda (widget symbol)
+ :custom-menu (lambda (_widget symbol)
(vector (custom-unlispify-menu-entry symbol)
`(customize-variable ',symbol)
':style 'toggle
':selected symbol)))
-(defun custom-group-menu-create (widget symbol)
+(defun custom-group-menu-create (_widget symbol)
"Ignoring WIDGET, create a menu entry for customization group SYMBOL."
`( ,(custom-unlispify-menu-entry symbol t)
:filter (lambda (&rest junk)
@@ -4597,7 +4747,7 @@ The format is suitable for use with `easy-menu-define'."
;;; The Custom Mode.
-(defun Custom-no-edit (pos &optional event)
+(defun Custom-no-edit (_pos &optional _event)
"Invoke button at POS, or refuse to allow editing of Custom buffer."
(interactive "@d")
(error "You can't edit this part of the Custom buffer"))
@@ -4606,6 +4756,12 @@ The format is suitable for use with `easy-menu-define'."
"Invoke button at POS, or refuse to allow editing of Custom buffer."
(interactive "@d")
(let ((button (get-char-property pos 'button)))
+ ;; If there is no button at point, then use the one at the start
+ ;; of the line, if it is a custom-group-link (bug#2298).
+ (or button
+ (if (setq button (get-char-property (line-beginning-position) 'button))
+ (or (eq (widget-type button) 'custom-group-link)
+ (setq button nil))))
(if button
(widget-apply-action button event)
(error "You can't edit this part of the Custom buffer"))))
@@ -4630,6 +4786,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.
@@ -4661,33 +4836,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)
@@ -4717,5 +4872,4 @@ if that value is non-nil."
(provide 'cus-edit)
-;; arch-tag: 64533aa4-1b1a-48c3-8812-f9dc718e8a6f
;;; cus-edit.el ends here
diff --git a/lisp/cus-face.el b/lisp/cus-face.el
index a7d3c04935f..90f21f32149 100644
--- a/lisp/cus-face.el
+++ b/lisp/cus-face.el
@@ -1,10 +1,10 @@
;;; cus-face.el --- customization support for faces
;;
-;; Copyright (C) 1996, 1997, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1997, 1999-2011 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: help, faces
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -34,28 +34,30 @@
(defun custom-declare-face (face spec doc &rest args)
"Like `defface', but FACE is evaluated as a normal argument."
(unless (get face 'face-defface-spec)
- (when (fboundp 'facep)
- (unless (facep face)
- ;; If the user has already created the face, respect that.
- (let ((value (or (get face 'saved-face) spec))
- (have-window-system (memq initial-window-system '(x w32))))
- ;; Create global face.
- (make-empty-face face)
- ;; Create frame-local faces
- (dolist (frame (frame-list))
- (face-spec-set-2 face frame value)
- (when (memq (window-system frame) '(x w32 ns))
- (setq have-window-system t)))
- ;; When making a face after frames already exist
- (if have-window-system
- (make-face-x-resource-internal face)))))
+ (unless (facep face)
+ ;; If the user has already created the face, respect that.
+ (let ((value (or (get face 'saved-face) spec))
+ (have-window-system (memq initial-window-system '(x w32))))
+ ;; Create global face.
+ (make-empty-face face)
+ ;; Create frame-local faces
+ (dolist (frame (frame-list))
+ (face-spec-set-2 face frame value)
+ (when (memq (window-system frame) '(x w32 ns))
+ (setq have-window-system t)))
+ ;; When making a face after frames already exist
+ (if have-window-system
+ (make-face-x-resource-internal face))))
;; Don't record SPEC until we see it causes no errors.
(put face 'face-defface-spec (purecopy spec))
(push (cons 'defface face) current-load-list)
(when (and doc (null (face-documentation face)))
(set-face-documentation face (purecopy doc)))
(custom-handle-all-keywords face args 'custom-face)
- (run-hooks 'custom-define-hook))
+ (run-hooks 'custom-define-hook)
+ ;; If the face has an existing theme setting, recalculate it.
+ (if (get face 'theme-face)
+ (custom-theme-recalc-face face)))
face)
;;; Face attributes.
@@ -318,44 +320,37 @@ 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))))))))
-
-;; XEmacs compability function. In XEmacs, when you reset a Custom
+ (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 compatibility function. In XEmacs, when you reset a Custom
;; Theme, you have to specify the theme to reset it to. We just apply
;; the next theme.
(defun custom-theme-reset-faces (theme &rest args)
@@ -384,5 +379,4 @@ This means reset FACE to its value in FROM-THEME."
(provide 'cus-face)
-;; arch-tag: 9a5c4b63-0d27-4c92-a5af-f2c7ed764c2b
;;; cus-face.el ends here
diff --git a/lisp/cus-start.el b/lisp/cus-start.el
index 4f3faf8a063..6113a4321c5 100644
--- a/lisp/cus-start.el
+++ b/lisp/cus-start.el
@@ -1,10 +1,10 @@
;;; cus-start.el --- define customization properties of builtins
;;
-;; Copyright (C) 1997, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 1999-2011 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -33,6 +33,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 +108,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
@@ -143,12 +166,6 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of
(max-mini-window-height limits
(choice (const :tag "quarter screen" nil)
number) "23.1")
- (stack-trace-on-error debug
- (choice (const :tag "off")
- (repeat :menu-tag "When"
- :value (nil)
- (symbol :format "%v"))
- (const :tag "always" t)))
(debug-on-error debug
(choice (const :tag "off")
(repeat :menu-tag "When"
@@ -165,6 +182,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 +226,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,9 +251,19 @@ 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")))
+ (debug-on-event debug
+ (choice (const :tag "None" nil)
+ (const :tag "When sent SIGUSR1" sigusr1)
+ (const :tag "When sent SIGUSR2" sigusr2))
+ "24.1")
;; This is not good news because it will use the wrong
;; version-specific directories when you upgrade. We need
@@ -254,12 +318,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)
@@ -281,6 +361,7 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of
(const alt) (const hyper)
(const super)) "23.1")
(ns-antialias-text ns boolean "23.1")
+ (ns-auto-hide-menu-bar ns boolean "24.0")
;; process.c
(delete-exited-processes processes-basics boolean)
;; syntax.c
@@ -321,6 +402,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 +430,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 +452,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 +478,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 +505,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 +517,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 85aeb32b9c6..86fb43be72a 100644
--- a/lisp/cus-theme.el
+++ b/lisp/cus-theme.el
@@ -1,11 +1,11 @@
;;; cus-theme.el -- custom theme creation user interface
;;
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;;
;; Author: Alex Schroeder <alex@gnu.org>
;; Maintainer: FSF
;; Keywords: help, faces
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -34,318 +34,361 @@
(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)
+ (when (called-interactively-p 'interactive)
+ (unless (y-or-n-p "Include basic face customizations in this theme? ")
+ (setq custom-theme--listed-faces nil)))
+
+ (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)
+ :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)
+ :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) (eval (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))))
+;;;###autoload
+(defun custom-theme-visit-theme (theme)
+ "Set up a Custom buffer to edit custom theme THEME."
+ (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)
+;; From cus-edit.el
+(defvar custom-reset-standard-faces-list)
+(defvar custom-reset-standard-variables-list)
+
+(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 +399,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 +431,246 @@ 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")))))
-;; arch-tag: cd6919bc-63af-410e-bae2-b6702e762344
+
+;;; 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)
+ (switch-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.
+ (progn
+ (disable-theme this-theme)
+ (widget-toggle-action widget event))
+ ;; 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))))
+ (when (load-theme this-theme)
+ (widget-toggle-action widget event)))
+ ;; Mark `custom-enabled-themes' as "set for current session".
+ (put 'custom-enabled-themes 'customized-value
+ (list (custom-quote custom-enabled-themes)))))
+
+(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)))
+
+(provide 'cus-theme)
+
;;; cus-theme.el ends here
diff --git a/lisp/custom.el b/lisp/custom.el
index 9a87bf68ac2..8295777f1f1 100644
--- a/lisp/custom.el
+++ b/lisp/custom.el
@@ -1,11 +1,11 @@
;;; custom.el --- tools for declaring and initializing options
;;
-;; Copyright (C) 1996, 1997, 1999, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1997, 1999, 2001-2011 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Maintainer: FSF
;; Keywords: help, faces
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -55,11 +55,9 @@ Otherwise, if symbol has a `saved-value' property, it will evaluate
the car of that and use it as the default binding for symbol.
Otherwise, VALUE will be evaluated and used as the default binding for
symbol."
- (unless (default-boundp symbol)
- ;; Use the saved value if it exists, otherwise the standard setting.
- (set-default symbol (eval (if (get symbol 'saved-value)
- (car (get symbol 'saved-value))
- value)))))
+ (eval `(defvar ,symbol ,(if (get symbol 'saved-value)
+ (car (get symbol 'saved-value))
+ value))))
(defun custom-initialize-set (symbol value)
"Initialize SYMBOL based on VALUE.
@@ -81,15 +79,15 @@ The value is either the symbol's current value
\(as obtained using the `:get' function), if any,
or the value in the symbol's `saved-value' property if any,
or (last of all) VALUE."
- (funcall (or (get symbol 'custom-set) 'set-default)
- symbol
- (cond ((default-boundp symbol)
- (funcall (or (get symbol 'custom-get) 'default-value)
- symbol))
- ((get symbol 'saved-value)
- (eval (car (get symbol 'saved-value))))
- (t
- (eval value)))))
+ (funcall (or (get symbol 'custom-set) 'set-default)
+ symbol
+ (cond ((default-boundp symbol)
+ (funcall (or (get symbol 'custom-get) 'default-value)
+ symbol))
+ ((get symbol 'saved-value)
+ (eval (car (get symbol 'saved-value))))
+ (t
+ (eval value)))))
(defun custom-initialize-changed (symbol value)
"Initialize SYMBOL with VALUE.
@@ -111,7 +109,7 @@ For the standard setting, use `set-default'."
(defvar custom-delayed-init-variables nil
"List of variables whose initialization is pending.")
-(defun custom-initialize-delay (symbol value)
+(defun custom-initialize-delay (symbol _value)
"Delay initialization of SYMBOL to the next Emacs start.
This is used in files that are preloaded (or for autoloaded
variables), so that the initialization is done in the run-time
@@ -142,8 +140,8 @@ set to nil, as the value is no longer rogue."
;; Maybe this option was rogue in an earlier version. It no longer is.
(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"))
(let ((initialize 'custom-initialize-reset)
(requests nil))
(unless (memq :group args)
@@ -187,6 +185,13 @@ set to nil, as the value is no longer rogue."
;; Do the actual initialization.
(unless custom-dont-initialize
(funcall initialize symbol default)))
+ ;; Use defvar to set the docstring as well as the special-variable-p flag.
+ ;; FIXME: We should reproduce more of `defvar's behavior, such as the warning
+ ;; when the var is currently let-bound.
+ (if (not (default-boundp symbol))
+ ;; Don't use defvar to avoid setting a default-value when undesired.
+ (when doc (put symbol 'variable-documentation doc))
+ (eval `(defvar ,symbol nil ,@(when doc (list doc)))))
(push symbol current-load-list)
(run-hooks 'custom-define-hook)
symbol)
@@ -304,15 +309,23 @@ _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.
- (nconc (list 'custom-declare-variable
- (list 'quote symbol)
- (list 'quote value)
- doc)
- args))
+ `(custom-declare-variable
+ ',symbol
+ ,(if lexical-binding ;FIXME: This is not reliable, but is all we have.
+ ;; The `default' arg should be an expression that evaluates to
+ ;; the value to use. The use of `eval' for it is spread over
+ ;; many different places and hence difficult to eliminate, yet
+ ;; we want to make sure that the `value' expression is checked by the
+ ;; byte-compiler, and that lexical-binding is obeyed, so quote the
+ ;; expression with `lambda' rather than with `quote'.
+ `(list (lambda () ,value))
+ `',value)
+ ,doc
+ ,@args))
;;; The `defface' Macro.
@@ -787,10 +800,10 @@ E.g. dumped variables whose default depends on run-time information."
(defvar custom-known-themes '(user changed)
"Themes that have been defined with `deftheme'.
The default value is the list (user changed). The theme `changed'
-contains the settings before custom themes are applied. The
-theme `user' contains all the settings the user customized and saved.
-Additional themes declared with the `deftheme' macro will be added to
-the front of this list.")
+contains the settings before custom themes are applied. The theme
+`user' contains all the settings the user customized and saved.
+Additional themes declared with the `deftheme' macro will be added
+to the front of this list.")
(defsubst custom-theme-p (theme)
"Non-nil when THEME has been defined."
@@ -816,48 +829,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))
+ (val (symbol-value symbol)))
+ (unless (and sv (equal (eval (car sv)) val))
+ (setq old `((changed ,(custom-quote val)))))))
+ ((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 +937,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 +969,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 +1043,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,109 +1062,262 @@ 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 THEME-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
+ "Whether the custom-theme-set-* functions act immediately.
+If nil, `custom-theme-set-variables' and `custom-theme-set-faces'
+change the current values of the given variable or face. If
+non-nil, they just make a record of the theme settings.")
+
(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)
- "Load a theme's settings from its file.
-This also enables the theme; use `disable-theme' to disable it."
- ;; 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: ")
+ (provide (get theme 'theme-feature)))
+
+(defcustom custom-safe-themes '(default)
+ "List of themes that are considered safe to load.
+Each list element should be the `sha1' hash of a theme file, or
+the symbol `default', which stands for any theme in the built-in
+Emacs theme directory (a directory named \"themes\" in
+`data-directory')."
+ :type '(repeat
+ (choice string (const :tag "Built-in themes" default)))
+ :group 'customize
+ :risky t
+ :version "24.1")
+
+(defun load-theme (theme &optional no-enable)
+ "Load Custom theme named THEME from its file.
+Normally, this also enables THEME. If optional arg NO-ENABLE is
+non-nil, load THEME but don't enable it.
+
+The theme file is named THEME-theme.el, in one of the directories
+specified by `custom-theme-load-path'.
+
+Return t if THEME was successfully loaded, nil otherwise."
+ (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")))
+ hash)
+ (unless fn
+ (error "Unable to find theme file for `%s'" theme))
+ (with-temp-buffer
+ (insert-file-contents fn)
+ (setq hash (sha1 (current-buffer)))
+ ;; Check file safety with `custom-safe-themes', prompting the
+ ;; user if necessary.
+ (when (or (and (memq 'default custom-safe-themes)
+ (equal (file-name-directory fn)
+ (expand-file-name "themes/" data-directory)))
+ (member hash custom-safe-themes)
+ (custom-theme-load-confirm hash))
+ (let ((custom--inhibit-theme-enable t))
+ (eval-buffer))
+ ;; Optimization: if the theme changes the `default' face, put that
+ ;; entry first. This avoids some `frame-set-background-mode' rigmarole
+ ;; by assigning the new background immediately.
+ (let* ((settings (get theme 'theme-settings))
+ (tail settings)
+ found)
+ (while (and tail (not found))
+ (and (eq (nth 0 (car tail)) 'theme-face)
+ (eq (nth 1 (car tail)) 'default)
+ (setq found (car tail)))
+ (setq tail (cdr tail)))
+ (if found
+ (put theme 'theme-settings (cons found (delq found settings)))))
+ ;; Finally, enable the theme.
+ (unless no-enable
+ (enable-theme theme))
+ t))))
+
+(defun custom-theme-load-confirm (hash)
+ "Query the user about loading a Custom theme that may not be safe.
+The theme should be in the current buffer. If the user agrees,
+query also about adding HASH to `custom-safe-themes'."
+ (if noninteractive
+ nil
+ (let ((exit-chars '(?y ?n ?\s))
+ window prompt char)
+ (save-window-excursion
+ (rename-buffer "*Custom Theme*" t)
+ (emacs-lisp-mode)
+ (setq window (display-buffer (current-buffer)))
+ (setq prompt
+ (format "Loading a theme can run Lisp code. Really load?%s"
+ (if (and window
+ (< (line-number-at-pos (point-max))
+ (window-body-height)))
+ " (y or n) "
+ (push ?\C-v exit-chars)
+ "\nType y or n, or C-v to scroll: ")))
+ (goto-char (point-min))
+ (while (null char)
+ (setq char (read-char-choice prompt exit-chars))
+ (when (eq char ?\C-v)
+ (if window
+ (with-selected-window window
+ (condition-case nil
+ (scroll-up)
+ (error (goto-char (point-min))))))
+ (setq char nil)))
+ (when (memq char '(?\s ?y))
+ ;; Offer to save to `custom-safe-themes'.
+ (and (or custom-file user-init-file)
+ (y-or-n-p "Treat this theme as safe in future sessions? ")
+ (let ((coding-system-for-read nil))
+ (push hash custom-safe-themes)
+ (customize-save-variable 'custom-safe-themes
+ custom-safe-themes)))
+ t)))))
+
+(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)))))
+ (nreverse (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.
-(defvar custom-enabling-themes nil)
-
(defun enable-theme (theme)
"Reenable all variable and face settings defined by THEME.
-The newly enabled theme gets the highest precedence (after `user').
-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: ")
+THEME should be either `user', or a theme loaded via `load-theme'.
+After this function completes, THEME will have the highest
+precedence (after `user')."
+ (interactive (list (intern
+ (completing-read
+ "Enable custom theme: "
+ obarray (lambda (sym) (get sym 'theme-settings)) t))))
(if (not (custom-theme-p theme))
- (load-theme theme)
- ;; This could use a bit of optimization -- cyd
- (let ((settings (get theme 'theme-settings)))
- (dolist (s settings)
- (let* ((prop (car s))
- (symbol (cadr s))
- (spec-list (get symbol prop)))
- (put symbol prop (cons (cddr s) (assq-delete-all theme spec-list)))
- (if (eq prop 'theme-value)
- (custom-theme-recalc-variable symbol)
- (custom-theme-recalc-face symbol)))))
- (unless (eq theme 'user)
- (setq custom-enabled-themes
- (cons theme (delq theme custom-enabled-themes)))
- (unless custom-enabling-themes
- (enable-theme 'user)))))
+ (error "Undefined Custom theme %s" theme))
+ (let ((settings (get theme 'theme-settings)))
+ ;; Loop through theme settings, recalculating vars/faces.
+ (dolist (s settings)
+ (let* ((prop (car s))
+ (symbol (cadr s))
+ (spec-list (get symbol prop)))
+ (put symbol prop (cons (cddr s) (assq-delete-all theme spec-list)))
+ (cond
+ ((eq prop 'theme-face)
+ (custom-theme-recalc-face symbol))
+ ((eq prop 'theme-value)
+ ;; Don't change `custom-enabled-themes'; that's special.
+ (unless (eq symbol 'custom-enabled-themes)
+ (custom-theme-recalc-variable symbol)))))))
+ (unless (eq theme 'user)
+ (setq custom-enabled-themes
+ (cons theme (delq theme custom-enabled-themes)))
+ ;; Give the `user' theme the highest priority.
+ (enable-theme 'user)))
(defcustom custom-enabled-themes nil
"List of enabled Custom Themes, highest precedence first.
+This list does not include the `user' theme, which is set by
+Customize and always takes precedence over other Custom Themes.
-This does not include the `user' theme, which is set by Customize,
-and always takes precedence over other Custom Themes."
+This variable cannot be defined inside a Custom theme; there, it
+is simply ignored."
: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
+ custom-safe-themes)
+ :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
- ;; custom-enabled-themes, which enables the theme...
- (unless custom-enabling-themes
- (let ((custom-enabling-themes t) failures)
- (setq themes (delq 'user (delete-dups themes)))
- (if (boundp symbol)
- (dolist (theme (symbol-value symbol))
- (if (not (memq theme themes))
- (disable-theme theme))))
- (dolist (theme (reverse themes))
- (condition-case nil
- (enable-theme theme)
- (error (progn (push theme failures)
- (setq themes (delq theme themes))))))
- (enable-theme 'user)
- (custom-set-default symbol themes)
- (if failures
- (message "Failed to enable themes: %s"
- (mapconcat 'symbol-name failures " ")))))))
+ (let (failures)
+ (setq themes (delq 'user (delete-dups themes)))
+ ;; Disable all themes not in THEMES.
+ (if (boundp symbol)
+ (dolist (theme (symbol-value symbol))
+ (if (not (memq theme themes))
+ (disable-theme theme))))
+ ;; Call `enable-theme' or `load-theme' on each of THEMES.
+ (dolist (theme (reverse themes))
+ (condition-case nil
+ (if (custom-theme-p theme)
+ (enable-theme theme)
+ (load-theme theme))
+ (error (setq failures (cons theme failures)
+ themes (delq theme themes)))))
+ (enable-theme 'user)
+ (custom-set-default symbol themes)
+ (if failures
+ (message "Failed to enable theme: %s"
+ (mapconcat 'symbol-name failures ", "))))))
(defsubst custom-theme-enabled-p (theme)
"Return non-nil if THEME is enabled."
@@ -1140,21 +1328,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.
@@ -1162,7 +1356,7 @@ That is to say, it specifies what the value should be according to
currently enabled custom themes.
This function returns nil if no custom theme specifies a value for VARIABLE."
- (let* ((theme-value (get variable 'theme-value)))
+ (let ((theme-value (get variable 'theme-value)))
(if theme-value
(cdr (car theme-value)))))
@@ -1180,10 +1374,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
@@ -1222,5 +1418,4 @@ This means reset VARIABLE. (The argument IGNORED is ignored)."
(provide 'custom)
-;; arch-tag: 041b6116-aabe-4f9a-902d-74092bc3dab2
;;; custom.el ends here
diff --git a/lisp/dabbrev.el b/lisp/dabbrev.el
index 4bc3a33f4ea..00e2ec802e2 100644
--- a/lisp/dabbrev.el
+++ b/lisp/dabbrev.el
@@ -1,7 +1,6 @@
;;; dabbrev.el --- dynamic abbreviation package
-;; Copyright (C) 1985, 1986, 1992, 1994, 1996, 1997, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+;; Copyright (C) 1985-1986, 1992, 1994, 1996-1997, 2000-2011
;; Free Software Foundation, Inc.
;; Author: Don Morrison
@@ -392,8 +391,7 @@ then it searches *all* buffers."
dabbrev-case-fold-search)
(or (not dabbrev-upcase-means-case-search)
(string= abbrev (downcase abbrev)))))
- (my-obarray dabbrev--last-obarray)
- init)
+ (my-obarray dabbrev--last-obarray))
(save-excursion
;;--------------------------------
;; New abbreviation to expand.
@@ -995,5 +993,4 @@ Leaves point at the location of the start of the expansion."
(provide 'dabbrev)
-;; arch-tag: 29e58596-f080-4306-a409-70296cf9d46f
;;; dabbrev.el ends here
diff --git a/lisp/delim-col.el b/lisp/delim-col.el
index 01791b8fc84..d9f8634fb54 100644
--- a/lisp/delim-col.el
+++ b/lisp/delim-col.el
@@ -1,7 +1,6 @@
;;; delim-col.el --- prettify all columns in a region or rectangle
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
@@ -241,6 +240,11 @@ column (column 0) is located at left corner."
;; User Commands:
+;; to avoid compilation gripes
+(defvar delimit-columns-max nil)
+(defvar delimit-columns-limit nil)
+
+
;;;###autoload
(defun delimit-columns-customize ()
"Customization of `columns' group."
@@ -355,12 +359,7 @@ START and END delimits the corners of text rectangle."
;; Internal Variables and Functions:
-;; to avoid compilation gripes
-(defvar delimit-columns-max nil)
-(defvar delimit-columns-limit nil)
-
-
-(defun delimit-columns-rectangle-max (startpos &optional ignore1 ignore2)
+(defun delimit-columns-rectangle-max (startpos &optional _ignore1 _ignore2)
(set-marker delimit-columns-limit (point))
(goto-char startpos)
(let ((ncol 1)
@@ -393,7 +392,7 @@ START and END delimits the corners of text rectangle."
(setq values (cdr values)))))
-(defun delimit-columns-rectangle-line (startpos &optional ignore1 ignore2)
+(defun delimit-columns-rectangle-line (startpos &optional _ignore1 _ignore2)
(let ((len (length delimit-columns-max))
(ncol 0)
origin)
@@ -477,5 +476,4 @@ START and END delimits the corners of text rectangle."
(provide 'delim-col)
-;; arch-tag: 1cc0c5c5-1b2a-43e4-9ba5-bf9441cfd1a9
;;; delim-col.el ends here
diff --git a/lisp/delsel.el b/lisp/delsel.el
index 5f08fd8791a..705b64be89d 100644
--- a/lisp/delsel.el
+++ b/lisp/delsel.el
@@ -1,7 +1,6 @@
;;; delsel.el --- delete selection if you insert
-;; Copyright (C) 1992, 1997, 1998, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 1997-1998, 2001-2011 Free Software Foundation, Inc.
;; Author: Matthieu Devin <devin@lucid.com>
;; Maintainer: FSF
@@ -177,5 +176,4 @@ then it takes a second \\[keyboard-quit] to abort the minibuffer."
(provide 'delsel)
-;; arch-tag: 1e388890-1b50-4ed0-9347-763b1343b6ed
;;; delsel.el ends here
diff --git a/lisp/descr-text.el b/lisp/descr-text.el
index a36e0a9d2d8..fca06adb2a9 100644
--- a/lisp/descr-text.el
+++ b/lisp/descr-text.el
@@ -1,7 +1,6 @@
;;; descr-text.el --- describe text mode
-;; Copyright (C) 1994, 1995, 1996, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1996, 2001-2011 Free Software Foundation, Inc.
;; Author: Boris Goldowsky <boris@gnu.org>
;; Maintainer: FSF
@@ -365,13 +364,13 @@ This function is semi-obsolete. Use `get-char-code-property'."
(let ((mnemonics (category-set-mnemonics category-set)))
(unless (eq mnemonics "")
(list (mapconcat
- #'(lambda (x)
- (let* ((c (category-docstring x))
- (doc (if (string-match "\\`\\(.*?\\)\n\\(.*\\)\\'" c)
- (propertize (match-string 1 c)
- 'help-echo (match-string 2 c))
- c)))
- (format "%c:%s" x doc)))
+ (lambda (x)
+ (let* ((c (category-docstring x))
+ (doc (if (string-match "\\`\\(.*?\\)\n\\(.*\\)\\'" c)
+ (propertize (match-string 1 c)
+ 'help-echo (match-string 2 c))
+ c)))
+ (format "%c:%s" x doc)))
mnemonics ", ")))))
;;;###autoload
@@ -400,7 +399,7 @@ as well as widgets, buttons, overlays, and text properties."
standard-display-table))
(disp-vector (and display-table (aref display-table char)))
(multibyte-p enable-multibyte-characters)
- (overlays (mapcar #'(lambda (o) (overlay-properties o))
+ (overlays (mapcar (lambda (o) (overlay-properties o))
(overlays-at pos)))
(char-description (if (not multibyte-p)
(single-key-description char)
@@ -583,8 +582,8 @@ as well as widgets, buttons, overlays, and text properties."
pos (glyph-char (aref disp-vector i))))))
(format "by display table entry [%s] (see below)"
(mapconcat
- #'(lambda (x)
- (format "?%c" (glyph-char (car x))))
+ (lambda (x)
+ (format "?%c" (glyph-char (car x))))
disp-vector " ")))
(composition
(cadr composition))
@@ -618,7 +617,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 +641,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
@@ -650,11 +650,11 @@ as well as widgets, buttons, overlays, and text properties."
(goto-char (point-min))
(re-search-forward "character:[ \t\n]+")
(let ((end (+ (point) (length char-description))))
- (mapc #'(lambda (props)
- (let ((o (make-overlay (point) end)))
- (while props
- (overlay-put o (car props) (nth 1 props))
- (setq props (cddr props)))))
+ (mapc (lambda (props)
+ (let ((o (make-overlay (point) end)))
+ (while props
+ (overlay-put o (car props) (nth 1 props))
+ (setq props (cddr props)))))
overlays))))
(when disp-vector
@@ -745,7 +745,7 @@ as well as widgets, buttons, overlays, and text properties."
"\nCharacter code properties: "))
(insert-text-button
"customize what to show"
- 'action (lambda (&rest ignore)
+ 'action (lambda (&rest _ignore)
(customize-variable
'describe-char-unidata-list))
'follow-link t)
@@ -768,5 +768,4 @@ as well as widgets, buttons, overlays, and text properties."
(provide 'descr-text)
-;; arch-tag: fc55a498-f3e9-4312-b5bd-98cc02480af1
;;; descr-text.el ends here
diff --git a/lisp/desktop.el b/lisp/desktop.el
index 4af1fea1f9a..c60745a6b16 100644
--- a/lisp/desktop.el
+++ b/lisp/desktop.el
@@ -1,8 +1,6 @@
;;; desktop.el --- save partial status of Emacs when killed
-;; Copyright (C) 1993, 1994, 1995, 1997, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1993-1995, 1997, 2000-2011 Free Software Foundation, Inc.
;; Author: Morten Welinder <terra@diku.dk>
;; Keywords: convenience
@@ -613,7 +611,8 @@ Furthermore, it clears the variables listed in `desktop-globals-to-clear'."
(delete-other-windows))
;; ----------------------------------------------------------------------------
-(add-hook 'kill-emacs-hook 'desktop-kill)
+(unless noninteractive
+ (add-hook 'kill-emacs-hook 'desktop-kill))
(defun desktop-kill ()
"If `desktop-save-mode' is non-nil, do what `desktop-save' says to do.
@@ -622,7 +621,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)))
@@ -809,7 +811,7 @@ which means to truncate VAR's value to at most MAX-SIZE elements
")\n"))))
;; ----------------------------------------------------------------------------
-(defun desktop-save-buffer-p (filename bufname mode &rest dummy)
+(defun desktop-save-buffer-p (filename bufname mode &rest _dummy)
"Return t if buffer should have its state saved in the desktop file.
FILENAME is the visited file name, BUFNAME is the buffer name, and
MODE is the major mode.
@@ -1074,15 +1076,16 @@ directory DIRNAME."
(defvar desktop-buffer-major-mode)
(defvar desktop-buffer-locals)
+(defvar auto-insert) ; from autoinsert.el
;; ----------------------------------------------------------------------------
-(defun desktop-restore-file-buffer (desktop-buffer-file-name
- desktop-buffer-name
- desktop-buffer-misc)
+(defun desktop-restore-file-buffer (buffer-filename
+ _buffer-name
+ _buffer-misc)
"Restore a file buffer."
- (when desktop-buffer-file-name
- (if (or (file-exists-p desktop-buffer-file-name)
+ (when buffer-filename
+ (if (or (file-exists-p buffer-filename)
(let ((msg (format "Desktop: File \"%s\" no longer exists."
- desktop-buffer-file-name)))
+ buffer-filename)))
(if desktop-missing-file-warning
(y-or-n-p (concat msg " Re-create buffer? "))
(message "%s" msg)
@@ -1092,7 +1095,7 @@ directory DIRNAME."
(or coding-system-for-read
(cdr (assq 'buffer-file-coding-system
desktop-buffer-locals))))
- (buf (find-file-noselect desktop-buffer-file-name)))
+ (buf (find-file-noselect buffer-filename)))
(condition-case nil
(switch-to-buffer buf)
(error (pop-to-buffer buf)))
@@ -1123,104 +1126,114 @@ directory DIRNAME."
(defvar desktop-buffer-fail-count)
(defun desktop-create-buffer
- (desktop-file-version
- desktop-buffer-file-name
- desktop-buffer-name
- desktop-buffer-major-mode
- desktop-buffer-minor-modes
- desktop-buffer-point
- desktop-buffer-mark
- desktop-buffer-read-only
- desktop-buffer-misc
- &optional
- desktop-buffer-locals)
- ;; To make desktop files with relative file names possible, we cannot
- ;; allow `default-directory' to change. Therefore we save current buffer.
- (save-current-buffer
- ;; Give major mode module a chance to add a handler.
- (desktop-load-file desktop-buffer-major-mode)
- (let ((buffer-list (buffer-list))
- (result
- (condition-case-no-debug err
- (funcall (or (cdr (assq desktop-buffer-major-mode
- desktop-buffer-mode-handlers))
- 'desktop-restore-file-buffer)
- desktop-buffer-file-name
- desktop-buffer-name
- desktop-buffer-misc)
- (error
- (message "Desktop: Can't load buffer %s: %s"
- desktop-buffer-name
- (error-message-string err))
- (when desktop-missing-file-warning (sit-for 1))
- nil))))
- (if (bufferp result)
- (setq desktop-buffer-ok-count (1+ desktop-buffer-ok-count))
- (setq desktop-buffer-fail-count (1+ desktop-buffer-fail-count))
- (setq result nil))
- ;; Restore buffer list order with new buffer at end. Don't change
- ;; the order for old desktop files (old desktop module behaviour).
- (unless (< desktop-file-version 206)
- (mapc 'bury-buffer buffer-list)
- (when result (bury-buffer result)))
- (when result
- (unless (or desktop-first-buffer (< desktop-file-version 206))
- (setq desktop-first-buffer result))
- (set-buffer result)
- (unless (equal (buffer-name) desktop-buffer-name)
- (rename-buffer desktop-buffer-name t))
- ;; minor modes
- (cond ((equal '(t) desktop-buffer-minor-modes) ; backwards compatible
- (auto-fill-mode 1))
- ((equal '(nil) desktop-buffer-minor-modes) ; backwards compatible
- (auto-fill-mode 0))
- (t
- (dolist (minor-mode desktop-buffer-minor-modes)
- ;; Give minor mode module a chance to add a handler.
- (desktop-load-file minor-mode)
- (let ((handler (cdr (assq minor-mode desktop-minor-mode-handlers))))
- (if handler
- (funcall handler desktop-buffer-locals)
- (when (functionp minor-mode)
- (funcall minor-mode 1)))))))
- ;; Even though point and mark are non-nil when written by
- ;; `desktop-save', they may be modified by handlers wanting to set
- ;; point or mark themselves.
- (when desktop-buffer-point
- (goto-char
- (condition-case err
- ;; Evaluate point. Thus point can be something like
- ;; '(search-forward ...
- (eval desktop-buffer-point)
- (error (message "%s" (error-message-string err)) 1))))
- (when desktop-buffer-mark
- (if (consp desktop-buffer-mark)
- (progn
- (set-mark (car desktop-buffer-mark))
- (setq mark-active (car (cdr desktop-buffer-mark))))
- (set-mark desktop-buffer-mark)))
- ;; Never override file system if the file really is read-only marked.
- (when desktop-buffer-read-only (setq buffer-read-only desktop-buffer-read-only))
- (while desktop-buffer-locals
- (let ((this (car desktop-buffer-locals)))
- (if (consp this)
- ;; an entry of this form `(symbol . value)'
+ (file-version
+ buffer-filename
+ buffer-name
+ buffer-majormode
+ buffer-minormodes
+ buffer-point
+ buffer-mark
+ buffer-readonly
+ buffer-misc
+ &optional
+ buffer-locals)
+
+ (let ((desktop-file-version file-version)
+ (desktop-buffer-file-name buffer-filename)
+ (desktop-buffer-name buffer-name)
+ (desktop-buffer-major-mode buffer-majormode)
+ (desktop-buffer-minor-modes buffer-minormodes)
+ (desktop-buffer-point buffer-point)
+ (desktop-buffer-mark buffer-mark)
+ (desktop-buffer-read-only buffer-readonly)
+ (desktop-buffer-misc buffer-misc)
+ (desktop-buffer-locals buffer-locals))
+ ;; To make desktop files with relative file names possible, we cannot
+ ;; allow `default-directory' to change. Therefore we save current buffer.
+ (save-current-buffer
+ ;; Give major mode module a chance to add a handler.
+ (desktop-load-file desktop-buffer-major-mode)
+ (let ((buffer-list (buffer-list))
+ (result
+ (condition-case-no-debug err
+ (funcall (or (cdr (assq desktop-buffer-major-mode
+ desktop-buffer-mode-handlers))
+ 'desktop-restore-file-buffer)
+ desktop-buffer-file-name
+ desktop-buffer-name
+ desktop-buffer-misc)
+ (error
+ (message "Desktop: Can't load buffer %s: %s"
+ desktop-buffer-name
+ (error-message-string err))
+ (when desktop-missing-file-warning (sit-for 1))
+ nil))))
+ (if (bufferp result)
+ (setq desktop-buffer-ok-count (1+ desktop-buffer-ok-count))
+ (setq desktop-buffer-fail-count (1+ desktop-buffer-fail-count))
+ (setq result nil))
+ ;; Restore buffer list order with new buffer at end. Don't change
+ ;; the order for old desktop files (old desktop module behaviour).
+ (unless (< desktop-file-version 206)
+ (mapc 'bury-buffer buffer-list)
+ (when result (bury-buffer result)))
+ (when result
+ (unless (or desktop-first-buffer (< desktop-file-version 206))
+ (setq desktop-first-buffer result))
+ (set-buffer result)
+ (unless (equal (buffer-name) desktop-buffer-name)
+ (rename-buffer desktop-buffer-name t))
+ ;; minor modes
+ (cond ((equal '(t) desktop-buffer-minor-modes) ; backwards compatible
+ (auto-fill-mode 1))
+ ((equal '(nil) desktop-buffer-minor-modes) ; backwards compatible
+ (auto-fill-mode 0))
+ (t
+ (dolist (minor-mode desktop-buffer-minor-modes)
+ ;; Give minor mode module a chance to add a handler.
+ (desktop-load-file minor-mode)
+ (let ((handler (cdr (assq minor-mode desktop-minor-mode-handlers))))
+ (if handler
+ (funcall handler desktop-buffer-locals)
+ (when (functionp minor-mode)
+ (funcall minor-mode 1)))))))
+ ;; Even though point and mark are non-nil when written by
+ ;; `desktop-save', they may be modified by handlers wanting to set
+ ;; point or mark themselves.
+ (when desktop-buffer-point
+ (goto-char
+ (condition-case err
+ ;; Evaluate point. Thus point can be something like
+ ;; '(search-forward ...
+ (eval desktop-buffer-point)
+ (error (message "%s" (error-message-string err)) 1))))
+ (when desktop-buffer-mark
+ (if (consp desktop-buffer-mark)
(progn
- (make-local-variable (car this))
- (set (car this) (cdr this)))
- ;; an entry of the form `symbol'
- (make-local-variable this)
- (makunbound this)))
- (setq desktop-buffer-locals (cdr desktop-buffer-locals)))))))
+ (set-mark (car desktop-buffer-mark))
+ (setq mark-active (car (cdr desktop-buffer-mark))))
+ (set-mark desktop-buffer-mark)))
+ ;; Never override file system if the file really is read-only marked.
+ (when desktop-buffer-read-only (setq buffer-read-only desktop-buffer-read-only))
+ (while desktop-buffer-locals
+ (let ((this (car desktop-buffer-locals)))
+ (if (consp this)
+ ;; an entry of this form `(symbol . value)'
+ (progn
+ (make-local-variable (car this))
+ (set (car this) (cdr this)))
+ ;; an entry of the form `symbol'
+ (make-local-variable this)
+ (makunbound this)))
+ (setq desktop-buffer-locals (cdr desktop-buffer-locals))))))))
;; ----------------------------------------------------------------------------
;; Backward compatibility -- update parameters to 205 standards.
-(defun desktop-buffer (desktop-buffer-file-name desktop-buffer-name
- desktop-buffer-major-mode
- mim pt mk ro tl fc cfs cr desktop-buffer-misc)
- (desktop-create-buffer 205 desktop-buffer-file-name desktop-buffer-name
- desktop-buffer-major-mode (cdr mim) pt mk ro
- desktop-buffer-misc
+(defun desktop-buffer (buffer-filename buffer-name buffer-majormode
+ mim pt mk ro tl fc cfs cr buffer-misc)
+ (desktop-create-buffer 205 buffer-filename buffer-name
+ buffer-majormode (cdr mim) pt mk ro
+ buffer-misc
(list (cons 'truncate-lines tl)
(cons 'fill-column fc)
(cons 'case-fold-search cfs)
@@ -1309,5 +1322,4 @@ If there are no buffers left to create, kill the timer."
(provide 'desktop)
-;; arch-tag: 221907c3-1771-4fd3-9c2e-c6f700c6ede9
;;; desktop.el ends here
diff --git a/lisp/dframe.el b/lisp/dframe.el
index ffcffc22c10..02eeef064fe 100644
--- a/lisp/dframe.el
+++ b/lisp/dframe.el
@@ -1,7 +1,6 @@
;;; dframe --- dedicate frame support modes
-;;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: file, tags, tools
@@ -244,6 +243,9 @@ Local to those buffers, as a function called that created it.")
"Return non-nil if FRAME is currently available."
(and frame (frame-live-p frame) (frame-visible-p frame)))
+(defvar x-sensitive-text-pointer-shape)
+(defvar x-pointer-shape)
+
(defun dframe-frame-mode (arg frame-var cache-var buffer-var frame-name
local-mode-fn
&optional
@@ -430,7 +432,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 +462,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 +474,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)))
@@ -503,7 +506,7 @@ a cons cell indicating a position of the form (LEFT . TOP)."
(list (cons 'left newleft)
(cons 'top newtop))))))
-(defun dframe-reposition-frame-xemacs (new-frame parent-frame location)
+(defun dframe-reposition-frame-xemacs (_new-frame _parent-frame _location)
"Move NEW-FRAME to be relative to PARENT-FRAME.
LOCATION can be one of 'random, 'left-right, or 'top-bottom."
;; Not yet implemented
@@ -632,7 +635,7 @@ selecting FRAME-VAR."
FRAME-VAR is the variable storing the currently active dedicated frame.
If the current frame's buffer uses DESIRED-MAJOR-MODE, then use that frame."
(if (not (eq (selected-frame) (symbol-value frame-var)))
- (if (and (eq major-mode 'desired-major-mode)
+ (if (and (eq major-mode desired-major-mode)
(get-buffer-window (current-buffer))
(window-frame (get-buffer-window (current-buffer))))
(window-frame (get-buffer-window (current-buffer)))
@@ -713,13 +716,12 @@ Argument PROMPT is the prompt to use."
(defvar dframe-client-functions nil
"List of client functions using the dframe timer.")
-(defun dframe-set-timer (timeout fn &optional null-on-error)
+(defun dframe-set-timer (timeout fn &optional _null-on-error)
"Apply a timer with TIMEOUT, to call FN, or remove a timer if TIMEOUT is nil.
TIMEOUT is the number of seconds until the dframe controled program
timer is called again. When TIMEOUT is nil, turn off all timeouts.
This function must be called from the buffer belonging to the program
-who requested the timer.
-If NULL-ON-ERROR is a symbol, set it to nil if we cannot create a timer."
+who requested the timer. NULL-ON-ERROR is ignored."
;; First, fix up our list of client functions
(if timeout
(add-to-list 'dframe-client-functions fn)
@@ -732,9 +734,9 @@ If NULL-ON-ERROR is a symbol, set it to nil if we cannot create a timer."
;; functions are left, shut er down.
(and dframe-timer (not timeout) dframe-client-functions))
;; Only call the low level function if we are changing the state.
- (dframe-set-timer-internal timeout null-on-error)))
+ (dframe-set-timer-internal timeout)))
-(defun dframe-set-timer-internal (timeout &optional null-on-error)
+(defun dframe-set-timer-internal (timeout &optional _null-on-error)
"Apply a timer with TIMEOUT to call the dframe timer manager."
(when dframe-timer
(if (featurep 'xemacs)
@@ -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.
@@ -838,7 +840,7 @@ Must be bound to event E."
(if dframe-track-mouse-function
(funcall dframe-track-mouse-function event)))
-(defun dframe-help-echo (window &optional buffer position)
+(defun dframe-help-echo (_window &optional buffer position)
"Display help based context.
The context is in WINDOW, viewing BUFFER, at POSITION.
BUFFER and POSITION are optional because XEmacs doesn't use them."
@@ -933,7 +935,7 @@ redirected into a window on the attached frame."
(mapcar (function (lambda (hook) (funcall hook buffer)))
temp-buffer-show-hook))))
-(defun dframe-hack-buffer-menu (e)
+(defun dframe-hack-buffer-menu (_e)
"Control mouse 1 is buffer menu.
This hack overrides it so that the right thing happens in the main
Emacs frame, not in the dedicated frame.
@@ -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 28b285f8b1f..059a635cded 100644
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -1,11 +1,12 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1986, 1992, 1994, 1998, 2000-2011
+;; 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.
@@ -458,6 +459,8 @@ with a prefix argument."
(funcall fun file))))
(forward-line 1)))))
+(defvar backup-extract-version-start) ; used in backup-extract-version
+
(defun dired-collect-file-versions (fn)
(let ((fn (file-name-sans-versions fn)))
;; Only do work if this file is not already in the alist.
@@ -508,18 +511,22 @@ to the end of the list of defaults just after the default value."
;; This is an extra function so that you can redefine it, e.g., to use gmhist.
(defun dired-read-shell-command (prompt arg files)
- "Read a dired shell command prompting with PROMPT (using `read-shell-command').
-ARG is the prefix arg and may be used to indicate in the prompt which
-FILES are affected."
+ "Read a dired shell command prompting with PROMPT.
+Passes the prefix argument ARG to `dired-mark-prompt', so that it
+can be used in the prompt to indicate which FILES are affected.
+Normally reads the command with `read-shell-command', but if the
+`dired-x' packages is loaded, uses `dired-guess-shell-command' to offer
+a smarter default choice of shell command."
(minibuffer-with-setup-hook
(lambda ()
(set (make-local-variable 'minibuffer-default-add-function)
'minibuffer-default-add-dired-shell-commands))
- (dired-mark-pop-up
- nil 'shell files
- #'read-shell-command
- (format prompt (dired-mark-prompt arg files))
- nil nil)))
+ (setq prompt (format prompt (dired-mark-prompt arg files)))
+ (if (featurep 'dired-x)
+ (dired-mark-pop-up nil 'shell files
+ #'dired-guess-shell-command prompt files)
+ (dired-mark-pop-up nil 'shell files
+ #'read-shell-command prompt nil nil))))
;;;###autoload
(defun dired-do-async-shell-command (command &optional arg file-list)
@@ -623,7 +630,7 @@ can be produced by `dired-get-marked-files', for example."
(defvar dired-mark-separator " "
"Separates marked files in dired shell commands.")
-(defun dired-shell-stuff-it (command file-list on-each &optional raw-arg)
+(defun dired-shell-stuff-it (command file-list on-each &optional _raw-arg)
;; "Make up a shell command line from COMMAND and FILE-LIST.
;; If ON-EACH is t, COMMAND should be applied to each file, else
;; simply concat all files and apply COMMAND to this.
@@ -699,7 +706,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 +740,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)))
@@ -887,55 +894,35 @@ Otherwise, the rule is a compression rule, and compression is done with gzip.")
(downcase string) count total (dired-plural-s total))
failures)))))
-(defvar dired-query-alist
- '((?y . y) (?\040 . y) ; `y' or SPC means accept once
- (?n . n) (?\177 . n) ; `n' or DEL skips once
- (?! . yes) ; `!' accepts rest
- (?q . no) (?\e . no) ; `q' or ESC skips rest
- ;; None of these keys quit - use C-g for that.
- ))
-
;;;###autoload
-(defun dired-query (qs-var qs-prompt &rest qs-args)
- "Query user and return nil or t.
-Store answer in symbol VAR (which must initially be bound to nil).
-Format PROMPT with ARGS.
-Binding variable `help-form' will help the user who types the help key."
- (let* ((char (symbol-value qs-var))
- (action (cdr (assoc char dired-query-alist))))
- (cond ((eq 'yes action)
- t) ; accept, and don't ask again
- ((eq 'no action)
- nil) ; skip, and don't ask again
- (t;; no lasting effects from last time we asked - ask now
- (let ((cursor-in-echo-area t)
- (executing-kbd-macro executing-kbd-macro)
- (qprompt (concat qs-prompt
- (if help-form
- (format " [Type yn!q or %s] "
- (key-description
- (char-to-string help-char)))
- " [Type y, n, q or !] ")))
- done result elt)
- (while (not done)
- (apply 'message qprompt qs-args)
- (setq char (set qs-var (read-event)))
- (if (numberp char)
- (cond ((and executing-kbd-macro (= char -1))
- ;; read-event returns -1 if we are in a kbd
- ;; macro and there are no more events in the
- ;; macro. Attempt to get an event
- ;; interactively.
- (setq executing-kbd-macro nil))
- ((eq (key-binding (vector char)) 'keyboard-quit)
- (keyboard-quit))
- (t
- (setq done (setq elt (assoc char
- dired-query-alist)))))))
- ;; Display the question with the answer.
- (message "%s" (concat (apply 'format qprompt qs-args)
- (char-to-string char)))
- (memq (cdr elt) '(t y yes)))))))
+(defun dired-query (sym prompt &rest args)
+ "Format PROMPT with ARGS, query user, and store the result in SYM.
+The return value is either nil or t.
+
+The user may type y or SPC to accept once; n or DEL to skip once;
+! to accept this and subsequent queries; or q or ESC to decline
+this and subsequent queries.
+
+If SYM is already bound to a non-nil value, this function may
+return automatically without querying the user. If SYM is !,
+return t; if SYM is q or ESC, return nil."
+ (let* ((char (symbol-value sym))
+ (char-choices '(?y ?\s ?n ?\177 ?! ?q ?\e)))
+ (cond ((eq char ?!)
+ t) ; accept, and don't ask again
+ ((memq char '(?q ?\e))
+ nil) ; skip, and don't ask again
+ (t ; no previous answer - ask now
+ (setq prompt
+ (concat (apply 'format prompt args)
+ (if help-form
+ (format " [Type yn!q or %s] "
+ (key-description
+ (char-to-string help-char)))
+ " [Type y, n, q or !] ")))
+ (set sym (setq char (read-char-choice prompt char-choices)))
+ (if (memq char '(?y ?\s ?!)) t)))))
+
;;;###autoload
(defun dired-do-compress (&optional arg)
@@ -1040,10 +1027,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))
- (buffer-read-only))
- (delete-region (point) (progn (forward-line 1) (point)))
+ (let* ((opoint (line-beginning-position))
+ (char (char-after opoint))
+ (buffer-read-only))
+ (delete-region opoint (progn (forward-line 1) (point)))
(if file
(progn
(dired-add-entry file nil t)
@@ -1058,93 +1045,123 @@ See Info node `(emacs)Subdir switches' for more details."
(file-name-directory filename) (file-name-nondirectory filename)
(function dired-add-entry) filename marker-char))
+(defvar dired-omit-mode)
+(declare-function dired-omit-regexp "dired-x" ())
+(defvar dired-omit-localp)
+
(defun dired-add-entry (filename &optional marker-char relative)
- ;; Add a new entry for FILENAME, optionally marking it
- ;; with MARKER-CHAR (a character, else dired-marker-char is used).
- ;; Note that this adds the entry `out of order' if files sorted by
- ;; time, etc.
- ;; At least this version inserts in the right subdirectory (if present).
- ;; And it skips "." or ".." (see `dired-trivial-filenames').
- ;; Hidden subdirs are exposed if a file is added there.
- (setq filename (directory-file-name filename))
- ;; Entry is always for files, even if they happen to also be directories
- (let* ((opoint (point))
- (cur-dir (dired-current-directory))
- (orig-file-name filename)
- (directory (if relative cur-dir (file-name-directory filename)))
- reason)
- (setq filename
- (if relative
- (file-relative-name filename directory)
- (file-name-nondirectory filename))
- reason
- (catch 'not-found
- (if (string= directory cur-dir)
- (progn
- (skip-chars-forward "^\r\n")
- (if (eq (following-char) ?\r)
- (dired-unhide-subdir))
- ;; We are already where we should be, except when
- ;; point is before the subdir line or its total line.
- (let ((p (dired-after-subdir-garbage cur-dir)))
- (if (< (point) p)
- (goto-char p))))
- ;; else try to find correct place to insert
- (if (dired-goto-subdir directory)
- (progn ;; unhide if necessary
- (if (looking-at "\r") ;; point is at end of subdir line
- (dired-unhide-subdir))
- ;; found - skip subdir and `total' line
- ;; and uninteresting files like . and ..
- ;; This better not moves into the next subdir!
- (dired-goto-next-nontrivial-file))
- ;; not found
- (throw 'not-found "Subdir not found")))
- (let (buffer-read-only opoint)
- (beginning-of-line)
- (setq opoint (point))
- ;; Don't expand `.'. Show just the file name within directory.
- (let ((default-directory directory))
- (dired-insert-directory directory
- (concat dired-actual-switches " -d")
- (list filename)))
- (goto-char opoint)
- ;; Put in desired marker char.
- (when marker-char
- (let ((dired-marker-char
- (if (integerp marker-char) marker-char dired-marker-char)))
- (dired-mark nil)))
- ;; Compensate for a bug in ange-ftp.
- ;; It inserts the file's absolute name, rather than
- ;; the relative one. That may be hard to fix since it
- ;; is probably controlled by something in ftp.
- (goto-char opoint)
- (let ((inserted-name (dired-get-filename 'verbatim)))
- (if (file-name-directory inserted-name)
- (let (props)
- (end-of-line)
- (forward-char (- (length inserted-name)))
- (setq props (text-properties-at (point)))
- (delete-char (length inserted-name))
- (let ((pt (point)))
- (insert filename)
- (set-text-properties pt (point) props))
- (forward-char 1))
- (forward-line 1)))
- (forward-line -1)
- (if dired-after-readin-hook ;; the subdir-alist is not affected...
- (save-excursion ;; ...so we can run it right now:
- (save-restriction
- (beginning-of-line)
- (narrow-to-region (point) (save-excursion
- (forward-line 1) (point)))
- (run-hooks 'dired-after-readin-hook))))
- (dired-move-to-filename))
- ;; return nil if all went well
- nil))
- (if reason ; don't move away on failure
- (goto-char opoint))
- (not reason))) ; return t on success, nil else
+ "Add a new dired entry for FILENAME.
+Optionally mark it with MARKER-CHAR (a character, else uses
+`dired-marker-char'). Note that this adds the entry `out of order'
+if files are sorted by time, etc.
+Skips files that match `dired-trivial-filenames'.
+Exposes hidden subdirectories if a file is added there.
+
+If `dired-x' is loaded and `dired-omit-mode' is enabled, skips
+files matching `dired-omit-regexp'."
+ (if (or (not (featurep 'dired-x))
+ (not dired-omit-mode)
+ ;; Avoid calling ls for files that are going to be omitted anyway.
+ (let ((omit-re (dired-omit-regexp)))
+ (or (string= omit-re "")
+ (not (string-match omit-re
+ (cond
+ ((eq 'no-dir dired-omit-localp)
+ filename)
+ ((eq t dired-omit-localp)
+ (dired-make-relative filename))
+ (t
+ (dired-make-absolute
+ filename
+ (file-name-directory filename)))))))))
+ ;; Do it!
+ (progn
+ (setq filename (directory-file-name filename))
+ ;; Entry is always for files, even if they happen to also be directories
+ (let* ((opoint (point))
+ (cur-dir (dired-current-directory))
+ (directory (if relative cur-dir (file-name-directory filename)))
+ reason)
+ (setq filename
+ (if relative
+ (file-relative-name filename directory)
+ (file-name-nondirectory filename))
+ reason
+ (catch 'not-found
+ (if (string= directory cur-dir)
+ (progn
+ (skip-chars-forward "^\r\n")
+ (if (eq (following-char) ?\r)
+ (dired-unhide-subdir))
+ ;; We are already where we should be, except when
+ ;; point is before the subdir line or its total line.
+ (let ((p (dired-after-subdir-garbage cur-dir)))
+ (if (< (point) p)
+ (goto-char p))))
+ ;; else try to find correct place to insert
+ (if (dired-goto-subdir directory)
+ (progn ;; unhide if necessary
+ (if (looking-at "\r")
+ ;; Point is at end of subdir line.
+ (dired-unhide-subdir))
+ ;; found - skip subdir and `total' line
+ ;; and uninteresting files like . and ..
+ ;; This better not move into the next subdir!
+ (dired-goto-next-nontrivial-file))
+ ;; not found
+ (throw 'not-found "Subdir not found")))
+ (let (buffer-read-only opoint)
+ (beginning-of-line)
+ (setq opoint (point))
+ ;; Don't expand `.'.
+ ;; Show just the file name within directory.
+ (let ((default-directory directory))
+ (dired-insert-directory
+ directory
+ (concat dired-actual-switches " -d")
+ (list filename)))
+ (goto-char opoint)
+ ;; Put in desired marker char.
+ (when marker-char
+ (let ((dired-marker-char
+ (if (integerp marker-char) marker-char
+ dired-marker-char)))
+ (dired-mark nil)))
+ ;; Compensate for a bug in ange-ftp.
+ ;; It inserts the file's absolute name, rather than
+ ;; the relative one. That may be hard to fix since it
+ ;; is probably controlled by something in ftp.
+ (goto-char opoint)
+ (let ((inserted-name (dired-get-filename 'verbatim)))
+ (if (file-name-directory inserted-name)
+ (let (props)
+ (end-of-line)
+ (forward-char (- (length inserted-name)))
+ (setq props (text-properties-at (point)))
+ (delete-char (length inserted-name))
+ (let ((pt (point)))
+ (insert filename)
+ (set-text-properties pt (point) props))
+ (forward-char 1))
+ (forward-line 1)))
+ (forward-line -1)
+ (if dired-after-readin-hook
+ ;; The subdir-alist is not affected...
+ (save-excursion ; ...so we can run it right now:
+ (save-restriction
+ (beginning-of-line)
+ (narrow-to-region (point)
+ (line-beginning-position 2))
+ (run-hooks 'dired-after-readin-hook))))
+ (dired-move-to-filename))
+ ;; return nil if all went well
+ nil))
+ (if reason ; don't move away on failure
+ (goto-char opoint))
+ (not reason))) ; return t on success, nil else
+ ;; Don't do it (dired-omit-mode).
+ ;; Return t for success (perhaps we should return file-exists-p).
+ t))
(defun dired-after-subdir-garbage (dir)
;; Return pos of first file line of DIR, skipping header and total
@@ -1170,7 +1187,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)
@@ -1191,7 +1208,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)))))
@@ -1235,21 +1252,20 @@ Special value `always' suppresses confirmation."
(defun dired-copy-file-recursive (from to ok-flag &optional
preserve-time top recursive)
- (let ((attrs (file-attributes from))
- dirfailed)
+ (let ((attrs (file-attributes from)))
(if (and recursive
(eq t (car attrs))
(or (eq recursive 'always)
(yes-or-no-p (format "Recursive copies of %s? " from))))
;; This is a directory.
- (copy-directory from to dired-copy-preserve-time)
+ (copy-directory from to preserve-time)
;; Not a directory.
(or top (dired-handle-overwrite to))
(condition-case err
(if (stringp (car attrs))
;; It is a symlink
(make-symbolic-link (car attrs) to ok-flag)
- (copy-file from to ok-flag dired-copy-preserve-time))
+ (copy-file from to ok-flag preserve-time))
(file-date-error
(push (dired-make-relative from)
dired-create-files-failures)
@@ -1344,36 +1360,35 @@ Special value `always' suppresses confirmation."
(setcar elt cur-dir)
(when cons (setcar cons cur-dir))))))
+;; Bound in dired-create-files
+(defvar overwrite-query)
+(defvar overwrite-backup-query)
+
;; The basic function for half a dozen variations on cp/mv/ln/ln -s.
(defun dired-create-files (file-creator operation fn-list name-constructor
&optional marker-char)
+ "Create one or more new files from a list of existing files FN-LIST.
+This function also handles querying the user, updating Dired
+buffers, and displaying a success or failure message.
-;; Create a new file for each from a list of existing files. The user
-;; is queried, dired buffers are updated, and at the end a success or
-;; failure message is displayed
+FILE-CREATOR should be a function. It is called once for each
+file in FN-LIST, and must create a new file, querying the user
+and updating Dired buffers as necessary. It should accept three
+arguments: the old file name, the new name, and an argument
+OK-IF-ALREADY-EXISTS with the same meaning as in `copy-file'.
-;; FILE-CREATOR must accept three args: oldfile newfile ok-if-already-exists
+OPERATION should be a capitalized string describing the operation
+performed (e.g. `Copy'). It is used for error logging.
-;; It is called for each file and must create newfile, the entry of
-;; which will be added. The user will be queried if the file already
-;; exists. If oldfile is removed by FILE-CREATOR (i.e, it is a
-;; rename), it is FILE-CREATOR's responsibility to update dired
-;; buffers. FILE-CREATOR must abort by signaling a file-error if it
-;; could not create newfile. The error is caught and logged.
+FN-LIST is the list of files to copy (full absolute file names).
-;; OPERATION (a capitalized string, e.g. `Copy') describes the
-;; operation performed. It is used for error logging.
-
-;; FN-LIST is the list of files to copy (full absolute file names).
-
-;; NAME-CONSTRUCTOR returns a newfile for every oldfile, or nil to
-;; skip. If it skips files for other reasons than a direct user
-;; query, it is supposed to tell why (using dired-log).
-
-;; Optional MARKER-CHAR is a character with which to mark every
-;; newfile's entry, or t to use the current marker character if the
-;; oldfile was marked.
+NAME-CONSTRUCTOR should be a function accepting a single
+argument, the name of an old file, and returning either the
+corresponding new file name or nil to skip.
+Optional MARKER-CHAR is a character with which to mark every
+newfile's entry, or t to use the current marker character if the
+old file was marked."
(let (dired-create-files-failures failures
skipped (success-count 0) (total (length fn-list)))
(let (to overwrite-query
@@ -1403,6 +1418,10 @@ ESC or `q' to not overwrite any of the remaining files,
(cond ((integerp marker-char) marker-char)
(marker-char (dired-file-marker from)) ; slow
(t nil))))
+ (when (and (file-directory-p from)
+ (file-directory-p to)
+ (eq file-creator 'dired-copy-file))
+ (setq to (file-name-directory to)))
(condition-case err
(progn
(funcall file-creator from to dired-overwrite-confirmed)
@@ -1531,7 +1550,7 @@ Optional arg HOW-TO determiness how to treat the target.
(function
(lambda (from)
(expand-file-name (file-name-nondirectory from) target)))
- (function (lambda (from) target)))
+ (function (lambda (_from) target)))
marker-char))))
;; Read arguments for a marked-files command that wants a file name,
@@ -1618,11 +1637,14 @@ Optional arg HOW-TO determiness how to treat the target.
;;;###autoload
(defun dired-create-directory (directory)
- "Create a directory called DIRECTORY."
+ "Create a directory called DIRECTORY.
+If DIRECTORY already exists, signal an error."
(interactive
(list (read-file-name "Create directory: " (dired-current-directory))))
(let* ((expanded (directory-file-name (expand-file-name directory)))
(try expanded) new)
+ (if (file-exists-p expanded)
+ (error "Cannot create directory %s: file exists" expanded))
;; Find the topmost nonexistent parent dir (variable `new')
(while (and try (not (file-exists-p try)) (not (equal new try)))
(setq new try
@@ -1722,6 +1744,8 @@ of `dired-dwim-target', which see."
;;; 5K
;;;###begin dired-re.el
+(defvar rename-regexp-query)
+
(defun dired-do-create-files-regexp
(file-creator operation arg regexp newname &optional whole-name marker-char)
;; Create a new file for each marked file using regexps.
@@ -1733,7 +1757,6 @@ of `dired-dwim-target', which see."
;; instead of only the non-directory part of the file.
;; Optional arg MARKER-CHAR as in dired-create-files.
(let* ((fn-list (dired-get-marked-files nil arg))
- (fn-count (length fn-list))
(operation-prompt (concat operation " `%s' to `%s'?"))
(rename-regexp-help-form (format "\
Type SPC or `y' to %s one match, DEL or `n' to skip to next,
@@ -1842,6 +1865,8 @@ See function `dired-do-rename-regexp' for more info."
(function make-symbolic-link)
"SymLink" arg regexp newname whole-name dired-keep-marker-symlink))
+(defvar rename-non-directory-query)
+
(defun dired-create-files-non-directory
(file-creator basename-constructor operation arg)
;; Perform FILE-CREATOR on the non-directory part of marked files
@@ -2038,8 +2063,7 @@ of marked files. If KILL-ROOT is non-nil, kill DIRNAME as well."
(while alist
(setq elt (car alist)
alist (cdr alist)
- dir (car elt)
- pos (dired-get-subdir-min elt))
+ dir (car elt))
(if (dired-tree-lessp dir new-dir)
;; Insert NEW-DIR after DIR
(setq new-pos (dired-get-subdir-max elt)
@@ -2485,5 +2509,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 f3e94dcd539..548728cf28d 100644
--- a/lisp/dired-x.el
+++ b/lisp/dired-x.el
@@ -1,12 +1,12 @@
;;; dired-x.el --- extra Dired functionality
-;; Copyright (C) 1993, 1994, 1997, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1994, 1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Sebastian Kremer <sk@thp.uni-koeln.de>
;; Lawrence R. Dodd <dodd@roebling.poly.edu>
;; Maintainer: Romain Francoise <rfrancoise@gnu.org>
;; Keywords: dired extensions files
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -25,91 +25,38 @@
;;; Commentary:
-;; This is Sebastian Kremer's excellent dired-x.el (Dired Extra), version
-;; 1.191, hacked up for GNU Emacs. Redundant or conflicting material has
-;; been removed or renamed in order to work properly with dired of GNU
-;; Emacs. All suggestions or comments are most welcomed.
+;; This is based on Sebastian Kremer's excellent dired-x.el (Dired Extra),
+;; version 1.191, adapted for GNU Emacs. See the `dired-x' info pages.
-;;
-;; Please, PLEASE, *PLEASE* see the info pages.
-;;
-
-;; BUGS: Type M-x dired-x-submit-report and a report will be generated.
-
-;; INSTALLATION: In your ~/.emacs,
+;; USAGE: In your ~/.emacs,
;;
;; (add-hook 'dired-load-hook
-;; (function (lambda ()
+;; (lambda ()
;; (load "dired-x")
;; ;; Set global variables here. For example:
;; ;; (setq dired-guess-shell-gnutar "gtar")
-;; )))
+;; ))
;; (add-hook 'dired-mode-hook
-;; (function (lambda ()
+;; (lambda ()
;; ;; Set buffer-local variables here. For example:
;; ;; (dired-omit-mode 1)
-;; )))
+;; ))
;;
-;; At load time dired-x.el will install itself, redefine some functions, and
-;; bind some dired keys. *Please* see the info pages for more details.
+;; At load time dired-x.el will install itself and bind some dired keys.
+;; Some dired.el and dired-aux.el functions have extra features if
+;; dired-x is loaded.
-;; *Please* see the info pages for more details.
+;; User customization: M-x customize-group RET dired-x RET.
-;; User defined variables:
-;;
-;; dired-bind-vm
-;; dired-vm-read-only-folders
-;; dired-bind-jump
-;; dired-bind-info
-;; dired-bind-man
-;; dired-x-hands-off-my-keys
-;; dired-find-subdir
-;; dired-enable-local-variables
-;; dired-local-variables-file
-;; dired-guess-shell-gnutar
-;; dired-guess-shell-gzip-quiet
-;; dired-guess-shell-znew-switches
-;; dired-guess-shell-alist-user
-;; dired-clean-up-buffers-too
-;; dired-omit-mode
-;; dired-omit-files
-;; dired-omit-extensions
-;; dired-omit-size-limit
-;;
-;; To find out more about these variables, load this file, put your cursor at
-;; the end of any of the variable names, and hit C-h v [RET]. *Please* see
-;; the info pages for more details.
-
-;; When loaded this code redefines the following functions of GNU Emacs
-;;
-;; Function Found in this file of GNU Emacs
-;; -------- -------------------------------
-;; dired-clean-up-after-deletion ../lisp/dired.el
-;; dired-find-buffer-nocreate ../lisp/dired.el
-;; dired-initial-position ../lisp/dired.el
-;;
-;; dired-add-entry ../lisp/dired-aux.el
-;; dired-read-shell-command ../lisp/dired-aux.el
+;; *Please* see the `dired-x' info pages for more details.
;;; Code:
-;; LOAD.
-
-;; This is a no-op if dired-x is being loaded via `dired-load-hook'. It is
-;; here in case the user has autoloaded dired-x via the dired-jump key binding
-;; (instead of autoloading to dired as is suggested in the info-pages).
-
+;; This is a no-op if dired-x is being loaded via `dired-load-hook',
+;; but maybe not if a dired-x function is being autoloaded.
(require 'dired)
-;; We will redefine some functions and also need some macros so we need to
-;; load dired stuff of GNU Emacs.
-
-(require 'dired-aux)
-
-(defvar vm-folder-directory)
-(eval-when-compile (require 'man))
-
;;; User-defined variables.
(defgroup dired-x nil
@@ -123,7 +70,6 @@
(defcustom dired-bind-vm nil
"Non-nil means \"V\" runs `dired-vm', otherwise \"V\" runs `dired-rmail'.
-
RMAIL files in the old Babyl format (used before before Emacs 23.1)
contain \"-*- rmail -*-\" at the top, so `dired-find-file'
will run `rmail' on these files. New RMAIL files use the standard
@@ -132,44 +78,81 @@ mbox format, and so cannot be distinguished in this way."
:group 'dired-keys)
(defcustom dired-bind-jump t
- "Non-nil means bind `dired-jump' to C-x C-j, otherwise do not."
+ "Non-nil means bind `dired-jump' to C-x C-j, otherwise do not.
+Setting this variable directly after dired-x is loaded has no effect -
+use \\[customize]."
:type 'boolean
+ :set (lambda (sym val)
+ (if (set sym val)
+ (progn
+ (define-key global-map "\C-x\C-j" 'dired-jump)
+ (define-key global-map "\C-x4\C-j" 'dired-jump-other-window))
+ (if (eq 'dired-jump (lookup-key global-map "\C-x\C-j"))
+ (define-key global-map "\C-x\C-j" nil))
+ (if (eq 'dired-jump-other-window (lookup-key global-map "\C-x4\C-j"))
+ (define-key global-map "\C-x4\C-j" nil))))
:group 'dired-keys)
(defcustom dired-bind-man t
- "Non-nil means bind `dired-man' to \"N\" in dired-mode, otherwise do not."
+ "Non-nil means bind `dired-man' to \"N\" in dired-mode, otherwise do not.
+Setting this variable directly after dired-x is loaded has no effect -
+use \\[customize]."
:type 'boolean
+ :set (lambda (sym val)
+ (if (set sym val)
+ (define-key dired-mode-map "N" 'dired-man)
+ (if (eq 'dired-man (lookup-key dired-mode-map "N"))
+ (define-key dired-mode-map "N" nil))))
:group 'dired-keys)
(defcustom dired-bind-info t
- "Non-nil means bind `dired-info' to \"I\" in dired-mode, otherwise do not."
+ "Non-nil means bind `dired-info' to \"I\" in dired-mode, otherwise do not.
+Setting this variable directly after dired-x is loaded has no effect -
+use \\[customize]."
:type 'boolean
+ :set (lambda (sym val)
+ (if (set sym val)
+ (define-key dired-mode-map "I" 'dired-info)
+ (if (eq 'dired-info (lookup-key dired-mode-map "I"))
+ (define-key dired-mode-map "I" nil))))
:group 'dired-keys)
(defcustom dired-vm-read-only-folders nil
"If non-nil, \\[dired-vm] will visit all folders read-only.
If neither nil nor t, e.g. the symbol `if-file-read-only', only
-files not writable by you are visited read-only.
-
-Read-only folders only work in VM 5, not in VM 4."
+files not writable by you are visited read-only."
:type '(choice (const :tag "off" nil)
(const :tag "on" t)
(other :tag "non-writable only" if-file-read-only))
:group 'dired-x)
+(defcustom dired-omit-size-limit 30000
+ "Maximum size for the \"omitting\" feature.
+If nil, there is no maximum size."
+ :type '(choice (const :tag "no maximum" nil) integer)
+ :group 'dired-x)
+
(define-minor-mode dired-omit-mode
"Toggle Dired-Omit mode.
With numeric ARG, enable Dired-Omit mode if ARG is positive, disable
otherwise. Enabling and disabling is buffer-local.
If enabled, \"uninteresting\" files are not listed.
Uninteresting files are those whose filenames match regexp `dired-omit-files',
-plus those ending with extensions in `dired-omit-extensions'."
+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:
(let ((dired-omit-size-limit nil)) (dired-omit-expunge))
(revert-buffer)))
+(put 'dired-omit-mode 'safe-local-variable 'booleanp)
+
;; For backward compatibility
(define-obsolete-variable-alias 'dired-omit-files-p 'dired-omit-mode "22.1")
@@ -182,6 +165,12 @@ files and lock files."
:type 'regexp
:group 'dired-x)
+(defcustom dired-omit-verbose t
+ "When non-nil, show messages when omitting files.
+When nil, don't show messages."
+ :type 'boolean
+ :group 'dired-x)
+
(defcustom dired-find-subdir nil ; t is pretty near to DWIM...
"If non-nil, Dired always finds a directory in a buffer of its own.
If nil, Dired finds the directory as a subdirectory in some other buffer
@@ -196,30 +185,35 @@ toggle between those two."
:type 'boolean
:group 'dired-x)
-(defcustom dired-omit-size-limit 30000
- "Maximum size for the \"omitting\" feature.
-If nil, there is no maximum size."
- :type '(choice (const :tag "no maximum" nil) integer)
- :group 'dired-x)
-
(defcustom dired-enable-local-variables t
"Control use of local-variables lists in Dired.
-The value can be t, nil or something else.
-A value of t means local-variables lists are obeyed;
-nil means they are ignored; anything else means query.
-
This temporarily overrides the value of `enable-local-variables' when
listing a directory. See also `dired-local-variables-file'."
- :type 'boolean
+ :risky t
+ :type '(choice (const :tag "Query Unsafe" t)
+ (const :tag "Safe Only" :safe)
+ (const :tag "Do all" :all)
+ (const :tag "Ignore" nil)
+ (other :tag "Query" other))
:group 'dired-x)
-(defcustom dired-guess-shell-gnutar (when (or (eq system-type 'gnu)
- (eq system-type 'gnu/linux))
- "tar")
+(make-obsolete-variable 'dired-enable-local-variables
+ "use a standard `dir-locals-file' instead." "24.1")
+
+(defcustom dired-guess-shell-gnutar
+ (catch 'found
+ (dolist (exe '("tar" "gtar"))
+ (if (with-temp-buffer
+ (ignore-errors (call-process exe nil t nil "--version"))
+ (and (re-search-backward "GNU tar" nil t) t))
+ (throw 'found exe))))
"If non-nil, name of GNU tar executable.
\(E.g., \"tar\" or \"gtar\"). The `z' switch will be used with it for
compressed or gzip'ed tar files. If you don't have GNU tar, set this
to nil: a pipe using `zcat' or `gunzip -c' will be used."
+ ;; Changed from system-type test to testing --version output.
+ ;; Maybe test --help for -z instead?
+ :version "24.1"
:type '(choice (const :tag "Not GNU tar" nil)
(string :tag "Command name"))
:group 'dired-x)
@@ -248,90 +242,52 @@ to nil: a pipe using `zcat' or `gunzip -c' will be used."
(define-key dired-mode-map "*(" 'dired-mark-sexp)
(define-key dired-mode-map "*." 'dired-mark-extension)
(define-key dired-mode-map "\M-!" 'dired-smart-shell-command)
-(define-key dired-mode-map "w" 'dired-copy-filename-as-kill)
(define-key dired-mode-map "\M-G" 'dired-goto-subdir)
(define-key dired-mode-map "F" 'dired-do-find-marked-files)
(define-key dired-mode-map "Y" 'dired-do-relsymlink)
(define-key dired-mode-map "%Y" 'dired-do-relsymlink-regexp)
(define-key dired-mode-map "V" 'dired-do-run-mail)
-(if dired-bind-man
- (define-key dired-mode-map "N" 'dired-man))
-
-(if dired-bind-info
- (define-key dired-mode-map "I" 'dired-info))
-
;;; MENU BINDINGS
-(let ((menu-bar (lookup-key dired-mode-map [menu-bar])))
- (let ((menu (lookup-key menu-bar [operate])))
- (define-key-after
- menu
- [find-files]
- '(menu-item
- "Find files"
- dired-do-find-marked-files
- :help "Find current or marked files")
- 'delete)
- (define-key-after
- menu
- [relsymlink]
- '(menu-item
- "Relative symlink to..."
- dired-do-relsymlink
- :visible (fboundp 'make-symbolic-link)
- :help "Make relative symbolic links for current or marked files")
- 'symlink))
- (let ((menu (lookup-key menu-bar [mark])))
- (define-key-after
- menu
- [flag-extension]
- '(menu-item
- "Flag extension..."
- dired-flag-extension
- :help "Flag files with a certain extension for deletion")
- 'garbage-files)
- (define-key-after
- menu
- [mark-extension]
- '(menu-item
- "Mark extension..."
- dired-mark-extension
- :help "Mark files with a certain extension")
- 'symlinks)
- (define-key-after
- menu
- [mark-omitted]
- '(menu-item
- "Mark omitted"
- dired-mark-omitted
- :help "Mark files matching `dired-omit-files' and `dired-omit-extensions'")
- 'mark-extension))
- (let ((menu (lookup-key menu-bar [regexp])))
- (define-key-after
- menu
- [relsymlink-regexp]
- '(menu-item
- "Relative symlink..."
- dired-do-relsymlink-regexp
- :visible (fboundp 'make-symbolic-link)
- :help "Make relative symbolic links for files matching regexp")
- 'symlink))
- (let ((menu (lookup-key menu-bar [immediate])))
- (define-key-after
- menu
- [omit-mode]
- '(menu-item
- "Omit mode" dired-omit-mode
- :button (:toggle . dired-omit-mode)
- :help "Enable or disable omitting \"uninteresting\" files")
- 'dashes)))
-
-;;; GLOBAL BINDING.
-(if dired-bind-jump
- (progn
- (define-key global-map "\C-x\C-j" 'dired-jump)
- (define-key global-map "\C-x4\C-j" 'dired-jump-other-window)))
+(require 'easymenu)
+
+(let ((menu (lookup-key dired-mode-map [menu-bar])))
+ (easy-menu-add-item menu '("Operate")
+ ["Find Files" dired-do-find-marked-files
+ :help "Find current or marked files"]
+ "Shell Command...")
+ (easy-menu-add-item menu '("Operate")
+ ["Relative Symlink to..." dired-do-relsymlink
+ :visible (fboundp 'make-symbolic-link)
+ :help "Make relative symbolic links for current or \
+marked files"]
+ "Hardlink to...")
+ (easy-menu-add-item menu '("Mark")
+ ["Flag Extension..." dired-flag-extension
+ :help "Flag files with a certain extension for deletion"]
+ "Mark Executables")
+ (easy-menu-add-item menu '("Mark")
+ ["Mark Extension..." dired-mark-extension
+ :help "Mark files with a certain extension"]
+ "Unmark All")
+ (easy-menu-add-item menu '("Mark")
+ ["Mark Omitted" dired-mark-omitted
+ :help "Mark files matching `dired-omit-files' \
+and `dired-omit-extensions'"]
+ "Unmark All")
+ (easy-menu-add-item menu '("Regexp")
+ ["Relative Symlink..." dired-do-relsymlink-regexp
+ :visible (fboundp 'make-symbolic-link)
+ :help "Make relative symbolic links for files \
+matching regexp"]
+ "Hardlink...")
+ (easy-menu-add-item menu '("Immediate")
+ ["Omit Mode" dired-omit-mode
+ :style toggle :selected dired-omit-mode
+ :help "Enable or disable omitting \"uninteresting\" \
+files"]
+ "Refresh"))
;; Install into appropriate hooks.
@@ -348,31 +304,9 @@ to nil: a pipe using `zcat' or `gunzip -c' will be used."
\\[dired-do-find-marked-files]\t-- visit all marked files simultaneously
\\[dired-omit-mode]\t-- toggle omitting of files
\\[dired-mark-sexp]\t-- mark by Lisp expression
- \\[dired-copy-filename-as-kill]\t-- copy the file or subdir names into the kill ring;
- \t you can feed it to other commands using \\[yank]
-
-For more features, see variables
-
- `dired-bind-vm'
- `dired-bind-jump'
- `dired-bind-info'
- `dired-bind-man'
- `dired-vm-read-only-folders'
- `dired-omit-mode'
- `dired-omit-files'
- `dired-omit-extensions'
- `dired-omit-size-limit'
- `dired-find-subdir'
- `dired-enable-local-variables'
- `dired-local-variables-file'
- `dired-guess-shell-gnutar'
- `dired-guess-shell-gzip-quiet'
- `dired-guess-shell-znew-switches'
- `dired-guess-shell-alist-user'
- `dired-clean-up-buffers-too'
-
-See also functions
+To see the options you can set, use M-x customize-group RET dired-x RET.
+See also the functions:
`dired-flag-extension'
`dired-virtual'
`dired-jump'
@@ -382,45 +316,11 @@ See also functions
`dired-info'
`dired-do-find-marked-files'"
(interactive)
-
;; These must be done in each new dired buffer.
(dired-hack-local-variables)
(dired-omit-startup))
-;;; BUFFER CLEANING.
-
-;; REDEFINE.
-(defun dired-clean-up-after-deletion (fn)
- "Clean up after a deleted file or directory FN.
-Remove expanded subdir of deleted dir, if any."
- (save-excursion (and (cdr dired-subdir-alist)
- (dired-goto-subdir fn)
- (dired-kill-subdir)))
-
- ;; Offer to kill buffer of deleted file FN.
- (if dired-clean-up-buffers-too
- (progn
- (let ((buf (get-file-buffer fn)))
- (and buf
- (funcall (function y-or-n-p)
- (format "Kill buffer of %s, too? "
- (file-name-nondirectory fn)))
- (save-excursion ; you never know where kill-buffer leaves you
- (kill-buffer buf))))
- (let ((buf-list (dired-buffers-for-dir (expand-file-name fn)))
- (buf nil))
- (and buf-list
- (y-or-n-p (format "Kill dired buffer%s of %s, too? "
- (dired-plural-s (length buf-list))
- (file-name-nondirectory fn)))
- (while buf-list
- (save-excursion (kill-buffer (car buf-list)))
- (setq buf-list (cdr buf-list)))))))
- ;; Anything else?
- )
-
-
;;; EXTENSION MARKING FUNCTIONS.
;; Mark files with some extension.
@@ -500,24 +400,28 @@ 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)
- (or (dired-goto-file dir)
+ (unless (dired-goto-file dir)
;; refresh and try again
- (progn
- (dired-insert-subdir (file-name-directory dir))
- (dired-goto-file dir))))
+ (dired-insert-subdir (file-name-directory dir))
+ (dired-goto-file dir)))
(if other-window
(dired-other-window dir)
(dired dir))
@@ -528,15 +432,17 @@ buffer and try again."
(dired-insert-subdir (file-name-directory file))
(dired-goto-file file))
;; Toggle omitting, if it is on, and try again.
- (if dired-omit-mode
- (progn
- (dired-omit-mode)
- (dired-goto-file file))))))))
+ (when dired-omit-mode
+ (dired-omit-mode)
+ (dired-goto-file file)))))))
-(defun dired-jump-other-window ()
+;;;###autoload
+(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.
@@ -570,7 +476,7 @@ Should never be used as marker by the user or other packages.")
(let ((dired-omit-mode nil)) (revert-buffer)) ;; Show omitted files
(dired-mark-unmarked-files (dired-omit-regexp) nil nil dired-omit-localp))
-(defvar dired-omit-extensions
+(defcustom dired-omit-extensions
(append completion-ignored-extensions
dired-latex-unclean-extensions
dired-bibtex-unclean-extensions
@@ -581,7 +487,9 @@ Defaults to elements of `completion-ignored-extensions',
`dired-texinfo-unclean-extensions'.
See interactive function `dired-omit-mode' \(\\[dired-omit-mode]\) and
-variables `dired-omit-mode' and `dired-omit-files'.")
+variables `dired-omit-mode' and `dired-omit-files'."
+ :type '(repeat string)
+ :group 'dired-x)
(defun dired-omit-expunge (&optional regexp)
"Erases all unmarked files matching REGEXP.
@@ -599,8 +507,9 @@ This functions works by temporarily binding `dired-marker-char' to
(not dired-omit-size-limit)
(< (buffer-size) dired-omit-size-limit)
(progn
- (message "Not omitting: directory larger than %d characters."
- dired-omit-size-limit)
+ (when dired-omit-verbose
+ (message "Not omitting: directory larger than %d characters."
+ dired-omit-size-limit))
(setq dired-omit-mode nil)
nil)))
(let ((omit-re (or regexp (dired-omit-regexp)))
@@ -608,12 +517,14 @@ This functions works by temporarily binding `dired-marker-char' to
count)
(or (string= omit-re "")
(let ((dired-marker-char dired-omit-marker-char))
- (message "Omitting...")
+ (when dired-omit-verbose (message "Omitting..."))
(if (dired-mark-unmarked-files omit-re nil nil dired-omit-localp)
(progn
- (setq count (dired-do-kill-lines nil "Omitted %d line%s."))
+ (setq count (dired-do-kill-lines
+ nil
+ (if dired-omit-verbose "Omitted %d line%s." "")))
(force-mode-line-update))
- (message "(Nothing to omit)"))))
+ (when dired-omit-verbose (message "(Nothing to omit)")))))
;; Try to preserve modified state of buffer. So `%*' doesn't appear
;; in mode-line of omitted buffers.
(set-buffer-modified-p (and old-modified-p
@@ -650,45 +561,6 @@ Optional fourth argument LOCALP is as in `dired-get-filename'."
(and fn (string-match regexp fn))))
msg)))
-;; Compiler does not get fset.
-(declare-function dired-omit-old-add-entry "dired-x")
-
-;; REDEFINE.
-;; Redefine dired-aux.el's version of `dired-add-entry'
-;; Save old defun if not already done:
-(or (fboundp 'dired-omit-old-add-entry)
- (fset 'dired-omit-old-add-entry (symbol-function 'dired-add-entry)))
-
-;; REDEFINE.
-(defun dired-omit-new-add-entry (filename &optional marker-char relative)
- ;; This redefines dired-aux.el's dired-add-entry to avoid calling ls for
- ;; files that are going to be omitted anyway.
- (if dired-omit-mode
- ;; perhaps return t without calling ls
- (let ((omit-re (dired-omit-regexp)))
- (if (or (string= omit-re "")
- (not
- (string-match omit-re
- (cond
- ((eq 'no-dir dired-omit-localp)
- filename)
- ((eq t dired-omit-localp)
- (dired-make-relative filename))
- (t
- (dired-make-absolute
- filename
- (file-name-directory filename)))))))
- ;; if it didn't match, go ahead and add the entry
- (dired-omit-old-add-entry filename marker-char relative)
- ;; dired-add-entry returns t for success, perhaps we should
- ;; return file-exists-p
- t))
- ;; omitting is not turned on at all
- (dired-omit-old-add-entry filename marker-char relative)))
-
-;; Redefine it.
-(fset 'dired-add-entry 'dired-omit-new-add-entry)
-
;;; VIRTUAL DIRED MODE.
@@ -741,7 +613,7 @@ you can relist single subdirs using \\[dired-do-redisplay]."
(forward-line 1)
(and (looking-at "^ wildcard ")
(buffer-substring (match-end 0)
- (progn (end-of-line) (point)))))))
+ (line-end-position))))))
(if wildcard
(setq dirname (expand-file-name wildcard default-directory))))
;; If raw ls listing (not a saved old dired buffer), give it a
@@ -787,7 +659,7 @@ nil."
nil))))
-(defun dired-virtual-revert (&optional arg noconfirm)
+(defun dired-virtual-revert (&optional _arg _noconfirm)
(if (not
(y-or-n-p "Cannot revert a Virtual Dired buffer - switch to Real Dired mode? "))
(error "Cannot revert a Virtual Dired buffer")
@@ -823,22 +695,36 @@ Also useful for `auto-mode-alist' like this:
;; mechanism is provided for special handling of the working directory in
;; special major modes.
+(define-obsolete-variable-alias 'default-directory-alist
+ 'dired-default-directory-alist "24.1")
+
;; It's easier to add to this alist than redefine function
;; default-directory while keeping the old information.
-(defconst default-directory-alist
+(defconst dired-default-directory-alist
'((dired-mode . (if (fboundp 'dired-current-directory)
(dired-current-directory)
default-directory)))
"Alist of major modes and their opinion on `default-directory'.
-This is given as a Lisp expression to evaluate. A resulting value of
-nil is ignored in favor of `default-directory'.")
+Each element has the form (MAJOR . EXPRESSION).
+The function `dired-default-directory' evaluates EXPRESSION to
+determine a default directory.")
+
+(put 'dired-default-directory-alist 'risky-local-variable t) ; gets eval'd
+(make-obsolete-variable 'dired-default-directory-alist
+ "this feature is due to be removed." "24.1")
(defun dired-default-directory ()
- "Usage like variable `default-directory'.
-Knows about the special cases in variable `default-directory-alist'."
- (or (eval (cdr (assq major-mode default-directory-alist)))
+ "Return the `dired-default-directory-alist' entry for the current major-mode.
+If none, return `default-directory'."
+ (or (eval (cdr (assq major-mode dired-default-directory-alist)))
default-directory))
+;; It looks like this was intended to be something of a "general" feature,
+;; but it only ever seems to have been used in dired-smart-shell-command,
+;; and does not seem worth keeping around (?).
+(make-obsolete 'dired-default-directory
+ "this feature is due to be removed." "24.1")
+
(defun dired-smart-shell-command (command &optional output-buffer error-buffer)
"Like function `shell-command', but in the current Virtual Dired directory."
(interactive
@@ -849,89 +735,105 @@ Knows about the special cases in variable `default-directory-alist'."
((eq major-mode 'dired-mode) (dired-get-filename t t))))
current-prefix-arg
shell-command-default-error-buffer))
- (let ((default-directory (dired-default-directory)))
+ (let ((default-directory (or (and (eq major-mode 'dired-mode)
+ (dired-current-directory))
+ default-directory)))
(shell-command command output-buffer error-buffer)))
;;; LOCAL VARIABLES FOR DIRED BUFFERS.
-;; Brief Description:
-;;;
+;; Brief Description (This feature is obsolete as of Emacs 24.1)
+;;
;; * `dired-extra-startup' is part of the `dired-mode-hook'.
-;;;
+;;
;; * `dired-extra-startup' calls `dired-hack-local-variables'
-;;;
+;;
;; * `dired-hack-local-variables' checks the value of
-;;; `dired-local-variables-file'
-;;;
+;; `dired-local-variables-file'
+;;
;; * Check if `dired-local-variables-file' is a non-nil string and is a
-;;; filename found in the directory of the Dired Buffer being created.
-;;;
+;; filename found in the directory of the Dired Buffer being created.
+;;
;; * If `dired-local-variables-file' satisfies the above, then temporarily
-;;; include it in the Dired Buffer at the bottom.
-;;;
+;; include it in the Dired Buffer at the bottom.
+;;
;; * Set `enable-local-variables' temporarily to the user variable
-;;; `dired-enable-local-variables' and run `hack-local-variables' on the
-;;; Dired Buffer.
+;; `dired-enable-local-variables' and run `hack-local-variables' on the
+;; Dired Buffer.
-(defvar dired-local-variables-file (convert-standard-filename ".dired")
+(defcustom dired-local-variables-file (convert-standard-filename ".dired")
"Filename, as string, containing local dired buffer variables to be hacked.
If this file found in current directory, then it will be inserted into dired
buffer and `hack-local-variables' will be run. See Info node
`(emacs)File Variables' for more information on local variables.
-See also `dired-enable-local-variables'.")
+See also `dired-enable-local-variables'."
+ :type 'file
+ :group 'dired)
+
+(make-obsolete-variable 'dired-local-variables-file 'dir-locals-file "24.1")
(defun dired-hack-local-variables ()
"Evaluate local variables in `dired-local-variables-file' for dired buffer."
- (if (and dired-local-variables-file
- (stringp dired-local-variables-file)
- (file-exists-p dired-local-variables-file))
- (let ((opoint (point-max))
- buffer-read-only
- ;; In case user has `enable-local-variables' set to nil we
- ;; override it locally with dired's variable.
- (enable-local-variables dired-enable-local-variables))
- ;; Insert 'em.
- (save-excursion
- (goto-char opoint)
- (insert "\^L\n")
- (insert-file-contents dired-local-variables-file))
- ;; Hack 'em.
- (let ((buffer-file-name dired-local-variables-file))
- (hack-local-variables))
- ;; Make sure that the modeline shows the proper information.
- (dired-sort-set-modeline)
- ;; Delete this stuff: `eobp' is used to find last subdir by dired.el.
- (delete-region opoint (point-max)))))
-
+ (and (stringp dired-local-variables-file)
+ (file-exists-p dired-local-variables-file)
+ (let ((opoint (point-max))
+ (inhibit-read-only t)
+ ;; In case user has `enable-local-variables' set to nil we
+ ;; override it locally with dired's variable.
+ (enable-local-variables dired-enable-local-variables))
+ ;; Insert 'em.
+ (save-excursion
+ (goto-char opoint)
+ (insert "\^L\n")
+ (insert-file-contents dired-local-variables-file))
+ ;; Hack 'em.
+ (unwind-protect
+ (let ((buffer-file-name dired-local-variables-file))
+ (hack-local-variables))
+ ;; Delete this stuff: `eobp' is used to find last subdir by dired.el.
+ (delete-region opoint (point-max)))
+ ;; Make sure that the modeline shows the proper information.
+ (dired-sort-set-modeline))))
+
+(make-obsolete 'dired-hack-local-variables
+ 'hack-dir-local-variables-non-file-buffer "24.1")
+
+;; Does not seem worth a dedicated command.
+;; See the more general features in files-x.el.
(defun dired-omit-here-always ()
- "Create `dired-local-variables-file' for omitting and reverts directory.
-Sets `dired-omit-mode' to t in a local variables file that is readable by
-dired."
+ "Create `dir-locals-file' setting `dired-omit-mode' to t in `dired-mode'.
+If in a Dired buffer, reverts it."
(interactive)
(if (file-exists-p dired-local-variables-file)
- (message "File `./%s' already exists." dired-local-variables-file)
-
- ;; Create `dired-local-variables-file'.
- (with-current-buffer (get-buffer-create " *dot-dired*")
- (erase-buffer)
- (insert "Local Variables:\ndired-omit-mode: t\nEnd:\n")
- (write-file dired-local-variables-file)
- (kill-buffer (current-buffer)))
-
+ (error "Old-style dired-local-variables-file `./%s' found;
+replace it with a dir-locals-file `./%s'"
+ dired-local-variables-file
+ dir-locals-file))
+ (if (file-exists-p dir-locals-file)
+ (message "File `./%s' already exists." dir-locals-file)
+ (with-temp-buffer
+ (insert "\
+\((dired-mode . ((subdirs . nil)
+ (dired-omit-mode . t))))\n")
+ (write-file dir-locals-file))
;; Run extra-hooks and revert directory.
- (dired-extra-startup)
- (dired-revert)))
+ (when (derived-mode-p 'dired-mode)
+ (hack-dir-local-variables-non-file-buffer)
+ (dired-extra-startup)
+ (dired-revert))))
+
+(make-obsolete 'dired-omit-here-always 'add-dir-local-variable "24.1")
;;; GUESS SHELL COMMAND.
;; Brief Description:
;;;
-;; `dired-do-shell-command' is bound to `!' by dired.el.
+;; * `dired-do-shell-command' is bound to `!' by dired.el.
;;;
-;; * Redefine `dired-read-shell-command' so it calls
-;;; `dired-guess-shell-command'.
+;; * `dired-guess-shell-command' provides smarter defaults for
+;;; dired-aux.el's `dired-read-shell-command'.
;;;
;; * `dired-guess-shell-command' calls `dired-guess-default' with list of
;;; marked files.
@@ -958,9 +860,11 @@ dired."
;; NOTE: Use `gunzip -c' instead of `zcat' on `.gz' files. Some do not
;; install GNU zip's version of zcat.
+(autoload 'Man-support-local-filenames "man")
+
(defvar dired-guess-shell-alist-default
(list
- (list "\\.tar$"
+ (list "\\.tar\\'"
'(if dired-guess-shell-gnutar
(concat dired-guess-shell-gnutar " xvf")
"tar xvf")
@@ -978,7 +882,7 @@ dired."
;; REGEXPS for compressed archives must come before the .Z rule to
;; be recognized:
- (list "\\.tar\\.Z$"
+ (list "\\.tar\\.Z\\'"
;; Untar it.
'(if dired-guess-shell-gnutar
(concat dired-guess-shell-gnutar " zxvf")
@@ -988,7 +892,7 @@ dired."
" " dired-guess-shell-znew-switches))
;; gzip'ed archives
- (list "\\.t\\(ar\\.\\)?gz$"
+ (list "\\.t\\(ar\\.\\)?gz\\'"
'(if dired-guess-shell-gnutar
(concat dired-guess-shell-gnutar " zxvf")
(concat "gunzip -qc * | tar xvf -"))
@@ -1008,7 +912,7 @@ dired."
(concat "gunzip -qc * | tar tvf -")))
;; bzip2'ed archives
- (list "\\.t\\(ar\\.bz2\\|bz\\)$"
+ (list "\\.t\\(ar\\.bz2\\|bz\\)\\'"
"bunzip2 -c * | tar xvf -"
;; Extract files into a separate subdirectory
'(concat "mkdir " (file-name-sans-extension file)
@@ -1018,7 +922,7 @@ dired."
"bunzip2")
;; xz'ed archives
- (list "\\.t\\(ar\\.\\)?xz$"
+ (list "\\.t\\(ar\\.\\)?xz\\'"
"unxz -c * | tar xvf -"
;; Extract files into a separate subdirectory
'(concat "mkdir " (file-name-sans-extension file)
@@ -1027,94 +931,103 @@ dired."
;; Optional decompression.
"unxz")
- '("\\.shar\\.Z$" "zcat * | unshar")
- '("\\.shar\\.g?z$" "gunzip -qc * | unshar")
+ '("\\.shar\\.Z\\'" "zcat * | unshar")
+ '("\\.shar\\.g?z\\'" "gunzip -qc * | unshar")
- '("\\.e?ps$" "ghostview" "xloadimage" "lpr")
- (list "\\.e?ps\\.g?z$" "gunzip -qc * | ghostview -"
+ '("\\.e?ps\\'" "ghostview" "xloadimage" "lpr")
+ (list "\\.e?ps\\.g?z\\'" "gunzip -qc * | ghostview -"
;; Optional decompression.
'(concat "gunzip" (if dired-guess-shell-gzip-quiet " -q")))
- (list "\\.e?ps\\.Z$" "zcat * | ghostview -"
+ (list "\\.e?ps\\.Z\\'" "zcat * | ghostview -"
;; Optional conversion to gzip format.
'(concat "znew" (if dired-guess-shell-gzip-quiet " -q")
" " dired-guess-shell-znew-switches))
- '("\\.patch$" "cat * | patch")
- (list "\\.patch\\.g?z$" "gunzip -qc * | patch"
+ '("\\.patch\\'" "cat * | patch")
+ (list "\\.patch\\.g?z\\'" "gunzip -qc * | patch"
;; Optional decompression.
'(concat "gunzip" (if dired-guess-shell-gzip-quiet " -q")))
- (list "\\.patch\\.Z$" "zcat * | patch"
+ (list "\\.patch\\.Z\\'" "zcat * | patch"
;; Optional conversion to gzip format.
'(concat "znew" (if dired-guess-shell-gzip-quiet " -q")
" " dired-guess-shell-znew-switches))
;; The following four extensions are useful with dired-man ("N" key)
- (list "\\.\\(?:[0-9]\\|man\\)$" '(progn (require 'man)
- (if (Man-support-local-filenames)
- "man -l"
- "cat * | tbl | nroff -man -h")))
- (list "\\.\\(?:[0-9]\\|man\\)\\.g?z$" '(progn (require 'man)
- (if (Man-support-local-filenames)
- "man -l"
- "gunzip -qc * | tbl | nroff -man -h"))
+ ;; FIXME "man ./" does not work with dired-do-shell-command,
+ ;; because there seems to be no way for us to modify the filename,
+ ;; only the command. Hmph. `dired-man' works though.
+ (list "\\.\\(?:[0-9]\\|man\\)\\'" '(let ((loc (Man-support-local-filenames)))
+ (cond ((eq loc 'man-db) "man -l")
+ ((eq loc 'man) "man ./")
+ (t
+ "cat * | tbl | nroff -man -h"))))
+ (list "\\.\\(?:[0-9]\\|man\\)\\.g?z\\'"
+ '(let ((loc (Man-support-local-filenames)))
+ (cond ((eq loc 'man-db)
+ "man -l")
+ ((eq loc 'man)
+ "man ./")
+ (t "gunzip -qc * | tbl | nroff -man -h")))
;; Optional decompression.
'(concat "gunzip" (if dired-guess-shell-gzip-quiet " -q")))
- (list "\\.[0-9]\\.Z$" '(progn (require 'man)
- (if (Man-support-local-filenames)
- "man -l"
- "zcat * | tbl | nroff -man -h"))
+ (list "\\.[0-9]\\.Z\\'" '(let ((loc (Man-support-local-filenames)))
+ (cond ((eq loc 'man-db) "man -l")
+ ((eq loc 'man) "man ./")
+ (t "zcat * | tbl | nroff -man -h")))
;; Optional conversion to gzip format.
'(concat "znew" (if dired-guess-shell-gzip-quiet " -q")
" " dired-guess-shell-znew-switches))
- '("\\.pod$" "perldoc" "pod2man * | nroff -man")
-
- '("\\.dvi$" "xdvi" "dvips") ; preview and printing
- '("\\.au$" "play") ; play Sun audiofiles
- '("\\.mpe?g$\\|\\.avi$" "xine -p")
- '("\\.ogg$" "ogg123")
- '("\\.mp3$" "mpg123")
- '("\\.wav$" "play")
- '("\\.uu$" "uudecode") ; for uudecoded files
- '("\\.hqx$" "mcvert")
- '("\\.sh$" "sh") ; execute shell scripts
- '("\\.xbm$" "bitmap") ; view X11 bitmaps
- '("\\.gp$" "gnuplot")
- '("\\.p[bgpn]m$" "xloadimage")
- '("\\.gif$" "xloadimage") ; view gif pictures
- '("\\.tif$" "xloadimage")
- '("\\.png$" "display") ; xloadimage 4.1 doesn't grok PNG
- '("\\.jpe?g$" "xloadimage")
- '("\\.fig$" "xfig") ; edit fig pictures
- '("\\.out$" "xgraph") ; for plotting purposes.
- '("\\.tex$" "latex" "tex")
- '("\\.texi\\(nfo\\)?$" "makeinfo" "texi2dvi")
- '("\\.pdf$" "xpdf")
- '("\\.doc$" "antiword" "strings")
- '("\\.rpm$" "rpm -qilp" "rpm -ivh")
- '("\\.dia$" "dia")
- '("\\.mgp$" "mgp")
+ '("\\.pod\\'" "perldoc" "pod2man * | nroff -man")
+
+ '("\\.dvi\\'" "xdvi" "dvips") ; preview and printing
+ '("\\.au\\'" "play") ; play Sun audiofiles
+ '("\\.mpe?g\\'\\|\\.avi\\'" "xine -p")
+ '("\\.ogg\\'" "ogg123")
+ '("\\.mp3\\'" "mpg123")
+ '("\\.wav\\'" "play")
+ '("\\.uu\\'" "uudecode") ; for uudecoded files
+ '("\\.hqx\\'" "mcvert")
+ '("\\.sh\\'" "sh") ; execute shell scripts
+ '("\\.xbm\\'" "bitmap") ; view X11 bitmaps
+ '("\\.gp\\'" "gnuplot")
+ '("\\.p[bgpn]m\\'" "xloadimage")
+ '("\\.gif\\'" "xloadimage") ; view gif pictures
+ '("\\.tif\\'" "xloadimage")
+ '("\\.png\\'" "display") ; xloadimage 4.1 doesn't grok PNG
+ '("\\.jpe?g\\'" "xloadimage")
+ '("\\.fig\\'" "xfig") ; edit fig pictures
+ '("\\.out\\'" "xgraph") ; for plotting purposes.
+ '("\\.tex\\'" "latex" "tex")
+ '("\\.texi\\(nfo\\)?\\'" "makeinfo" "texi2dvi")
+ '("\\.pdf\\'" "xpdf")
+ '("\\.doc\\'" "antiword" "strings")
+ '("\\.rpm\\'" "rpm -qilp" "rpm -ivh")
+ '("\\.dia\\'" "dia")
+ '("\\.mgp\\'" "mgp")
;; Some other popular archivers.
- (list "\\.zip$" "unzip" "unzip -l"
+ (list "\\.zip\\'" "unzip" "unzip -l"
;; Extract files into a separate subdirectory
'(concat "unzip" (if dired-guess-shell-gzip-quiet " -q")
" -d " (file-name-sans-extension file)))
- '("\\.zoo$" "zoo x//")
- '("\\.lzh$" "lharc x")
- '("\\.arc$" "arc x")
- '("\\.shar$" "unshar")
+ '("\\.zoo\\'" "zoo x//")
+ '("\\.lzh\\'" "lharc x")
+ '("\\.arc\\'" "arc x")
+ '("\\.shar\\'" "unshar")
+ '("\\.rar\\'" "unrar x")
+ '("\\.7z\\'" "7z x")
;; Compression.
- (list "\\.g?z$" '(concat "gunzip" (if dired-guess-shell-gzip-quiet " -q")))
- (list "\\.dz$" "dictunzip")
- (list "\\.bz2$" "bunzip2")
- (list "\\.xz$" "unxz")
- (list "\\.Z$" "uncompress"
+ (list "\\.g?z\\'" '(concat "gunzip" (if dired-guess-shell-gzip-quiet " -q")))
+ (list "\\.dz\\'" "dictunzip")
+ (list "\\.bz2\\'" "bunzip2")
+ (list "\\.xz\\'" "unxz")
+ (list "\\.Z\\'" "uncompress"
;; Optional conversion to gzip format.
'(concat "znew" (if dired-guess-shell-gzip-quiet " -q")
" " dired-guess-shell-znew-switches))
- '("\\.sign?$" "gpg --verify"))
+ '("\\.sign?\\'" "gpg --verify"))
"Default alist used for shell command guessing.
See `dired-guess-shell-alist-user'.")
@@ -1187,10 +1100,9 @@ See `dired-guess-shell-alist-user'."
;; Return commands or nil if flist is still non-nil.
;; Evaluate the commands in order that any logical testing will be done.
- (cond ((not (cdr cmds))
- (eval (car cmds))) ; single command
- (t
- (mapcar (function eval) cmds)))))
+ (if (cdr cmds)
+ (mapcar #'eval cmds)
+ (eval (car cmds))))) ; single command
(defun dired-guess-shell-command (prompt files)
"Ask user with PROMPT for a shell command, guessing a default from FILES."
@@ -1217,23 +1129,6 @@ See `dired-guess-shell-alist-user'."
;; If we got a return, then return default.
(if (equal val "") default val))))
-;; REDEFINE.
-;; Redefine dired-aux.el's version:
-(defun dired-read-shell-command (prompt arg files)
- "Read a dired shell command prompting with PROMPT (using `read-shell-command').
-ARG is the prefix arg and may be used to indicate in the prompt which
-FILES are affected.
-This is an extra function so that you can redefine it."
- (minibuffer-with-setup-hook
- (lambda ()
- (set (make-local-variable 'minibuffer-default-add-function)
- 'minibuffer-default-add-dired-shell-commands))
- (dired-mark-pop-up
- nil 'shell files
- 'dired-guess-shell-command
- (format prompt (dired-mark-prompt arg files)) ; PROMPT
- files))) ; FILES
-
;;; RELATIVE SYMBOLIC LINKS.
@@ -1260,8 +1155,7 @@ results in
;; Find common initial file name components:
(let (next)
(while (and (setq next (string-match "/" file1 index))
- (setq next (1+ next))
- (< next (min len1 len2))
+ (< (setq next (1+ next)) (min len1 len2))
;; For the comparison, both substrings must end in
;; `/', so NEXT is *one plus* the result of the
;; string-match.
@@ -1286,14 +1180,15 @@ results in
(setq count (1+ count)
start (1+ start)))
;; ... and prepend a "../" for each slash found:
- (while (> count 0)
- (setq count (1- count)
- name1 (concat "../" name1)))))
+ (dotimes (_n count)
+ (setq name1 (concat "../" name1)))))
(make-symbolic-link
(directory-file-name name1) ; must not link to foo/
; (trailing slash!)
name2 ok-if-already-exists)))
+(autoload 'dired-do-create-files "dired-aux")
+
;;;###autoload
(defun dired-do-relsymlink (&optional arg)
"Relative symlink all marked (or next ARG) files into a directory.
@@ -1308,16 +1203,19 @@ not absolute ones like
For absolute symlinks, use \\[dired-do-symlink]."
(interactive "P")
- (dired-do-create-files 'relsymlink (function dired-make-relative-symlink)
+ (dired-do-create-files 'relsymlink #'dired-make-relative-symlink
"RelSymLink" arg dired-keep-marker-relsymlink))
+(autoload 'dired-mark-read-regexp "dired-aux")
+(autoload 'dired-do-create-files-regexp "dired-aux")
+
(defun dired-do-relsymlink-regexp (regexp newname &optional arg whole-name)
"RelSymlink all marked files containing REGEXP to NEWNAME.
See functions `dired-do-rename-regexp' and `dired-do-relsymlink'
for more info."
(interactive (dired-mark-read-regexp "RelSymLink"))
(dired-do-create-files-regexp
- (function dired-make-relative-symlink)
+ #'dired-make-relative-symlink
"RelSymLink" arg regexp newname whole-name dired-keep-marker-relsymlink))
@@ -1357,59 +1255,50 @@ displayed this way is restricted by the height of the current window and
To keep dired buffer displayed, type \\[split-window-vertically] first.
To display just marked files, type \\[delete-other-windows] first."
-
(interactive "P")
(dired-simultaneous-find-file (dired-get-marked-files) noselect))
(defun dired-simultaneous-find-file (file-list noselect)
-
"Visit all files in FILE-LIST and display them simultaneously.
The current window is split across all files in FILE-LIST, as evenly as
possible. Remaining lines go to the bottom-most window. The number of
files that can be displayed this way is restricted by the height of the
current window and the variable `window-min-height'. With non-nil
NOSELECT the files are merely found but not selected."
-
;; We don't make this function interactive because it is usually too clumsy
;; to specify FILE-LIST interactively unless via dired.
-
(let (size)
-
(if noselect
;; Do not select the buffer.
(find-file-noselect (car file-list))
-
;; We will have to select the buffer. Calculate and check window size.
(setq size (/ (window-height) (length file-list)))
(or (<= window-min-height size)
(error "Too many files to visit simultaneously. Try C-u prefix"))
(find-file (car file-list)))
-
;; Decrement.
- (setq file-list (cdr file-list))
-
- (while file-list
-
+ (dolist (file (cdr file-list))
(if noselect
;; Do not select the buffer.
- (find-file-noselect (car file-list))
-
+ (find-file-noselect file)
;; Vertically split off a window of desired size. Upper window will
;; have SIZE lines. Select lower (larger) window. We split it again.
(select-window (split-window nil size))
- (find-file (car file-list)))
-
- ;; Decrement.
- (setq file-list (cdr file-list)))))
+ (find-file file)))))
;;; MISCELLANEOUS COMMANDS.
;; Run man on files.
+(declare-function Man-getpage-in-background "man" (topic))
+
+(defvar manual-program) ; from man.el
+
(defun dired-man ()
- "Run man on this file. Display old buffer if buffer name matches filename.
-Uses `man.el' of \\[manual-entry] fame."
+ "Run `man' on this file."
+;; Used also to say: "Display old buffer if buffer name matches filename."
+;; but I have no idea what that means.
(interactive)
(require 'man)
(let* ((file (dired-get-filename))
@@ -1421,31 +1310,27 @@ Uses `man.el' of \\[manual-entry] fame."
;; Run Info on files.
(defun dired-info ()
- "Run info on this file."
+ "Run `info' on this file."
(interactive)
(info (dired-get-filename)))
;; Run mail on mail folders.
-;; Avoid compiler warning.
-(eval-when-compile
- (when (not (fboundp 'vm-visit-folder))
- (defun vm-visit-folder (file &optional arg)
- nil)))
+(declare-function vm-visit-folder "ext:vm" (folder &optional read-only))
+(defvar vm-folder-directory)
(defun dired-vm (&optional read-only)
"Run VM on this file.
-With prefix arg, visit folder read-only (this requires at least VM 5).
-See also variable `dired-vm-read-only-folders'."
+With optional prefix argument, visits the folder read-only.
+Otherwise obeys the value of `dired-vm-read-only-folders'."
(interactive "P")
(let ((dir (dired-current-directory))
(fil (dired-get-filename)))
- ;; take care to supply 2nd arg only if requested - may still run VM 4!
- (cond (read-only (vm-visit-folder fil t))
- ((eq t dired-vm-read-only-folders) (vm-visit-folder fil t))
- ((null dired-vm-read-only-folders) (vm-visit-folder fil))
- (t (vm-visit-folder fil (not (file-writable-p fil)))))
- ;; so that pressing `v' inside VM does prompt within current directory:
+ (vm-visit-folder fil (or read-only
+ (eq t dired-vm-read-only-folders)
+ (and dired-vm-read-only-folders
+ (not (file-writable-p fil)))))
+ ;; So that pressing `v' inside VM does prompt within current directory:
(set (make-local-variable 'vm-folder-directory) dir)))
(defun dired-rmail ()
@@ -1454,7 +1339,7 @@ See also variable `dired-vm-read-only-folders'."
(rmail (dired-get-filename)))
(defun dired-do-run-mail ()
- "If `dired-bind-vm' is t, then function `dired-vm', otherwise `dired-rmail'."
+ "If `dired-bind-vm' is non-nil, call `dired-vm', else call `dired-rmail'."
(interactive)
(if dired-bind-vm
;; Read mail folder using vm.
@@ -1465,43 +1350,13 @@ See also variable `dired-vm-read-only-folders'."
;;; MISCELLANEOUS INTERNAL FUNCTIONS.
-(declare-function dired-old-find-buffer-nocreate "dired-x")
-
-(or (fboundp 'dired-old-find-buffer-nocreate)
- (fset 'dired-old-find-buffer-nocreate
- (symbol-function 'dired-find-buffer-nocreate)))
-
-;; REDEFINE.
-;; Redefines dired.el's version of `dired-find-buffer-nocreate'
-(defun dired-find-buffer-nocreate (dirname &optional mode)
- (if (and dired-find-subdir
- ;; don't try to find a wildcard as a subdirectory
- (string-equal dirname (file-name-directory dirname)))
- (let* ((cur-buf (current-buffer))
- (buffers (nreverse
- (dired-buffers-for-dir (expand-file-name dirname))))
- (cur-buf-matches (and (memq cur-buf buffers)
- ;; wildcards must match, too:
- (equal dired-directory dirname))))
- ;; We don't want to switch to the same buffer---
- (setq buffers (delq cur-buf buffers));;need setq with delq
- (or (car (sort buffers (function dired-buffer-more-recently-used-p)))
- ;; ---unless it's the only possibility:
- (and cur-buf-matches cur-buf)))
- (dired-old-find-buffer-nocreate dirname mode)))
-
;; This should be a builtin
(defun dired-buffer-more-recently-used-p (buffer1 buffer2)
- "Return t if BUFFER1 is more recently used than BUFFER2."
- (if (equal buffer1 buffer2)
- nil
- (let ((more-recent nil)
- (list (buffer-list)))
- (while (and list
- (not (setq more-recent (equal buffer1 (car list))))
- (not (equal buffer2 (car list))))
- (setq list (cdr list)))
- more-recent)))
+ "Return t if BUFFER1 is more recently used than BUFFER2.
+Considers buffers closer to the car of `buffer-list' to be more recent."
+ (and (not (equal buffer1 buffer2))
+ (memq buffer1 (buffer-list))
+ (not (memq buffer1 (memq buffer2 (buffer-list))))))
;; Same thing as `dired-buffers-for-dir' of dired.el? - lrd 11/23/93
;; (defun dired-buffers-for-dir-exact (dir)
@@ -1526,19 +1381,26 @@ See also variable `dired-vm-read-only-folders'."
;; (setq dired-buffers (delq elt dired-buffers)))))
;; result))
-;; REDEFINE.
-;; Redefines dired.el's version of `dired-initial-position'
-(defun dired-initial-position (dirname)
- "Where point should go in a new listing of DIRNAME.
-Point assumed at beginning of new subdir line.
-You may redefine this function as you wish, e.g. like in `dired-x.el'."
- (end-of-line)
- (if dired-find-subdir (dired-goto-subdir dirname)) ; new
- (if dired-trivial-filenames (dired-goto-next-nontrivial-file)))
-
;; Does anyone use this? - lrd 6/29/93.
;; Apparently people do use it. - lrd 12/22/97.
+
+(with-no-warnings
+ ;; Warnings are suppresed to avoid "global/dynamic var `X' lacks a prefix".
+ ;; This is unbearably ugly, but not more than having global variables
+ ;; named size, time, name or s, however practical it can be while writing
+ ;; `dired-mark-sexp' predicates.
+ (defvar inode)
+ (defvar s)
+ (defvar mode)
+ (defvar nlink)
+ (defvar uid)
+ (defvar gid)
+ (defvar size)
+ (defvar time)
+ (defvar name)
+ (defvar sym))
+
(defun dired-mark-sexp (predicate &optional unflag-p)
"Mark files for which PREDICATE returns non-nil.
With a prefix arg, unflag those files instead.
@@ -1581,168 +1443,140 @@ to mark all zero length files."
;; there is no file line. Upon success, all variables are set, either
;; to nil or the appropriate value, so they need not be initialized.
;; Moves point within the current line.
- (if (dired-move-to-filename)
- (let (pos
- (mode-len 10) ; length of mode string
- ;; like in dired.el, but with subexpressions \1=inode, \2=s:
- (dired-re-inode-size "\\s *\\([0-9]*\\)\\s *\\([0-9]*\\) ?"))
- (beginning-of-line)
- (forward-char 2)
- (if (looking-at dired-re-inode-size)
- (progn
- (goto-char (match-end 0))
- (setq inode (string-to-number (buffer-substring (match-beginning 1)
- (match-end 1)))
- s (string-to-number (buffer-substring (match-beginning 2)
- (match-end 2)))))
- (setq inode nil
- s nil))
- (setq mode (buffer-substring (point) (+ mode-len (point))))
- (forward-char mode-len)
- (setq nlink (read (current-buffer)))
- ;; Karsten Wenger <kw@cis.uni-muenchen.de> fixed uid.
- (setq uid (buffer-substring (+ (point) 1)
- (progn (forward-word 1) (point))))
- (re-search-forward directory-listing-before-filename-regexp)
- (goto-char (match-beginning 1))
- (forward-char -1)
- (setq size (string-to-number (buffer-substring (save-excursion
- (backward-word 1)
- (setq pos (point)))
- (point))))
- (goto-char pos)
- (backward-word 1)
- ;; if no gid is displayed, gid will be set to uid
- ;; but user will then not reference it anyway in PREDICATE.
- (setq gid (buffer-substring (save-excursion
- (forward-word 1) (point))
- (point))
- time (buffer-substring (match-beginning 1)
- (1- (dired-move-to-filename)))
- name (buffer-substring (point)
- (or
- (dired-move-to-end-of-filename t)
- (point)))
- sym (progn
- (if (looking-at " -> ")
- (buffer-substring
- (progn (forward-char 4) (point))
- (progn (end-of-line) (point)))
- "")))
- t)
- nil)
- (eval predicate)))
+ (dired-move-to-filename)
+ (let (pos
+ (mode-len 10) ; length of mode string
+ ;; like in dired.el, but with subexpressions \1=inode, \2=s:
+ (dired-re-inode-size "\\s *\\([0-9]*\\)\\s *\\([0-9]*\\) ?"))
+ (beginning-of-line)
+ (forward-char 2)
+ (if (looking-at dired-re-inode-size)
+ (progn
+ (goto-char (match-end 0))
+ (setq inode (string-to-number
+ (buffer-substring (match-beginning 1)
+ (match-end 1)))
+ s (string-to-number
+ (buffer-substring (match-beginning 2)
+ (match-end 2)))))
+ (setq inode nil
+ s nil))
+ (setq mode (buffer-substring (point) (+ mode-len (point))))
+ (forward-char mode-len)
+ (setq nlink (read (current-buffer)))
+ ;; Karsten Wenger <kw@cis.uni-muenchen.de> fixed uid.
+ (setq uid (buffer-substring (1+ (point))
+ (progn (forward-word 1) (point))))
+ (re-search-forward directory-listing-before-filename-regexp)
+ (goto-char (match-beginning 1))
+ (forward-char -1)
+ (setq size (string-to-number
+ (buffer-substring (save-excursion
+ (backward-word 1)
+ (setq pos (point)))
+ (point))))
+ (goto-char pos)
+ (backward-word 1)
+ ;; if no gid is displayed, gid will be set to uid
+ ;; but user will then not reference it anyway in PREDICATE.
+ (setq gid (buffer-substring (save-excursion
+ (forward-word 1) (point))
+ (point))
+ time (buffer-substring (match-beginning 1)
+ (1- (dired-move-to-filename)))
+ name (buffer-substring (point)
+ (or
+ (dired-move-to-end-of-filename t)
+ (point)))
+ sym (if (looking-at " -> ")
+ (buffer-substring (progn (forward-char 4) (point))
+ (line-end-position))
+ ""))
+ t)
+ (eval predicate)))
(format "'%s file" predicate))))
;;; FIND FILE AT POINT.
-(defvar dired-x-hands-off-my-keys t
- "*Non-nil means don't bind `dired-x-find-file' over `find-file' on keyboard.
-Similarly for `dired-x-find-file-other-window' over `find-file-other-window'.
-If you change this variable after `dired-x.el' is loaded then do
-\\[dired-x-bind-find-file].")
+(defcustom dired-x-hands-off-my-keys t
+ "Non-nil means don't remap `find-file' to `dired-x-find-file'.
+Similarly for `find-file-other-window' and `dired-x-find-file-other-window'.
+If you change this variable without using \\[customize] after `dired-x.el'
+is loaded then call \\[dired-x-bind-find-file]."
+ :type 'boolean
+ :initialize 'custom-initialize-default
+ :set (lambda (symbol value)
+ (set symbol value)
+ (dired-x-bind-find-file))
+ :group 'dired-x)
-;; Bind `dired-x-find-file{-other-window}' over wherever
-;; `find-file{-other-window}' is bound?
(defun dired-x-bind-find-file ()
- "Bind `dired-x-find-file' in place of `find-file' \(or reverse\).
+ "Bind `dired-x-find-file' in place of `find-file' (or vice-versa).
Similarly for `dired-x-find-file-other-window' and `find-file-other-window'.
-Binding direction based on `dired-x-hands-off-my-keys'.
-This function is part of `after-init-hook'."
+Binding direction based on `dired-x-hands-off-my-keys'."
(interactive)
(if (called-interactively-p 'interactive)
(setq dired-x-hands-off-my-keys
(not (y-or-n-p "Bind dired-x-find-file over find-file? "))))
- (cond ((not dired-x-hands-off-my-keys)
- (substitute-key-definition 'find-file
- 'dired-x-find-file
- (current-global-map))
- (substitute-key-definition 'find-file-other-window
- 'dired-x-find-file-other-window
- (current-global-map)))
- (t
- (substitute-key-definition 'dired-x-find-file
- 'find-file
- (current-global-map))
- (substitute-key-definition 'dired-x-find-file-other-window
- 'find-file-other-window
- (current-global-map))))
- ;; Clear mini-buffer.
- (message nil))
-
-;; Now call it so binding is correct and put on `after-init-hook' in case
-;; user changes binding.
+ (define-key (current-global-map) [remap find-file]
+ (if (not dired-x-hands-off-my-keys) 'dired-x-find-file))
+ (define-key (current-global-map) [remap find-file-other-window]
+ (if (not dired-x-hands-off-my-keys) 'dired-x-find-file-other-window)))
+
+;; Now call it so binding is correct. This could go in the :initialize
+;; slot, but then dired-x-bind-find-file has to be defined before the
+;; defcustom, and we get free variable warnings.
(dired-x-bind-find-file)
-(add-hook 'after-init-hook 'dired-x-bind-find-file)
(defun dired-x-find-file (filename)
"Edit file FILENAME.
-May create a new window, or reuse an existing one.
-See the function `display-buffer'.
-
-Identical to `find-file' except when called interactively, with a prefix arg
-\(e.g., \\[universal-argument]\), in which case it guesses filename near point.
-Useful for editing file mentioned in buffer you are viewing,
-or to test if that file exists. Use minibuffer after snatching filename."
- (interactive (list (read-filename-at-point "Find file: ")))
- (find-file (expand-file-name filename)))
+Like `find-file', except that when called interactively with a
+prefix argument, it offers the filename near point as a default."
+ (interactive (list (dired-x-read-filename-at-point "Find file: ")))
+ (find-file filename))
(defun dired-x-find-file-other-window (filename)
"Edit file FILENAME, in another window.
-May create a new window, or reuse an existing one.
-See the function `display-buffer'.
-
-Identical to `find-file-other-window' except when called interactively, with
-a prefix arg \(e.g., \\[universal-argument]\), in which case it guesses filename near point.
-Useful for editing file mentioned in buffer you are viewing,
-or to test if that file exists. Use minibuffer after snatching filename."
- (interactive (list (read-filename-at-point "Find file: ")))
- (find-file-other-window (expand-file-name filename)))
+Like `find-file-other-window', except that when called interactively with
+a prefix argument, when it offers the filename near point as a default."
+ (interactive (list (dired-x-read-filename-at-point "Find file: ")))
+ (find-file-other-window filename))
;;; Internal functions.
;; Fixme: This should probably use `thing-at-point'. -- fx
(defun dired-filename-at-point ()
- "Get the filename closest to point, but do not change position.
-Has a preference for looking backward when not directly on a symbol.
-Not perfect - point must be in middle of or end of filename."
-
- (let ((filename-chars "-.[:alnum:]_/:$+@")
- start end filename prefix)
-
- (save-excursion
- ;; First see if just past a filename.
- (if (not (eobp))
- (if (looking-at "[] \t\n[{}()]") ; whitespace or some parens
- (progn
- (skip-chars-backward " \n\t\r({[]})")
- (if (not (bobp))
- (backward-char 1)))))
-
- (if (string-match (concat "[" filename-chars "]")
- (char-to-string (following-char)))
+ "Return the filename closest to point, expanded.
+Point should be in or after a filename."
+ (save-excursion
+ ;; First see if just past a filename.
+ (or (eobp) ; why?
+ (when (looking-at "[] \t\n[{}()]") ; whitespace or some parens
+ (skip-chars-backward " \n\t\r({[]})")
+ (or (bobp) (backward-char 1))))
+ (let ((filename-chars "-.[:alnum:]_/:$+@")
+ start prefix)
+ (if (looking-at (format "[%s]" filename-chars))
(progn
- (if (re-search-backward (concat "[^" filename-chars "]") nil t)
- (forward-char)
- (goto-char (point-min)))
- (setq start (point))
- (setq prefix
+ (skip-chars-backward filename-chars)
+ (setq start (point)
+ prefix
+ ;; This is something to do with ange-ftp filenames.
+ ;; It convert foo@bar to /foo@bar.
+ ;; But when does the former occur in dired buffers?
(and (string-match
"^\\w+@"
- (buffer-substring start (line-beginning-position)))
+ (buffer-substring start (line-end-position)))
"/"))
- (goto-char start)
(if (string-match "[/~]" (char-to-string (preceding-char)))
(setq start (1- start)))
- (re-search-forward (concat "\\=[" filename-chars "]*") nil t))
-
+ (skip-chars-forward filename-chars))
(error "No file found around point!"))
-
;; Return string.
(expand-file-name (concat prefix (buffer-substring start (point)))))))
-(defun read-filename-at-point (prompt)
+(defun dired-x-read-filename-at-point (prompt)
"Return filename prompting with PROMPT with completion.
If `current-prefix-arg' is non-nil, uses name at point as guess."
(if current-prefix-arg
@@ -1752,51 +1586,13 @@ If `current-prefix-arg' is non-nil, uses name at point as guess."
guess
nil (file-name-nondirectory guess)))
(read-file-name prompt default-directory)))
+
+(define-obsolete-function-alias 'read-filename-at-point
+ 'dired-x-read-filename-at-point "24.1") ; is this even needed?
;;; BUG REPORTS
-;; Fixme: get rid of this later.
-
-;; This section is provided for reports. It uses Barry A. Warsaw's
-;; reporter.el which is bundled with GNU Emacs v19.
-
-(defconst dired-x-help-address "bug-gnu-emacs@gnu.org"
- "Address(es) accepting submission of reports on dired-x.el.")
-
-(defconst dired-x-variable-list
- (list
- 'dired-bind-vm
- 'dired-vm-read-only-folders
- 'dired-bind-jump
- 'dired-bind-info
- 'dired-bind-man
- 'dired-find-subdir
- 'dired-enable-local-variables
- 'dired-local-variables-file
- 'dired-guess-shell-gnutar
- 'dired-guess-shell-gzip-quiet
- 'dired-guess-shell-znew-switches
- 'dired-guess-shell-alist-user
- 'dired-clean-up-buffers-too
- 'dired-omit-mode
- 'dired-omit-files
- 'dired-omit-extensions
- )
- "List of variables to be appended to reports sent by `dired-x-submit-report'.")
-
-(defun dired-x-submit-report ()
- "Submit via `reporter.el' a bug report on program.
-Send report on `dired-x-file' version `dired-x-version', to
-`dired-x-maintainer' at address `dired-x-help-address' listing
-variables `dired-x-variable-list' in the message."
- (interactive)
-
- (reporter-submit-bug-report
- dired-x-help-address ; address
- "dired-x" ; pkgname
- dired-x-variable-list ; varlist
- nil nil ; pre-/post-hooks
- ""))
+(define-obsolete-function-alias 'dired-x-submit-report 'report-emacs-bug "24.1")
;; As Barry Warsaw would say: "This might be useful..."
@@ -1807,5 +1603,4 @@ variables `dired-x-variable-list' in the message."
;; generated-autoload-file: "dired.el"
;; End:
-;; arch-tag: 71a43ba2-7a00-4793-a028-0613dd7765ae
;;; dired-x.el ends here
diff --git a/lisp/dired.el b/lisp/dired.el
index 4fba72d8106..c581597494c 100644
--- a/lisp/dired.el
+++ b/lisp/dired.el
@@ -1,12 +1,12 @@
-;;; dired.el --- directory-browsing commands
+;;; dired.el --- directory-browsing commands -*- lexical-binding: t -*-
-;; Copyright (C) 1985, 1986, 1992, 1993, 1994, 1995, 1996, 1997, 2000,
-;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+;; Copyright (C) 1985-1986, 1992-1997, 2000-2011
;; 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.
@@ -25,8 +25,8 @@
;;; Commentary:
-;; This is a major mode for directory browsing and editing. It is
-;; documented in the Emacs manual.
+;; This is a major mode for directory browsing and editing.
+;; It is documented in the Emacs manual.
;; Rewritten in 1990/1991 to add tree features, file marking and
;; sorting by Sebastian Kremer <sk@thp.uni-koeln.de>.
@@ -61,32 +61,41 @@ some of the `ls' switches are not supported; see the doc string of
:type 'string
:group 'dired)
-(defvar dired-subdir-switches nil
+(defcustom dired-subdir-switches nil
"If non-nil, switches passed to `ls' for inserting subdirectories.
-If nil, `dired-listing-switches' is used.")
-
-; Don't use absolute file names as /bin should be in any PATH and people
-; may prefer /usr/local/gnu/bin or whatever. However, chown is
-; usually not in PATH.
-
-;;;###autoload
-(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")))
- "Name of chown command (usually `chown' or `/etc/chown').")
+If nil, `dired-listing-switches' is used."
+ :group 'dired
+ :type '(choice (const :tag "Use dired-listing-switches" nil)
+ (string :tag "Switches")))
+
+(defcustom dired-chown-program
+ (purecopy (cond ((executable-find "chown") "chown")
+ ((file-executable-p "/usr/sbin/chown") "/usr/sbin/chown")
+ ((file-executable-p "/etc/chown") "/etc/chown")
+ (t "chown")))
+ "Name of chown command (usually `chown')."
+ :group 'dired
+ :type 'file)
-(defvar dired-use-ls-dired (not (not (string-match "gnu" system-configuration)))
- "Non-nil means Dired should use `ls --dired'.")
+(defcustom dired-use-ls-dired 'unspecified
+ "Non-nil means Dired should use \"ls --dired\".
+The special value of `unspecified' means to check explicitly, and
+save the result in this variable. This is performed the first
+time `dired-insert-directory' is called."
+ :group 'dired
+ :type '(choice (const :tag "Check for --dired support" unspecified)
+ (const :tag "Do not use --dired" nil)
+ (other :tag "Use --dired" t)))
-(defvar dired-chmod-program "chmod"
- "Name of chmod command (usually `chmod').")
+(defcustom dired-chmod-program "chmod"
+ "Name of chmod command (usually `chmod')."
+ :group 'dired
+ :type 'file)
-(defvar dired-touch-program "touch"
- "Name of touch command (usually `touch').")
+(defcustom dired-touch-program "touch"
+ "Name of touch command (usually `touch')."
+ :group 'dired
+ :type 'file)
(defcustom dired-ls-F-marks-symlinks nil
"Informs Dired about how `ls -lF' marks symbolic links.
@@ -104,7 +113,6 @@ always set this variable to t."
:type 'boolean
:group 'dired-mark)
-;;;###autoload
(defcustom dired-trivial-filenames (purecopy "^\\.\\.?$\\|^#")
"Regexp of files to skip when finding first file of a directory.
A value of nil means move to the subdir line.
@@ -241,9 +249,19 @@ Local to each dired buffer. May be a list, in which case the car is the
directory name and the cdr is the list of files to mention.
The directory name must be absolute, but need not be fully expanded.")
+;; Beware of "-l;reboot" etc. See bug#3230.
+(defun dired-safe-switches-p (switches)
+ "Return non-nil if string SWITCHES does not look risky for dired."
+ (or (not switches)
+ (and (stringp switches)
+ (< (length switches) 100) ; arbitrary
+ (string-match "\\` *-[- [:alnum:]]+\\'" switches))))
+
(defvar dired-actual-switches nil
"The value of `dired-listing-switches' used to make this buffer's text.")
+(put 'dired-actual-switches 'safe-local-variable 'dired-safe-switches-p)
+
(defvar dired-re-inode-size "[0-9 \t]*"
"Regexp for optional initial inode and file size as made by `ls -i -s'.")
@@ -593,9 +611,12 @@ Don't use that together with FILTER."
(if current-prefix-arg
(read-string "Dired listing switches: "
dired-listing-switches))
- ;; If a dialog is about to be used, call read-directory-name so
- ;; the dialog code knows we want directories. Some dialogs can
- ;; only select directories or files when popped up, not both.
+ ;; If a dialog is used, call `read-directory-name' so the
+ ;; dialog code knows we want directories. Some dialogs
+ ;; can only select directories or files when popped up,
+ ;; not both. If no dialog is used, call `read-file-name'
+ ;; because the user may want completion of file names for
+ ;; use in a wildcard pattern.
(if (next-read-file-uses-dialog-p)
(read-directory-name (format "Dired %s(directory): " str)
nil default-directory nil)
@@ -752,7 +773,6 @@ for a remote directory. This feature is used by Auto Revert Mode."
buffer-read-only
(dired-directory-changed-p dirname))))
-;;;###autoload
(defcustom dired-auto-revert-buffer nil
"Automatically revert dired buffer on revisiting.
If t, revisiting an existing dired buffer automatically reverts it.
@@ -840,28 +860,47 @@ periodically reverts at specified time intervals."
;; killed buffer, it is removed from this list.
"Alist of expanded directories and their associated dired buffers.")
+(defvar dired-find-subdir)
+
+;; FIXME add a doc-string, and document dired-x extensions.
(defun dired-find-buffer-nocreate (dirname &optional mode)
;; This differs from dired-buffers-for-dir in that it does not consider
;; subdirs of default-directory and searches for the first match only.
;; Also, the major mode must be MODE.
- (setq dirname (expand-file-name dirname))
- (let (found (blist dired-buffers)) ; was (buffer-list)
- (or mode (setq mode 'dired-mode))
- (while blist
- (if (null (buffer-name (cdr (car blist))))
- (setq blist (cdr blist))
- (with-current-buffer (cdr (car blist))
- (if (and (eq major-mode mode)
- dired-directory ;; nil during find-alternate-file
- (equal dirname
- (expand-file-name
- (if (consp dired-directory)
- (car dired-directory)
- dired-directory))))
- (setq found (cdr (car blist))
- blist nil)
- (setq blist (cdr blist))))))
- found))
+ (if (and (featurep 'dired-x)
+ dired-find-subdir
+ ;; Don't try to find a wildcard as a subdirectory.
+ (string-equal dirname (file-name-directory dirname)))
+ (let* ((cur-buf (current-buffer))
+ (buffers (nreverse
+ (dired-buffers-for-dir (expand-file-name dirname))))
+ (cur-buf-matches (and (memq cur-buf buffers)
+ ;; Wildcards must match, too:
+ (equal dired-directory dirname))))
+ ;; We don't want to switch to the same buffer---
+ (setq buffers (delq cur-buf buffers))
+ (or (car (sort buffers #'dired-buffer-more-recently-used-p))
+ ;; ---unless it's the only possibility:
+ (and cur-buf-matches cur-buf)))
+ ;; No dired-x, or dired-find-subdir nil.
+ (setq dirname (expand-file-name dirname))
+ (let (found (blist dired-buffers)) ; was (buffer-list)
+ (or mode (setq mode 'dired-mode))
+ (while blist
+ (if (null (buffer-name (cdr (car blist))))
+ (setq blist (cdr blist))
+ (with-current-buffer (cdr (car blist))
+ (if (and (eq major-mode mode)
+ dired-directory ;; nil during find-alternate-file
+ (equal dirname
+ (expand-file-name
+ (if (consp dired-directory)
+ (car dired-directory)
+ dired-directory))))
+ (setq found (cdr (car blist))
+ blist nil)
+ (setq blist (cdr blist))))))
+ found)))
;; Read in a new dired buffer
@@ -1045,6 +1084,8 @@ BEG..END is the line where the file info is located."
(set-marker file nil)))))
+(defvar ls-lisp-use-insert-directory-program)
+
(defun dired-insert-directory (dir switches &optional file-list wildcard hdr)
"Insert a directory listing of DIR, Dired style.
Use SWITCHES to make the listings.
@@ -1056,7 +1097,20 @@ If HDR is non-nil, insert a header line with the directory name."
(let ((opoint (point))
(process-environment (copy-sequence process-environment))
end)
- (if (or dired-use-ls-dired (file-remote-p dir))
+ (if (and
+ ;; Don't try to invoke `ls' if we are on DOS/Windows where
+ ;; ls-lisp emulation is used, except if they want to use `ls'
+ ;; as indicated by `ls-lisp-use-insert-directory-program'.
+ (not (and (featurep 'ls-lisp)
+ (null ls-lisp-use-insert-directory-program)))
+ (or (if (eq dired-use-ls-dired 'unspecified)
+ ;; Check whether "ls --dired" gives exit code 0, and
+ ;; save the answer in `dired-use-ls-dired'.
+ (setq dired-use-ls-dired
+ (eq (call-process insert-directory-program nil nil nil "--dired")
+ 0))
+ dired-use-ls-dired)
+ (file-remote-p dir)))
(setq switches (concat "--dired " switches)))
;; We used to specify the C locale here, to force English month names;
;; but this should not be necessary any more,
@@ -1127,7 +1181,7 @@ If HDR is non-nil, insert a header line with the directory name."
;; Reverting a dired buffer
-(defun dired-revert (&optional arg noconfirm)
+(defun dired-revert (&optional _arg _noconfirm)
"Reread the dired buffer.
Must also be called after `dired-actual-switches' have changed.
Should not fail even on completely garbaged buffers.
@@ -1280,7 +1334,7 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST."
;; This looks ugly when substitute-command-keys uses C-d instead d:
;; (define-key dired-mode-map "\C-d" 'dired-flag-file-deletion)
(let ((map (make-keymap)))
- (suppress-keymap map)
+ (set-keymap-parent map special-mode-map)
(define-key map [mouse-2] 'dired-mouse-find-file-other-window)
(define-key map [follow-link] 'mouse-face)
;; Commands to mark or flag certain categories of files
@@ -1359,7 +1413,6 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST."
(define-key map "\C-m" 'dired-find-file)
(put 'dired-find-file :advertised-binding "\C-m")
(define-key map "g" 'revert-buffer)
- (define-key map "h" 'describe-mode)
(define-key map "i" 'dired-maybe-insert-subdir)
(define-key map "j" 'dired-goto-file)
(define-key map "k" 'dired-do-kill-lines)
@@ -1369,7 +1422,6 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST."
(define-key map "o" 'dired-find-file-other-window)
(define-key map "\C-o" 'dired-display-file)
(define-key map "p" 'dired-previous-line)
- (define-key map "q" 'quit-window)
(define-key map "s" 'dired-sort-toggle-or-edit)
(define-key map "t" 'dired-toggle-marks)
(define-key map "u" 'dired-unmark)
@@ -1383,10 +1435,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)
@@ -1396,7 +1446,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)
@@ -1412,7 +1462,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)
@@ -1823,6 +1873,7 @@ Keybindings:
(set (make-local-variable 'desktop-save-buffer)
'dired-desktop-buffer-misc-data)
(setq dired-switches-alist nil)
+ (hack-dir-local-variables-non-file-buffer) ; before sorting
(dired-sort-other dired-actual-switches t)
(when (featurep 'dnd)
(set (make-local-variable 'dnd-protocol-alist)
@@ -2015,7 +2066,7 @@ Otherwise, an error occurs in these cases."
;; with quotation marks in their names.
(while (string-match "\\(?:[^\\]\\|\\`\\)\\(\"\\)" file)
(setq file (replace-match "\\\"" nil t file 1)))
-
+
(when (eq system-type 'windows-nt)
(save-match-data
(let ((start 0))
@@ -2092,7 +2143,7 @@ Optional arg GLOBAL means to replace all matches."
;; dired-get-filename.
(concat (or dir default-directory) file))
-(defun dired-make-relative (file &optional dir ignore)
+(defun dired-make-relative (file &optional dir _ignore)
"Convert FILE (an absolute file name) to a name relative to DIR.
If this is impossible, return FILE unchanged.
DIR must be a directory name, not a file name."
@@ -2150,7 +2201,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
@@ -2526,11 +2577,15 @@ instead of `dired-actual-switches'."
;; return value of point (i.e., FOUND):
(goto-char found))))
+(defvar dired-find-subdir)
+
+;; FIXME document whatever dired-x is doing.
(defun dired-initial-position (dirname)
- ;; Where point should go in a new listing of DIRNAME.
- ;; Point assumed at beginning of new subdir line.
- ;; You may redefine this function as you wish, e.g. like in dired-x.el.
+ "Where point should go in a new listing of DIRNAME.
+Point assumed at beginning of new subdir line."
(end-of-line)
+ (and (featurep 'dired-x) dired-find-subdir
+ (dired-goto-subdir dirname))
(if dired-trivial-filenames (dired-goto-next-nontrivial-file)))
;; These are hooks which make tree dired work.
@@ -2592,7 +2647,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.
@@ -2603,15 +2658,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.
@@ -2629,7 +2688,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)")))))
@@ -2644,11 +2703,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.
@@ -2657,14 +2716,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
@@ -2672,10 +2738,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))
@@ -2684,7 +2750,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
@@ -2716,12 +2782,32 @@ non-empty directories is allowed."
(save-excursion (forward-line 1) (point))))))
(dired-clean-up-after-deletion file))
-;; This is a separate function for the sake of dired-x.el.
+(defvar dired-clean-up-buffers-too)
+
(defun dired-clean-up-after-deletion (fn)
- ;; Clean up after a deleted file or directory FN.
+ "Clean up after a deleted file or directory FN.
+Removes any expanded subdirectory of deleted directory.
+If `dired-x' is loaded and `dired-clean-up-buffers-too' is non-nil,
+also offers to kill buffers visiting deleted files and directories."
(save-excursion (and (cdr dired-subdir-alist)
(dired-goto-subdir fn)
- (dired-kill-subdir))))
+ (dired-kill-subdir)))
+ ;; Offer to kill buffer of deleted file FN.
+ (when (and (featurep 'dired-x) dired-clean-up-buffers-too)
+ (let ((buf (get-file-buffer fn)))
+ (and buf
+ (funcall #'y-or-n-p
+ (format "Kill buffer of %s, too? "
+ (file-name-nondirectory fn)))
+ (kill-buffer buf)))
+ (let ((buf-list (dired-buffers-for-dir (expand-file-name fn))))
+ (and buf-list
+ (y-or-n-p (format "Kill dired buffer%s of %s, too? "
+ (dired-plural-s (length buf-list))
+ (file-name-nondirectory fn)))
+ (dolist (buf buf-list)
+ (kill-buffer buf))))))
+
;; Confirmation
@@ -2768,17 +2854,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.
@@ -3145,7 +3233,7 @@ Type \\[help-command] at that time for help."
(interactive "cRemove marks (RET means all): \nP")
(save-excursion
(let* ((count 0)
- (inhibit-read-only t) case-fold-search query
+ (inhibit-read-only t) case-fold-search
(string (format "\n%c" mark))
(help-form "\
Type SPC or `y' to unmark one file, DEL or `n' to skip to next,
@@ -3249,12 +3337,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
@@ -3280,8 +3372,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"))
@@ -3292,24 +3384,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))
@@ -3416,6 +3508,8 @@ Anything else means ask for each directory."
(declare-function dnd-get-local-file-name "dnd" (uri &optional must-exist))
(declare-function dnd-get-local-file-uri "dnd" (uri))
+(defvar dired-overwrite-confirmed) ;Defined in dired-aux.
+
(defun dired-dnd-handle-local-file (uri action)
"Copy, move or link a file to the dired directory.
URI is the file to handle, ACTION is one of copy, move, link or ask.
@@ -3477,38 +3571,38 @@ Ask means pop up a menu for the user to select one of copy, move or link."
(eval-when-compile (require 'desktop))
-(defun dired-desktop-buffer-misc-data (desktop-dirname)
+(defun dired-desktop-buffer-misc-data (dirname)
"Auxiliary information to be saved in desktop file."
(cons
;; Value of `dired-directory'.
(if (consp dired-directory)
;; Directory name followed by list of files.
- (cons (desktop-file-name (car dired-directory) desktop-dirname)
+ (cons (desktop-file-name (car dired-directory) dirname)
(cdr dired-directory))
;; Directory name, optionally with shell wildcard.
- (desktop-file-name dired-directory desktop-dirname))
+ (desktop-file-name dired-directory dirname))
;; Subdirectories in `dired-subdir-alist'.
(cdr
(nreverse
(mapcar
- (function (lambda (f) (desktop-file-name (car f) desktop-dirname)))
+ (function (lambda (f) (desktop-file-name (car f) dirname)))
dired-subdir-alist)))))
-(defun dired-restore-desktop-buffer (desktop-buffer-file-name
- desktop-buffer-name
- desktop-buffer-misc)
+(defun dired-restore-desktop-buffer (_file-name
+ _buffer-name
+ misc-data)
"Restore a dired buffer specified in a desktop file."
- ;; First element of `desktop-buffer-misc' is the value of `dired-directory'.
+ ;; First element of `misc-data' is the value of `dired-directory'.
;; This value is a directory name, optionally with shell wildcard or
;; a directory name followed by list of files.
- (let* ((dired-dir (car desktop-buffer-misc))
+ (let* ((dired-dir (car misc-data))
(dir (if (consp dired-dir) (car dired-dir) dired-dir)))
(if (file-directory-p (file-name-directory dir))
(progn
(dired dired-dir)
- ;; The following elements of `desktop-buffer-misc' are the keys
+ ;; The following elements of `misc-data' are the keys
;; from `dired-subdir-alist'.
- (mapc 'dired-maybe-insert-subdir (cdr desktop-buffer-misc))
+ (mapc 'dired-maybe-insert-subdir (cdr misc-data))
(current-buffer))
(message "Desktop: Directory %s no longer exists." dir)
(when desktop-missing-file-warning (sit-for 1))
@@ -3535,7 +3629,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" "255ac82c318ef43da2e47b931c0f8581")
+;;;;;; dired-diff) "dired-aux" "dired-aux.el" "e34e1bbdb701078d52466c319d8e0cda")
;;; Generated autoloads from dired-aux.el
(autoload 'dired-diff "dired-aux" "\
@@ -3672,7 +3766,7 @@ can be produced by `dired-get-marked-files', for example.
\(fn COMMAND &optional ARG FILE-LIST)" t nil)
(autoload 'dired-run-shell-command "dired-aux" "\
-Not documented
+
\(fn COMMAND)" nil nil)
@@ -3691,17 +3785,23 @@ command with a prefix argument (the value does not matter).
\(fn &optional ARG FMT)" t nil)
(autoload 'dired-compress-file "dired-aux" "\
-Not documented
+
\(fn FILE)" nil nil)
(autoload 'dired-query "dired-aux" "\
-Query user and return nil or t.
-Store answer in symbol VAR (which must initially be bound to nil).
-Format PROMPT with ARGS.
-Binding variable `help-form' will help the user who types the help key.
+Format PROMPT with ARGS, query user, and store the result in SYM.
+The return value is either nil or t.
+
+The user may type y or SPC to accept once; n or DEL to skip once;
+! to accept this and subsequent queries; or q or ESC to decline
+this and subsequent queries.
-\(fn QS-VAR QS-PROMPT &rest QS-ARGS)" nil nil)
+If SYM is already bound to a non-nil value, this function may
+return automatically without querying the user. If SYM is !,
+return t; if SYM is q or ESC, return nil.
+
+\(fn SYM PROMPT &rest ARGS)" nil nil)
(autoload 'dired-do-compress "dired-aux" "\
Compress or uncompress marked (or next ARG) files.
@@ -3734,12 +3834,12 @@ See Info node `(emacs)Subdir switches' for more details.
\(fn &optional ARG TEST-FOR-SUBDIR)" t nil)
(autoload 'dired-add-file "dired-aux" "\
-Not documented
+
\(fn FILENAME &optional MARKER-CHAR)" nil nil)
(autoload 'dired-remove-file "dired-aux" "\
-Not documented
+
\(fn FILE)" nil nil)
@@ -3749,17 +3849,18 @@ Create or update the line for FILE in all Dired buffers it would belong in.
\(fn FILE)" nil nil)
(autoload 'dired-copy-file "dired-aux" "\
-Not documented
+
\(fn FROM TO OK-FLAG)" nil nil)
(autoload 'dired-rename-file "dired-aux" "\
-Not documented
+
\(fn FILE NEWNAME OK-IF-ALREADY-EXISTS)" nil nil)
(autoload 'dired-create-directory "dired-aux" "\
Create a directory called DIRECTORY.
+If DIRECTORY already exists, signal an error.
\(fn DIRECTORY)" t nil)
@@ -3987,8 +4088,8 @@ 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"
-;;;;;; "48197b7ca054193643e01957196dd491")
+;;;### (autoloads (dired-do-relsymlink dired-jump-other-window dired-jump)
+;;;;;; "dired-x" "dired-x.el" "94bd5ca0bd260e43402e3cd9f114970c")
;;; Generated autoloads from dired-x.el
(autoload 'dired-jump "dired-x" "\
@@ -3997,8 +4098,16 @@ 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 FILE-NAME)" t nil)
+
+(autoload 'dired-jump-other-window "dired-x" "\
+Like \\[dired-jump] (`dired-jump') but in other window.
-\(fn &optional OTHER-WINDOW)" t nil)
+\(fn &optional FILE-NAME)" t nil)
(autoload 'dired-do-relsymlink "dired-x" "\
Relative symlink all marked (or next ARG) files into a directory.
@@ -4023,5 +4132,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 50017a0219f..c3dfc747772 100644
--- a/lisp/dirtrack.el
+++ b/lisp/dirtrack.el
@@ -1,7 +1,6 @@
;;; dirtrack.el --- Directory Tracking by watching the prompt
-;; Copyright (C) 1996, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 2001-2011 Free Software Foundation, Inc.
;; Author: Peter Breton <pbreton@cs.umb.edu>
;; Created: Sun Nov 17 1996
@@ -143,15 +142,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 +151,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
@@ -238,9 +230,9 @@ function `dirtrack-debug-mode' to turn on debugging output."
(let (prompt-path
(current-dir default-directory)
(dirtrack-regexp (nth 0 dirtrack-list))
- (match-num (nth 1 dirtrack-list))
+ (match-num (nth 1 dirtrack-list)))
;; Currently unimplemented, it seems. --Stef
- (multi-line (nth 2 dirtrack-list)))
+ ;; (multi-line (nth 2 dirtrack-list)))
(save-excursion
;; No match
(if (not (string-match dirtrack-regexp input))
@@ -276,5 +268,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 4f4182618e7..7a9043a6a0a 100644
--- a/lisp/disp-table.el
+++ b/lisp/disp-table.el
@@ -1,12 +1,13 @@
;;; disp-table.el --- functions for dealing with char tables
-;; Copyright (C) 1987, 1994, 1995, 1999, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1987, 1994-1995, 1999, 2001-2011
+;; Free Software Foundation, Inc.
;; Author: Erik Naggum <erik@naggum.no>
;; Based on a previous version by Howard Gayle
;; Maintainer: FSF
;; Keywords: i18n
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -280,5 +281,4 @@ in `.emacs'."
(provide 'disp-table)
-;; arch-tag: ffe4c28c-960c-47aa-b8a8-ae89d371ffc7
;;; disp-table.el ends here
diff --git a/lisp/dnd.el b/lisp/dnd.el
index 5d1d0c75bc4..2d0c6fc31cd 100644
--- a/lisp/dnd.el
+++ b/lisp/dnd.el
@@ -1,11 +1,11 @@
;;; dnd.el --- drag and drop support. -*- coding: utf-8 -*-
-;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2005-2011 Free Software Foundation, Inc.
;; Author: Jan Djärv <jan.h.d@swipnet.se>
;; Maintainer: FSF
;; Keywords: window, drag, drop
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -134,6 +134,16 @@ Return nil if URI is not a local file."
(string-equal system-name-no-dot hostname)))
(concat "file://" (substring uri (+ 7 (length hostname)))))))
+(defsubst dnd-unescape-uri (uri)
+ (replace-regexp-in-string
+ "%[A-Fa-f0-9][A-Fa-f0-9]"
+ (lambda (arg)
+ (let ((str (make-string 1 0)))
+ (aset str 0 (string-to-number (substring arg 1) 16))
+ str))
+ uri t t))
+
+;; http://lists.gnu.org/archive/html/emacs-devel/2006-05/msg01060.html
(defun dnd-get-local-file-name (uri &optional must-exist)
"Return file name converted from file:/// or file: syntax.
URI is the uri for the file. If MUST-EXIST is given and non-nil,
@@ -143,24 +153,14 @@ Return nil if URI is not a local file."
(substring uri (1- (match-end 0))))
((string-match "^file:" uri) ; Old KDE, Motif, Sun
(substring uri (match-end 0))))))
- (when (and f must-exist)
- (setq f (replace-regexp-in-string
- "%[A-Fa-f0-9][A-Fa-f0-9]"
- (lambda (arg)
- (let ((str (make-string 1 0)))
- (aset str 0 (string-to-number (substring arg 1) 16))
- str))
- f t t))
- (let* ((decoded-f (decode-coding-string
- f
- (or file-name-coding-system
- default-file-name-coding-system))))
- (setq f (cond ((file-readable-p decoded-f) decoded-f)
- ((file-readable-p f) f)
- (t nil)))))
+ (and f (setq f (decode-coding-string (dnd-unescape-uri f)
+ (or file-name-coding-system
+ default-file-name-coding-system))))
+ (when (and f must-exist (not (file-readable-p f)))
+ (setq f nil))
f))
-(defun dnd-open-local-file (uri action)
+(defun dnd-open-local-file (uri _action)
"Open a local file.
The file is opened in the current window, or a new window if
`dnd-open-file-other-window' is set. URI is the url for the file,
@@ -180,7 +180,7 @@ An alternative for systems that do not support unc file names is
'private)
(error "Can not read %s" uri))))
-(defun dnd-open-remote-url (uri action)
+(defun dnd-open-remote-url (uri _action)
"Open a remote file with `find-file' and `url-handler-mode'.
Turns `url-handler-mode' on if not on before. The file is opened in the
current window, or a new window if `dnd-open-file-other-window' is set.
@@ -226,5 +226,4 @@ TEXT is the text as a string, WINDOW is the window where the drop happened."
(provide 'dnd)
-;; arch-tag: 0472f6a5-2e8f-4304-9e44-1a0877c771b7
;;; dnd.el ends here
diff --git a/lisp/doc-view.el b/lisp/doc-view.el
index af6e4f3ef58..7bd1a55011e 100644
--- a/lisp/doc-view.el
+++ b/lisp/doc-view.el
@@ -1,6 +1,7 @@
-;;; doc-view.el --- View PDF/PostScript/DVI files in Emacs
+;;; doc-view.el --- View PDF/PostScript/DVI files in Emacs -*- lexical-binding: t -*-
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;;
;; Author: Tassilo Horn <tassilo@member.fsf.org>
;; Maintainer: Tassilo Horn <tassilo@member.fsf.org>
@@ -155,7 +156,7 @@
(defcustom doc-view-ghostscript-options
'("-dSAFER" ;; Avoid security problems when rendering files from untrusted
- ;; sources.
+ ;; sources.
"-dNOPAUSE" "-sDEVICE=png16m" "-dTextAlphaBits=4"
"-dBATCH" "-dGraphicsAlphaBits=4" "-dQUIET")
"A list of options to give to ghostscript."
@@ -168,6 +169,12 @@ Higher values result in larger images."
:type 'number
:group 'doc-view)
+(defcustom doc-view-image-width 850
+ "Default image width.
+Has only an effect if imagemagick support is compiled into emacs."
+ :type 'number
+ :group 'doc-view)
+
(defcustom doc-view-dvipdfm-program (executable-find "dvipdfm")
"Program to convert DVI files to PDF.
@@ -190,6 +197,13 @@ If this and `doc-view-dvipdfm-program' are set,
:type 'file
:group 'doc-view)
+(defcustom doc-view-unoconv-program (executable-find "unoconv")
+ "Program to convert any file type readable by OpenOffice.org to PDF.
+
+Needed for viewing OpenOffice.org (and MS Office) files."
+ :type 'file
+ :group 'doc-view)
+
(defcustom doc-view-ps2pdf-program (executable-find "ps2pdf")
"Program to convert PS files to PDF.
@@ -314,6 +328,10 @@ Can be `dvi', `pdf', or `ps'.")
;; Zoom in/out.
(define-key map "+" 'doc-view-enlarge)
(define-key map "-" 'doc-view-shrink)
+ ;; Fit the image to the window
+ (define-key map "W" 'doc-view-fit-width-to-window)
+ (define-key map "H" 'doc-view-fit-height-to-window)
+ (define-key map "P" 'doc-view-fit-page-to-window)
;; Killing the buffer (and the process)
(define-key map (kbd "k") 'doc-view-kill-proc-and-buffer)
(define-key map (kbd "K") 'doc-view-kill-proc)
@@ -429,9 +447,7 @@ Can be `dvi', `pdf', or `ps'.")
doc-view-current-converter-processes)
;; The PNG file hasn't been generated yet.
(doc-view-pdf->png-1 doc-view-buffer-file-name file page
- (lexical-let ((page page)
- (win (selected-window))
- (file file))
+ (let ((win (selected-window)))
(lambda ()
(and (eq (current-buffer) (window-buffer win))
;; If we changed page in the mean
@@ -440,7 +456,7 @@ Can be `dvi', `pdf', or `ps'.")
;; Make sure we don't infloop.
(file-readable-p file)
(with-selected-window win
- (doc-view-goto-page page))))))))
+ (doc-view-goto-page page))))))))
(overlay-put (doc-view-current-overlay)
'help-echo (doc-view-current-info))))
@@ -604,10 +620,12 @@ It's a subdirectory of `doc-view-cache-directory'."
;;;###autoload
(defun doc-view-mode-p (type)
- "Return non-nil if image type TYPE is available for `doc-view'.
-Image types are symbols like `dvi', `postscript' or `pdf'."
+ "Return non-nil if document type TYPE is available for `doc-view'.
+Document types are symbols like `dvi', `ps', `pdf', or `odf' (any
+OpenDocument format)."
(and (display-graphic-p)
- (image-type-available-p 'png)
+ (or (image-type-available-p 'imagemagick)
+ (image-type-available-p 'png))
(cond
((eq type 'dvi)
(and (doc-view-mode-p 'pdf)
@@ -619,6 +637,10 @@ Image types are symbols like `dvi', `postscript' or `pdf'."
(eq type 'pdf))
(and doc-view-ghostscript-program
(executable-find doc-view-ghostscript-program)))
+ ((eq type 'odf)
+ (and doc-view-unoconv-program
+ (executable-find doc-view-unoconv-program)
+ (doc-view-mode-p 'pdf)))
(t ;; unknown image type
nil))))
@@ -629,15 +651,95 @@ Image types are symbols like `dvi', `postscript' or `pdf'."
(defun doc-view-enlarge (factor)
"Enlarge the document."
(interactive (list doc-view-shrink-factor))
- (set (make-local-variable 'doc-view-resolution)
- (* factor doc-view-resolution))
- (doc-view-reconvert-doc))
+ (if (eq (plist-get (cdr (doc-view-current-image)) :type)
+ 'imagemagick)
+ ;; ImageMagick supports on-the-fly-rescaling
+ (progn
+ (set (make-local-variable 'doc-view-image-width)
+ (ceiling (* factor doc-view-image-width)))
+ (doc-view-insert-image (plist-get (cdr (doc-view-current-image)) :file)
+ :width doc-view-image-width))
+ (set (make-local-variable 'doc-view-resolution)
+ (ceiling (* factor doc-view-resolution)))
+ (doc-view-reconvert-doc)))
(defun doc-view-shrink (factor)
"Shrink the document."
(interactive (list doc-view-shrink-factor))
(doc-view-enlarge (/ 1.0 factor)))
+(defun doc-view-fit-width-to-window ()
+ "Fit the image width to the window width."
+ (interactive)
+ (let ((win-width (- (nth 2 (window-inside-pixel-edges))
+ (nth 0 (window-inside-pixel-edges))))
+ (slice (doc-view-current-slice)))
+ (if (not slice)
+ (let ((img-width (car (image-display-size
+ (image-get-display-property) t))))
+ (doc-view-enlarge (/ (float win-width) (float img-width))))
+
+ ;; If slice is set
+ (let* ((slice-width (nth 2 slice))
+ (scale-factor (/ (float win-width) (float slice-width)))
+ (new-slice (mapcar (lambda (x) (ceiling (* scale-factor x))) slice)))
+
+ (doc-view-enlarge scale-factor)
+ (setf (doc-view-current-slice) new-slice)
+ (doc-view-goto-page (doc-view-current-page))))))
+
+(defun doc-view-fit-height-to-window ()
+ "Fit the image height to the window height."
+ (interactive)
+ (let ((win-height (- (nth 3 (window-inside-pixel-edges))
+ (nth 1 (window-inside-pixel-edges))))
+ (slice (doc-view-current-slice)))
+ (if (not slice)
+ (let ((img-height (cdr (image-display-size
+ (image-get-display-property) t))))
+ ;; When users call 'doc-view-fit-height-to-window',
+ ;; they might want to go to next page by typing SPC
+ ;; ONLY once. So I used '(- win-height 1)' instead of
+ ;; 'win-height'
+ (doc-view-enlarge (/ (float (- win-height 1)) (float img-height))))
+
+ ;; If slice is set
+ (let* ((slice-height (nth 3 slice))
+ (scale-factor (/ (float (- win-height 1)) (float slice-height)))
+ (new-slice (mapcar (lambda (x) (ceiling (* scale-factor x))) slice)))
+
+ (doc-view-enlarge scale-factor)
+ (setf (doc-view-current-slice) new-slice)
+ (doc-view-goto-page (doc-view-current-page))))))
+
+(defun doc-view-fit-page-to-window ()
+ "Fit the image to the window.
+More specifically, this function enlarges image by:
+
+min {(window-width / image-width), (window-height / image-height)} times."
+ (interactive)
+ (let ((win-width (- (nth 2 (window-inside-pixel-edges))
+ (nth 0 (window-inside-pixel-edges))))
+ (win-height (- (nth 3 (window-inside-pixel-edges))
+ (nth 1 (window-inside-pixel-edges))))
+ (slice (doc-view-current-slice)))
+ (if (not slice)
+ (let ((img-width (car (image-display-size
+ (image-get-display-property) t)))
+ (img-height (cdr (image-display-size
+ (image-get-display-property) t))))
+ (doc-view-enlarge (min (/ (float win-width) (float img-width))
+ (/ (float (- win-height 1)) (float img-height)))))
+ ;; If slice is set
+ (let* ((slice-width (nth 2 slice))
+ (slice-height (nth 3 slice))
+ (scale-factor (min (/ (float win-width) (float slice-width))
+ (/ (float (- win-height 1)) (float slice-height))))
+ (new-slice (mapcar (lambda (x) (ceiling (* scale-factor x))) slice)))
+ (doc-view-enlarge scale-factor)
+ (setf (doc-view-current-slice) new-slice)
+ (doc-view-goto-page (doc-view-current-page))))))
+
(defun doc-view-reconvert-doc ()
"Reconvert the current document.
Should be invoked when the cached images aren't up-to-date."
@@ -686,12 +788,19 @@ Should be invoked when the cached images aren't up-to-date."
(if (and doc-view-dvipdf-program
(executable-find doc-view-dvipdf-program))
(doc-view-start-process "dvi->pdf" doc-view-dvipdf-program
- (list dvi pdf)
- callback)
+ (list dvi pdf)
+ callback)
(doc-view-start-process "dvi->pdf" doc-view-dvipdfm-program
(list "-o" pdf dvi)
callback)))
+(defun doc-view-odf->pdf (odf callback)
+ "Convert ODF to PDF asynchronously and call CALLBACK when finished.
+The converted PDF is put into the current cache directory, and it
+is named like ODF with the extension turned to pdf."
+ (doc-view-start-process "odf->pdf" doc-view-unoconv-program
+ (list "-f" "pdf" "-o" (doc-view-current-cache-dir) odf)
+ callback))
(defun doc-view-pdf/ps->png (pdf-ps png)
"Convert PDF-PS to PNG asynchronously."
@@ -701,7 +810,7 @@ Should be invoked when the cached images aren't up-to-date."
(list (format "-r%d" (round doc-view-resolution))
(concat "-sOutputFile=" png)
pdf-ps))
- (lexical-let ((resolution doc-view-resolution))
+ (let ((resolution doc-view-resolution))
(lambda ()
;; Only create the resolution file when it's all done, so it also
;; serves as a witness that the conversion is complete.
@@ -746,7 +855,7 @@ Start by converting PAGES, and then the rest."
;; (almost) consecutive, but since in 99% of the cases, there'll be only
;; a single page anyway, and of the remaining 1%, few cases will have
;; consecutive pages, it's not worth the trouble.
- (lexical-let ((pdf pdf) (png png) (rest (cdr pages)))
+ (let ((rest (cdr pages)))
(doc-view-pdf->png-1
pdf (format png (car pages)) (car pages)
(lambda ()
@@ -759,8 +868,8 @@ Start by converting PAGES, and then the rest."
;; not sufficient.
(dolist (win (get-buffer-window-list (current-buffer) nil 'visible))
(with-selected-window win
- (when (stringp (get-char-property (point-min) 'display))
- (doc-view-goto-page (doc-view-current-page)))))
+ (when (stringp (get-char-property (point-min) 'display))
+ (doc-view-goto-page (doc-view-current-page)))))
;; Convert the rest of the pages.
(doc-view-pdf/ps->png pdf png)))))))
@@ -782,10 +891,8 @@ Start by converting PAGES, and then the rest."
(ps
;; Doc is a PS, so convert it to PDF (which will be converted to
;; TXT thereafter).
- (lexical-let ((pdf (expand-file-name "doc.pdf"
- (doc-view-current-cache-dir)))
- (txt txt)
- (callback callback))
+ (let ((pdf (expand-file-name "doc.pdf"
+ (doc-view-current-cache-dir))))
(doc-view-ps->pdf doc-view-buffer-file-name pdf
(lambda () (doc-view-pdf->txt pdf txt callback)))))
(dvi
@@ -794,6 +901,12 @@ Start by converting PAGES, and then the rest."
(doc-view-pdf->txt (expand-file-name "doc.pdf"
(doc-view-current-cache-dir))
txt callback))
+ (odf
+ ;; Doc is some ODF (or MS Office) doc. This means that a doc.pdf
+ ;; already exists in its cache subdirectory.
+ (doc-view-pdf->txt (expand-file-name "doc.pdf"
+ (doc-view-current-cache-dir))
+ txt callback))
(t (error "DocView doesn't know what to do"))))
(defun doc-view-ps->pdf (ps pdf callback)
@@ -833,11 +946,27 @@ Those files are saved in the directory given by the function
(dvi
;; DVI files have to be converted to PDF before Ghostscript can process
;; it.
+ (let ((pdf (expand-file-name "doc.pdf" doc-view-current-cache-dir)))
+ (doc-view-dvi->pdf doc-view-buffer-file-name pdf
+ (lambda () (doc-view-pdf/ps->png pdf png-file)))))
+ (odf
+ ;; ODF files have to be converted to PDF before Ghostscript can
+ ;; process it.
(lexical-let
((pdf (expand-file-name "doc.pdf" doc-view-current-cache-dir))
+ (opdf (expand-file-name (concat (file-name-sans-extension
+ (file-name-nondirectory doc-view-buffer-file-name))
+ ".pdf")
+ doc-view-current-cache-dir))
(png-file png-file))
- (doc-view-dvi->pdf doc-view-buffer-file-name pdf
- (lambda () (doc-view-pdf/ps->png pdf png-file)))))
+ ;; The unoconv tool only supports a output directory, but no
+ ;; file name. It's named like the input file with the
+ ;; extension replaced by pdf.
+ (doc-view-odf->pdf doc-view-buffer-file-name
+ (lambda ()
+ ;; Rename to doc.pdf
+ (rename-file opdf pdf)
+ (doc-view-pdf/ps->png pdf png-file)))))
(pdf
(let ((pages (doc-view-active-pages)))
;; Convert PDF to PNG images starting with the active pages.
@@ -906,7 +1035,11 @@ ARGS is a list of image descriptors."
(setq doc-view-pending-cache-flush nil))
(let ((ol (doc-view-current-overlay))
(image (if (and file (file-readable-p file))
- (apply 'create-image file 'png nil args)))
+ (if (not (fboundp 'imagemagick-types))
+ (apply 'create-image file 'png nil args)
+ (unless (member :width args)
+ (setq args (append args (list :width doc-view-image-width))))
+ (apply 'create-image file 'imagemagick nil args))))
(slice (doc-view-current-slice)))
(setf (doc-view-current-image) image)
(move-overlay ol (point-min) (point-max))
@@ -964,8 +1097,8 @@ have the page we want to view."
(and (not (member pagefile prev-pages))
(member pagefile doc-view-current-files)))
(with-selected-window win
- (assert (eq (current-buffer) buffer))
- (doc-view-goto-page page))))))))
+ (assert (eq (current-buffer) buffer))
+ (doc-view-goto-page page))))))))
(defun doc-view-buffer-message ()
;; Only show this message initially, not when refreshing the buffer (in which
@@ -999,12 +1132,16 @@ For now these keys are useful:
(message "DocView: please wait till conversion finished.")
(let ((txt (expand-file-name "doc.txt" (doc-view-current-cache-dir))))
(if (file-readable-p txt)
- (find-file txt)
+ (let ((name (concat "Text contents of "
+ (file-name-nondirectory buffer-file-name)))
+ (dir (file-name-directory buffer-file-name)))
+ (with-current-buffer (find-file txt)
+ (rename-buffer name)
+ (setq default-directory dir)))
(doc-view-doc->txt txt 'doc-view-open-text)))))
;;;;; Toggle between editing and viewing
-
(defun doc-view-toggle-display ()
"Toggle between editing a document as text or viewing it."
(interactive)
@@ -1015,11 +1152,9 @@ For now these keys are useful:
(setq buffer-read-only nil)
(remove-overlays (point-min) (point-max) 'doc-view t)
(set (make-local-variable 'image-mode-winprops-alist) t)
- ;; Switch to the previously used major mode or fall back to fundamental
- ;; mode.
- (if doc-view-previous-major-mode
- (funcall doc-view-previous-major-mode)
- (fundamental-mode))
+ ;; Switch to the previously used major mode or fall back to
+ ;; normal mode.
+ (doc-view-fallback-mode)
(doc-view-minor-mode 1))
;; Switch to doc-view-mode
(when (and (buffer-modified-p)
@@ -1179,11 +1314,11 @@ If BACKWARD is non-nil, jump to the previous match."
(concat "No PNG support is available, or some conversion utility for "
(file-name-extension doc-view-buffer-file-name)
" files is missing."))
- (if (and (executable-find doc-view-pdftotext-program)
- (y-or-n-p
- "Unable to render file. View extracted text instead? "))
- (doc-view-open-text)
- (doc-view-toggle-display))))
+ (when (and (executable-find doc-view-pdftotext-program)
+ (y-or-n-p
+ "Unable to render file. View extracted text instead? "))
+ (doc-view-open-text))
+ (doc-view-toggle-display)))
(defvar bookmark-make-record-function)
@@ -1206,6 +1341,41 @@ If BACKWARD is non-nil, jump to the previous match."
(dolist (x l1) (if (memq x l2) (push x l)))
l))
+(defun doc-view-set-doc-type ()
+ "Figure out the current document type (`doc-view-doc-type')."
+ (let ((name-types
+ (when buffer-file-name
+ (cdr (assoc (file-name-extension buffer-file-name)
+ '(
+ ;; DVI
+ ("dvi" dvi)
+ ;; PDF
+ ("pdf" pdf) ("epdf" pdf)
+ ;; PostScript
+ ("ps" ps) ("eps" ps)
+ ;; OpenDocument formats
+ ("odt" odf) ("ods" odf) ("odp" odf) ("odg" odf)
+ ("odc" odf) ("odi" odf) ("odm" odf) ("ott" odf)
+ ("ots" odf) ("otp" odf) ("otg" odf)
+ ;; Microsoft Office formats (also handled
+ ;; by the odf conversion chain)
+ ("doc" odf) ("docx" odf) ("xls" odf) ("xlsx" odf)
+ ("ppt" odf) ("pptx" odf))))))
+ (content-types
+ (save-excursion
+ (goto-char (point-min))
+ (cond
+ ((looking-at "%!") '(ps))
+ ((looking-at "%PDF") '(pdf))
+ ((looking-at "\367\002") '(dvi))))))
+ (set (make-local-variable 'doc-view-doc-type)
+ (car (or (doc-view-intersection name-types content-types)
+ (when (and name-types content-types)
+ (error "Conflicting types: name says %s but content says %s"
+ name-types content-types))
+ name-types content-types
+ (error "Cannot determine the document type"))))))
+
;;;###autoload
(defun doc-view-mode ()
"Major mode in DocView buffers.
@@ -1222,39 +1392,19 @@ toggle between displaying the document or editing it as text.
;; The doc is empty or doesn't exist at all, so fallback to
;; another mode. We used to also check file-exists-p, but this
;; returns nil for tar members.
- (let ((auto-mode-alist (remq (rassq 'doc-view-mode auto-mode-alist)
- auto-mode-alist)))
- (normal-mode))
+ (doc-view-fallback-mode)
(let* ((prev-major-mode (if (eq major-mode 'doc-view-mode)
doc-view-previous-major-mode
- major-mode)))
+ (when (not (memq major-mode
+ '(doc-view-mode fundamental-mode)))
+ major-mode))))
(kill-all-local-variables)
(set (make-local-variable 'doc-view-previous-major-mode) prev-major-mode))
;; Figure out the document type.
- (let ((name-types
- (when buffer-file-name
- (cdr (assoc (file-name-extension buffer-file-name)
- '(("dvi" dvi)
- ("pdf" pdf)
- ("epdf" pdf)
- ("ps" ps)
- ("eps" ps))))))
- (content-types
- (save-excursion
- (goto-char (point-min))
- (cond
- ((looking-at "%!") '(ps))
- ((looking-at "%PDF") '(pdf))
- ((looking-at "\367\002") '(dvi))))))
- (set (make-local-variable 'doc-view-doc-type)
- (car (or (doc-view-intersection name-types content-types)
- (when (and name-types content-types)
- (error "Conflicting types: name says %s but content says %s"
- name-types content-types))
- name-types content-types
- (error "Cannot determine the document type")))))
+ (unless doc-view-doc-type
+ (doc-view-set-doc-type))
(doc-view-make-safe-dir doc-view-cache-directory)
;; Handle compressed files, remote files, files inside archives
@@ -1322,6 +1472,28 @@ toggle between displaying the document or editing it as text.
(set (make-local-variable 'view-read-only) nil)
(run-mode-hooks 'doc-view-mode-hook)))
+(defun doc-view-fallback-mode ()
+ "Fallback to the previous or next best major mode."
+ (if doc-view-previous-major-mode
+ (funcall doc-view-previous-major-mode)
+ (let ((auto-mode-alist (rassq-delete-all
+ 'doc-view-mode-maybe
+ (rassq-delete-all 'doc-view-mode
+ (copy-alist auto-mode-alist)))))
+ (normal-mode))))
+
+;;;###autoload
+(defun doc-view-mode-maybe ()
+ "Switch to `doc-view-mode' if possible.
+If the required external tools are not available, then fallback
+to the next best mode."
+ (condition-case nil
+ (doc-view-set-doc-type)
+ (error (doc-view-fallback-mode)))
+ (if (doc-view-mode-p doc-view-doc-type)
+ (doc-view-mode)
+ (doc-view-fallback-mode)))
+
;;;###autoload
(define-minor-mode doc-view-minor-mode
"Toggle Doc view minor mode.
@@ -1349,8 +1521,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))
@@ -1369,16 +1541,15 @@ See the command `doc-view-mode' for more information on this mode."
(when (not (eq major-mode 'doc-view-mode))
(doc-view-toggle-display))
(with-selected-window
- (or (get-buffer-window (current-buffer) 0)
- (selected-window))
- (doc-view-goto-page page)))))
+ (or (get-buffer-window (current-buffer) 0)
+ (selected-window))
+ (doc-view-goto-page page)))))
(provide 'doc-view)
;; Local Variables:
-;; mode: outline-minor
+;; eval: (outline-minor-mode)
;; End:
-;; arch-tag: 5d6e5c5e-095f-489e-b4e4-1ca90a7d79be
;;; doc-view.el ends here
diff --git a/lisp/dos-fns.el b/lisp/dos-fns.el
index b917acd588c..629360b1c18 100644
--- a/lisp/dos-fns.el
+++ b/lisp/dos-fns.el
@@ -1,10 +1,11 @@
;;; dos-fns.el --- MS-Dos specific functions
-;; Copyright (C) 1991, 1993, 1995, 1996, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1991, 1993, 1995-1996, 2001-2011
+;; Free Software Foundation, Inc.
;; 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)
@@ -158,7 +159,7 @@ shell requires it (see `w32-shell-dos-semantics')."
(string (copy-sequence (file-name-nondirectory filename)))
(strlen (length string))
(lastchar (aref string (1- strlen)))
- i firstdot)
+ firstdot)
(setq firstdot (string-match "\\." string))
(cond
(firstdot
@@ -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,7 +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
;;; dos-fns.el ends here
diff --git a/lisp/dos-vars.el b/lisp/dos-vars.el
index 2574295816c..7de2ecb75a6 100644
--- a/lisp/dos-vars.el
+++ b/lisp/dos-vars.el
@@ -1,10 +1,10 @@
;;; dos-vars.el --- MS-Dos specific user options
-;; Copyright (C) 1998, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -43,5 +43,4 @@ in `standard-display-table' as appropriate for your codepage, if
:type '(hook)
:version "20.3.3")
-;; arch-tag: dce8a0d9-ab29-413f-84ed-8b89d6190546
;;; dos-vars.el ends here
diff --git a/lisp/dos-w32.el b/lisp/dos-w32.el
index 212024ed97d..36832df3c67 100644
--- a/lisp/dos-w32.el
+++ b/lisp/dos-w32.el
@@ -1,10 +1,10 @@
;; dos-w32.el --- Functions shared among MS-DOS and W32 (NT/95) platforms
-;; Copyright (C) 1996, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: Geoff Voelker <voelker@cs.washington.edu>
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -290,7 +290,7 @@ filesystem mounted on drive Z:, FILESYSTEM could be \"Z:\"."
(defun direct-print-region-helper (printer
start end
lpr-prog
- delete-text buf display
+ _delete-text _buf _display
rest)
(let* (;; Ignore case when matching known external program names.
(case-fold-search t)
@@ -381,9 +381,9 @@ filesystem mounted on drive Z:, FILESYSTEM could be \"Z:\"."
(declare-function default-printer-name "w32fns.c")
(defun direct-print-region-function (start end
- &optional lpr-prog
- delete-text buf display
- &rest rest)
+ &optional lpr-prog
+ delete-text buf display
+ &rest rest)
"DOS/Windows-specific function to print the region on a printer.
Writes the region to the device or file which is a value of
`printer-name' \(which see\), unless the value of `lpr-command'
@@ -399,7 +399,7 @@ indicates a specific program should be invoked."
;; paper if the file ends with a form-feed already.
(write-region-annotate-functions
(cons
- (lambda (start end)
+ (lambda (_start end)
(if (not (char-equal (char-before end) ?\C-l))
`((,end . "\f"))))
write-region-annotate-functions))
@@ -457,5 +457,4 @@ indicates a specific program should be invoked."
(provide 'dos-w32)
-;; arch-tag: dcfefdd2-362f-4fbc-9141-9634f5f4d6a7
;;; dos-w32.el ends here
diff --git a/lisp/double.el b/lisp/double.el
index 19702c9bef2..4aa8da72af7 100644
--- a/lisp/double.el
+++ b/lisp/double.el
@@ -1,7 +1,6 @@
;;; double.el --- support for keyboard remapping with double clicking
-;; Copyright (C) 1994, 1997, 1998, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 1997-1998, 2001-2011 Free Software Foundation, Inc.
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: i18n
@@ -169,5 +168,4 @@ when pressed twice. See variable `double-map' for details."
(provide 'double)
-;; arch-tag: 2e170036-44cb-4493-bc32-ada0a4395221
;;; double.el ends here
diff --git a/lisp/font-setting.el b/lisp/dynamic-setting.el
index 25c02f86c64..81531c4a21f 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2011 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,29 @@ 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 9f9129919da..a906cf8516a 100644
--- a/lisp/ebuff-menu.el
+++ b/lisp/ebuff-menu.el
@@ -1,7 +1,6 @@
;;; ebuff-menu.el --- electric-buffer-list mode
-;; Copyright (C) 1985, 1986, 1994, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1986, 1994, 2001-2011 Free Software Foundation, Inc.
;; Author: Richard Mlynarik <mly@ai.mit.edu>
;; Maintainer: FSF
@@ -144,7 +143,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)
@@ -283,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/echistory.el b/lisp/echistory.el
index 8d69d64228c..d5ee3003d68 100644
--- a/lisp/echistory.el
+++ b/lisp/echistory.el
@@ -1,7 +1,6 @@
;;; echistory.el --- Electric Command History Mode
-;; Copyright (C) 1985, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 2001-2011 Free Software Foundation, Inc.
;; Author: K. Shane Hartman
;; Maintainer: FSF
@@ -28,6 +27,9 @@
(require 'electric) ; command loop
(require 'chistory) ; history lister
+;; Dynamically bound in electric-command-history
+(defvar electric-history-in-progress)
+
;;;###autoload
(defun Electric-command-history-redo-expression (&optional noconfirm)
"Edit current history line in minibuffer and execute result.
@@ -86,6 +88,8 @@ With prefix arg NOCONFIRM, execute current line as-is without editing."
(defvar electric-command-history-hook nil
"If non-nil, its value is called by `electric-command-history'.")
+(defvar Helper-return-blurb) ; from helper.el
+
(defun electric-command-history ()
"\\<electric-history-map>Major mode for examining and redoing commands from `command-history'.
This pops up a window with the Command History listing.
@@ -150,5 +154,4 @@ The Command History listing is recomputed each time this mode is invoked."
(provide 'echistory)
-;; arch-tag: 1e5018fe-190f-44a7-9109-a895dcac4c50
;;; echistory.el ends here
diff --git a/lisp/edmacro.el b/lisp/edmacro.el
index 499ad8966ea..f6c39062d1c 100644
--- a/lisp/edmacro.el
+++ b/lisp/edmacro.el
@@ -1,7 +1,6 @@
;;; edmacro.el --- keyboard macro editor
-;; Copyright (C) 1993, 1994, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1994, 2001-2011 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Maintainer: Dave Gillespie <daveg@synaptics.com>
@@ -62,11 +61,6 @@
;; With a prefix argument, `edit-kbd-macro' will format the
;; macro in a more concise way that omits the comments.
-;; This package requires GNU Emacs 19 or later, and daveg's CL
-;; package 2.02 or later. (CL 2.02 comes standard starting with
-;; Emacs 19.18.) This package does not work with Emacs 18 or
-;; Lucid Emacs.
-
;;; Code:
(eval-when-compile
@@ -76,16 +70,17 @@
;;; The user-level commands for editing macros.
-;;;###autoload
-(defvar edmacro-eight-bits nil
- "*Non-nil if `edit-kbd-macro' should leave 8-bit characters intact.
-Default nil means to write characters above \\177 in octal notation.")
+(defcustom edmacro-eight-bits nil
+ "Non-nil if `edit-kbd-macro' should leave 8-bit characters intact.
+Default nil means to write characters above \\177 in octal notation."
+ :type 'boolean
+ :group 'kmacro)
-(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)
@@ -230,7 +225,7 @@ or nil, use a compact 80-column format."
"This command is valid only in buffers created by `edit-kbd-macro'"))
(run-hooks 'edmacro-finish-hook)
(let ((cmd nil) (keys nil) (no-keys nil)
- (mac-counter nil) (mac-format nil) (kmacro nil)
+ (mac-counter nil) (mac-format nil)
(top (point-min)))
(goto-char top)
(let ((case-fold-search nil))
@@ -245,7 +240,7 @@ or nil, use a compact 80-column format."
(setq cmd (and (not (equal str "none"))
(intern str)))
(and (fboundp cmd) (not (arrayp (symbol-function cmd)))
- (not (setq kmacro (get cmd 'kmacro)))
+ (not (get cmd 'kmacro))
(not (y-or-n-p
(format "Command %s is already defined; %s"
cmd "proceed? ")))
@@ -785,5 +780,4 @@ This function assumes that the events can be stored in a string."
(provide 'edmacro)
-;; arch-tag: 726807b4-3ae6-49de-b0ae-b9590973e0d7
;;; edmacro.el ends here
diff --git a/lisp/ehelp.el b/lisp/ehelp.el
index 4091fb3f5ba..b2bcf1f85cb 100644
--- a/lisp/ehelp.el
+++ b/lisp/ehelp.el
@@ -1,7 +1,6 @@
-;;; ehelp.el --- bindings for electric-help mode
+;;; ehelp.el --- bindings for electric-help mode -*- lexical-binding: t -*-
-;; Copyright (C) 1986, 1995, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1986, 1995, 2000-2011 Free Software Foundation, Inc.
;; Author: Richard Mlynarik
;; (according to ack.texi and authors.el)
@@ -94,10 +93,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 +134,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 +173,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)
@@ -340,14 +347,14 @@ will select it.)"
;; This is to be bound to M-x in ehelp mode. Retains ehelp buffer and then
;; continues with execute-extended-command.
-(defun electric-help-execute-extended (prefixarg)
+(defun electric-help-execute-extended (_prefixarg)
(interactive "p")
(setq electric-help-form-to-execute '(execute-extended-command nil))
(electric-help-retain))
;; This is to be buond to C-x in ehelp mode. Retains ehelp buffer and then
;; continues with ctrl-x prefix.
-(defun electric-help-ctrl-x-prefix (prefixarg)
+(defun electric-help-ctrl-x-prefix (_prefixarg)
(interactive "p")
(setq electric-help-form-to-execute '(progn (message nil) (setq unread-command-char ?\C-x)))
(electric-help-retain))
@@ -418,5 +425,4 @@ will select it.)"
(provide 'ehelp)
-;; arch-tag: e0e3037f-42c0-433e-ba18-322c5d951f46
;;; ehelp.el ends here
diff --git a/lisp/electric.el b/lisp/electric.el
index cac89b35b2e..17c33c7d5cd 100644
--- a/lisp/electric.el
+++ b/lisp/electric.el
@@ -1,7 +1,6 @@
;;; electric.el --- window maker and Command loop for `electric' modes
-;; Copyright (C) 1985, 1986, 1995, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1986, 1995, 2001-2011 Free Software Foundation, Inc.
;; Author: K. Shane Hartman
;; Maintainer: FSF
@@ -24,10 +23,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
@@ -51,19 +63,18 @@
;; conditions for any error that occurred or nil if none.
(defun Electric-command-loop (return-tag
- &optional prompt inhibit-quit
+ &optional prompt inhibit-quitting
loop-function loop-state)
(let (cmd
(err nil)
+ (inhibit-quit inhibit-quitting)
(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,7 +170,219 @@
(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 (< (1- pos) (line-beginning-position))
+ (let ((before (copy-marker (1- pos) t)))
+ (save-excursion
+ (unless (memq indent-line-function
+ '(indent-relative indent-to-left-margin
+ indent-relative-maybe))
+ ;; Don't reindent the previous line if the indentation function
+ ;; is not a real one.
+ (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))))
+ (unless (memq indent-line-function '(indent-to-left-margin))
+ (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
;;; electric.el ends here
diff --git a/lisp/elide-head.el b/lisp/elide-head.el
index 085e71ad0b6..5d640f629e8 100644
--- a/lisp/elide-head.el
+++ b/lisp/elide-head.el
@@ -1,7 +1,6 @@
;;; elide-head.el --- hide headers in files
-;; Copyright (C) 1999, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2001-2011 Free Software Foundation, Inc.
;; Author: Dave Love <fx@gnu.org>
;; Keywords: outlines tools
@@ -119,5 +118,4 @@ This is suitable as an entry on `find-file-hook' or appropriate mode hooks."
(provide 'elide-head)
-;; arch-tag: a00e6b5b-6aeb-45b1-b734-63e23df80928
;;; elide-head.el ends here
diff --git a/lisp/emacs-lisp/.gitignore b/lisp/emacs-lisp/.gitignore
index 88830a1c6e8..133e79e817a 100644
--- a/lisp/emacs-lisp/.gitignore
+++ b/lisp/emacs-lisp/.gitignore
@@ -1,3 +1,2 @@
!*-loaddefs.el
-# arch-tag: d0a60bce-b886-4817-b4c3-9a81ba0308bc
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el
index b37e1c289c1..5934975e36a 100644
--- a/lisp/emacs-lisp/advice.el
+++ b/lisp/emacs-lisp/advice.el
@@ -1,12 +1,12 @@
;;; advice.el --- an overloading mechanism for Emacs Lisp functions
-;; Copyright (C) 1993, 1994, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1994, 2000-2011 Free Software Foundation, Inc.
;; Author: Hans Chalupsky <hans@cs.buffalo.edu>
;; Maintainer: FSF
;; Created: 12 Dec 1992
;; Keywords: extensions, lisp, tools
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -503,36 +503,6 @@
;; exact structure of the original argument list as long as the new argument
;; list takes a compatible number/magnitude of actual arguments.
-;; @@@ Definition of subr argument lists:
-;; ======================================
-;; When advice constructs the advised definition of a function it has to
-;; know the argument list of the original function. For functions and macros
-;; the argument list can be determined from the actual definition, however,
-;; for subrs there is no such direct access available. In Lemacs and for some
-;; subrs in Emacs-19 the argument list of a subr can be determined from
-;; its documentation string, in a v18 Emacs even that is not possible. If
-;; advice cannot at all determine the argument list of a subr it uses
-;; `(&rest ad-subr-args)' which will always work but is inefficient because
-;; it conses up arguments. The macro `ad-define-subr-args' can be used by
-;; the advice programmer to explicitly tell advice about the argument list
-;; of a certain subr, for example,
-;;
-;; (ad-define-subr-args 'fset '(sym newdef))
-;;
-;; is used by advice itself to tell a v18 Emacs about the arguments of `fset'.
-;; The following can be used to undo such a definition:
-;;
-;; (ad-undefine-subr-args 'fset)
-;;
-;; The argument list definition is stored on the property list of the subr
-;; name symbol. When an argument list could be determined from the
-;; documentation string it will be cached under that property. The general
-;; mechanism for looking up the argument list of a subr is the following:
-;; 1) look for a definition stored on the property list
-;; 2) if that failed try to infer it from the documentation string and
-;; if successful cache it on the property list
-;; 3) otherwise use `(&rest ad-subr-args)'
-
;; @@ Activation and deactivation:
;; ===============================
;; The definition of an advised function does not change until all its advice
@@ -1654,41 +1624,6 @@
;; (fii 3 2)
;; 5
;;
-;; @@ Specifying argument lists of subrs:
-;; ======================================
-;; The argument lists of subrs cannot be determined directly from Lisp.
-;; This means that Advice has to use `(&rest ad-subr-args)' as the
-;; argument list of the advised subr which is not very efficient. In Lemacs
-;; subr argument lists can be determined from their documentation string, in
-;; Emacs-19 this is the case for some but not all subrs. To accommodate
-;; for the cases where the argument lists cannot be determined (e.g., in a
-;; v18 Emacs) Advice comes with a specification mechanism that allows the
-;; advice programmer to tell advice what the argument list of a certain subr
-;; really is.
-;;
-;; In a v18 Emacs the following will return the &rest idiom:
-;;
-;; (ad-arglist (symbol-function 'car))
-;; (&rest ad-subr-args)
-;;
-;; To tell advice what the argument list of `car' really is we
-;; can do the following:
-;;
-;; (ad-define-subr-args 'car '(list))
-;; ((list))
-;;
-;; Now `ad-arglist' will return the proper argument list (this method is
-;; actually used by advice itself for the advised definition of `fset'):
-;;
-;; (ad-arglist (symbol-function 'car))
-;; (list)
-;;
-;; The defined argument list will be stored on the property list of the
-;; subr name symbol. When advice looks for a subr argument list it first
-;; checks for a definition on the property list, if that fails it tries
-;; to infer it from the documentation string and caches it on the property
-;; list if it was successful, otherwise `(&rest ad-subr-args)' will be used.
-;;
;; @@ Advising interactive subrs:
;; ==============================
;; For the most part there is no difference between advising functions and
@@ -2535,59 +2470,12 @@ See Info node `(elisp)Computed Advice' for detailed documentation."
"Return the argument list of DEFINITION.
If DEFINITION could be from a subr then its NAME should be
supplied to make subr arglist lookup more efficient."
- (cond ((ad-compiled-p definition)
- (aref (ad-compiled-code definition) 0))
- ((consp definition)
- (car (cdr (ad-lambda-expression definition))))
- ((ad-subr-p definition)
- (if name
- (ad-subr-arglist name)
- ;; otherwise get it from its printed representation:
- (setq name (format "%s" definition))
- (string-match "^#<subr \\([^>]+\\)>$" name)
- (ad-subr-arglist (intern (match-string 1 name)))))))
-
-;; Store subr-args as `((arg1 arg2 ...))' so I can distinguish
-;; a defined empty arglist `(nil)' from an undefined arglist:
-(defmacro ad-define-subr-args (subr arglist)
- `(put ,subr 'ad-subr-arglist (list ,arglist)))
-(defmacro ad-undefine-subr-args (subr)
- `(put ,subr 'ad-subr-arglist nil))
-(defmacro ad-subr-args-defined-p (subr)
- `(get ,subr 'ad-subr-arglist))
-(defmacro ad-get-subr-args (subr)
- `(car (get ,subr 'ad-subr-arglist)))
-
-(defun ad-subr-arglist (subr-name)
- "Retrieve arglist of the subr with SUBR-NAME.
-Either use the one stored under the `ad-subr-arglist' property,
-or try to retrieve it from the docstring and cache it under
-that property, or otherwise use `(&rest ad-subr-args)'."
- (if (ad-subr-args-defined-p subr-name)
- (ad-get-subr-args subr-name)
- ;; says jwz: Should use this for Lemacs 19.8 and above:
- ;;((fboundp 'subr-min-args)
- ;; ...)
- ;; says hans: I guess what Jamie means is that I should use the values
- ;; of `subr-min-args' and `subr-max-args' to construct the subr arglist
- ;; without having to look it up via parsing the docstring, e.g.,
- ;; values 1 and 2 would suggest `(arg1 &optional arg2)' as an
- ;; argument list. However, that won't work because there is no
- ;; way to distinguish a subr with args `(a &optional b &rest c)' from
- ;; one with args `(a &rest c)' using that mechanism. Also, the argument
- ;; names from the docstring are more meaningful. Hence, I'll stick with
- ;; the old way of doing things.
- (let ((doc (or (ad-real-documentation subr-name t) "")))
- (if (not (string-match "\n\n\\((.+)\\)\\'" doc))
- ;; Signalling an error leads to bugs during bootstrapping because
- ;; the DOC file is not yet built (which is an error, BTW).
- ;; (error "The usage info is missing from the subr %s" subr-name)
- '(&rest ad-subr-args)
- (ad-define-subr-args
- subr-name
- (cdr (car (read-from-string
- (downcase (match-string 1 doc))))))
- (ad-get-subr-args subr-name)))))
+ (require 'help-fns)
+ (help-function-arglist
+ (if (or (ad-macro-p definition) (ad-advice-p definition))
+ (cdr definition)
+ definition)
+ 'preserve-names))
(defun ad-docstring (definition)
"Return the unexpanded docstring of DEFINITION."
@@ -2635,17 +2523,16 @@ definition (see the code for `documentation')."
(defun ad-definition-type (definition)
"Return symbol that describes the type of DEFINITION."
- (if (ad-macro-p definition)
- 'macro
- (if (ad-subr-p definition)
- (if (ad-special-form-p definition)
- 'special-form
- 'subr)
- (if (or (ad-lambda-p definition)
- (ad-compiled-p definition))
- 'function
- (if (ad-advice-p definition)
- 'advice)))))
+ (cond
+ ((ad-macro-p definition) 'macro)
+ ((ad-subr-p definition)
+ (if (ad-special-form-p definition)
+ 'special-form
+ 'subr))
+ ((or (ad-lambda-p definition)
+ (ad-compiled-p definition))
+ 'function)
+ ((ad-advice-p definition) 'advice)))
(defun ad-has-proper-definition (function)
"True if FUNCTION is a symbol with a proper definition.
@@ -3007,9 +2894,7 @@ in any of these classes."
(setq usage (if (null usage) t (setq origdoc (cdr usage)) (car usage)))
(if origdoc (setq paragraphs (list origdoc)))
(unless (eq style 'plain)
- (push (propertize (concat "This " origtype " is advised.")
- 'face 'font-lock-warning-face)
- paragraphs))
+ (push (concat "This " origtype " is advised.") paragraphs))
(ad-dolist (class ad-advice-classes)
(ad-dolist (advice (ad-get-enabled-advices function class))
(setq advice-docstring
@@ -3929,10 +3814,6 @@ undone on exit of this macro."
;; Use the advice mechanism to advise `documentation' to make it
;; generate proper documentation strings for advised definitions:
-;; This makes sure we get the right arglist for `documentation'
-;; during bootstrapping.
-(ad-define-subr-args 'documentation '(function &optional raw))
-
;; @@ Starting, stopping and recovering from the advice package magic:
;; ===================================================================
@@ -3965,5 +3846,4 @@ Use only in REAL emergencies."
(provide 'advice)
-;; arch-tag: 29f8c9a1-8c88-471f-95d7-e28541c6b7c0
;;; advice.el ends here
diff --git a/lisp/emacs-lisp/assoc.el b/lisp/emacs-lisp/assoc.el
index e90c9df7f82..31be851f2dd 100644
--- a/lisp/emacs-lisp/assoc.el
+++ b/lisp/emacs-lisp/assoc.el
@@ -1,7 +1,6 @@
-;;; assoc.el --- insert/delete/sort functions on association lists
+;;; assoc.el --- insert/delete functions on association lists
-;; Copyright (C) 1996, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 2001-2011 Free Software Foundation, Inc.
;; Author: Barry A. Warsaw <bwarsaw@cen.com>
;; Keywords: extensions
@@ -36,7 +35,7 @@ head is one matching KEY. Returns the sorted list and doesn't affect
the order of any other key-value pair. Side effect sets alist to new
sorted list."
(set alist-symbol
- (sort (copy-alist (eval alist-symbol))
+ (sort (copy-alist (symbol-value alist-symbol))
(function (lambda (a b) (equal (car a) key))))))
@@ -76,7 +75,7 @@ of the alist (with value nil if VALUE is nil or not supplied)."
(lexical-let ((elem (aelement key value))
alist)
(asort alist-symbol key)
- (setq alist (eval alist-symbol))
+ (setq alist (symbol-value alist-symbol))
(cond ((null alist) (set alist-symbol elem))
((anot-head-p alist key) (set alist-symbol (nconc elem alist)))
(value (setcar alist (car elem)))
@@ -88,7 +87,7 @@ of the alist (with value nil if VALUE is nil or not supplied)."
Alist is referenced by ALIST-SYMBOL and the key-value pair to remove
is pair matching KEY. Returns the altered alist."
(asort alist-symbol key)
- (lexical-let ((alist (eval alist-symbol)))
+ (lexical-let ((alist (symbol-value alist-symbol)))
(cond ((null alist) nil)
((anot-head-p alist key) alist)
(t (set alist-symbol (cdr alist))))))
@@ -134,9 +133,8 @@ extra values are ignored. Returns the created alist."
(t
(amake alist-symbol keycdr valcdr)
(aput alist-symbol keycar valcar))))
- (eval alist-symbol))
+ (symbol-value alist-symbol))
(provide 'assoc)
-;; arch-tag: 3e58bd89-d912-4b74-a0dc-6ed9735922bc
;;; assoc.el ends here
diff --git a/lisp/emacs-lisp/authors.el b/lisp/emacs-lisp/authors.el
index 433d36c3ef7..163af883334 100644
--- a/lisp/emacs-lisp/authors.el
+++ b/lisp/emacs-lisp/authors.el
@@ -1,11 +1,11 @@
;;; authors.el --- utility for maintaining Emacs' AUTHORS file -*-coding: utf-8;-*-
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; 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 +220,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 +247,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 +266,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 +298,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 +355,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 +378,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 +409,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 +464,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 +475,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 +506,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 +559,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 +585,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 +633,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 +668,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 +685,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 +834,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 +1032,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 1f7837ba43a..f8f8d9b00f2 100644
--- a/lisp/emacs-lisp/autoload.el
+++ b/lisp/emacs-lisp/autoload.el
@@ -1,11 +1,10 @@
;; 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, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1991-1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Roland McGrath <roland@gnu.org>
;; Keywords: maint
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -35,11 +34,19 @@
(require 'help-fns) ;for help-add-fundoc-usage.
(eval-when-compile (require 'cl))
-(defvar generated-autoload-file "loaddefs.el"
- "*File \\[update-file-autoloads] puts autoloads into.
-A `.el' file can set this in its local variables section to make its
-autoloads go somewhere else. The autoload file is assumed to contain a
-trailer starting with a FormFeed character.")
+(defvar generated-autoload-file nil
+ "File into which to write autoload definitions.
+A Lisp file can set this in its local variables section to make
+its autoloads go somewhere else.
+
+If this is a relative file name, the directory is determined as
+follows:
+ - If a Lisp file defined `generated-autoload-file' as a
+ file-local variable, use its containing directory.
+ - Otherwise use the \"lisp\" subdirectory of `source-directory'.
+
+The autoload file is assumed to contain a trailer starting with a
+FormFeed character.")
;;;###autoload
(put 'generated-autoload-file 'safe-local-variable 'stringp)
@@ -109,29 +116,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-safe 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)
@@ -172,6 +198,15 @@ or macro definition or a defcustom)."
;; the doc-string in FORM.
;; Those properties are now set in lisp-mode.el.
+(defun autoload-find-generated-file ()
+ "Visit the autoload file for the current buffer, and return its buffer.
+If a buffer is visiting the desired autoload file, return it."
+ (let ((enable-local-variables :safe))
+ ;; We used to use `raw-text' to read this file, but this causes
+ ;; problems when the file contains non-ASCII characters.
+ (find-file-noselect
+ (autoload-ensure-default-file (autoload-generated-file)))))
+
(defun autoload-generated-file ()
(expand-file-name generated-autoload-file
;; File-local settings of generated-autoload-file should
@@ -259,14 +294,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 +363,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)))
@@ -338,7 +398,10 @@ If FILE is being visited in a buffer, the contents of the buffer
are used.
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)))
+ (let ((generated-autoload-file buffer-file-name))
+ (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
@@ -370,9 +433,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 +444,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 +458,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,10 +485,12 @@ 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)))
+ (message "Autoload cookie error in %s:%s %S"
+ file (count-lines (point-min) (point)) err)))
;; Copy the rest of the line to the output.
(princ (buffer-substring
@@ -439,7 +502,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,56 +514,68 @@ 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
(with-current-buffer (pop autoload-modified-buffers)
- (save-buffer))))
+ (let ((version-control 'never))
+ (save-buffer)))))
;;;###autoload
-(defun update-file-autoloads (file &optional save-after)
- "Update the autoloads for FILE in `generated-autoload-file'
-\(which FILE might bind in its local variables).
-If SAVE-AFTER is non-nil (which is always, when called interactively),
-save the buffer too.
+(defun update-file-autoloads (file &optional save-after outfile)
+ "Update the autoloads for FILE.
+If prefix arg SAVE-AFTER is non-nil, save the buffer too.
+
+If FILE binds `generated-autoload-file' as a file-local variable,
+autoloads are written into that file. Otherwise, the autoloads
+file is determined by OUTFILE. If called interactively, prompt
+for OUTFILE; if called from Lisp with OUTFILE nil, use the
+existing value of `generated-autoload-file'.
Return FILE if there was no autoload cookie in it, else nil."
- (interactive "fUpdate autoloads for file: \np")
- (let* ((autoload-modified-buffers nil)
+ (interactive (list (read-file-name "Update autoloads for file: ")
+ current-prefix-arg
+ (read-file-name "Write autoload definitions to file: ")))
+ (let* ((generated-autoload-file (or outfile generated-autoload-file))
+ (autoload-modified-buffers nil)
(no-autoloads (autoload-generate-file-autoloads file)))
(if autoload-modified-buffers
(if save-after (autoload-save-buffers))
@@ -508,28 +583,23 @@ 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
- ;; We used to use `raw-text' to read this file, but this causes
- ;; problems when the file contains non-ASCII characters.
- (find-file-noselect
- (autoload-ensure-default-file (autoload-generated-file)))
+ (with-current-buffer (autoload-find-generated-file)
;; This is to make generated-autoload-file have Unix EOLs, so
;; that it is portable to all platforms.
(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)
@@ -582,15 +652,20 @@ removes any prior now out-of-date autoload entries."
;;;###autoload
(defun update-directory-autoloads (&rest dirs)
- "\
-Update loaddefs.el with all the current autoloads from DIRS, and no old ones.
-This uses `update-file-autoloads' (which see) to do its work.
-In an interactive call, you must give one argument, the name
-of a single directory. In a call from Lisp, you can supply multiple
+ "Update autoload definitions for Lisp files in the directories DIRS.
+In an interactive call, you must give one argument, the name of a
+single directory. In a call from Lisp, you can supply multiple
directories as separate arguments, but this usage is discouraged.
The function does NOT recursively descend into subdirectories of the
-directory or directories specified."
+directory or directories specified.
+
+In an interactive call, prompt for a default output file for the
+autoload definitions, and temporarily bind the variable
+`generated-autoload-file' to this value. When called from Lisp,
+use the existing value of `generated-autoload-file'. If any Lisp
+file binds `generated-autoload-file' as a file-local variable,
+write its autoloads into the specified file instead."
(interactive "DUpdate autoloads from directory: ")
(let* ((files-re (let ((tmp nil))
(dolist (suf (get-load-suffixes)
@@ -606,13 +681,14 @@ directory or directories specified."
;; Files with no autoload cookies or whose autoloads go to other
;; files because of file-local autoload-generated-file settings.
(no-autoloads nil)
- (autoload-modified-buffers nil))
+ (autoload-modified-buffers nil)
+ (generated-autoload-file
+ (if (called-interactively-p 'interactive)
+ (read-file-name "Write autoload definitions to file: ")
+ generated-autoload-file)))
- (with-current-buffer
- (find-file-noselect
- (autoload-ensure-default-file (autoload-generated-file)))
+ (with-current-buffer (autoload-find-generated-file)
(save-excursion
-
;; Canonicalize file names and remove the autoload file itself.
(setq files (delete (file-relative-name buffer-file-name)
(mapcar 'file-relative-name files)))
@@ -649,6 +725,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 +734,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))))
@@ -670,7 +750,8 @@ directory or directories specified."
(current-buffer) nil nil no-autoloads this-time)
(insert generate-autoload-section-trailer))
- (save-buffer)
+ (let ((version-control 'never))
+ (save-buffer))
;; In case autoload entries were added to other files because of
;; file-local autoload-generated-file settings.
(autoload-save-buffers))))
@@ -684,7 +765,9 @@ directory or directories specified."
;;;###autoload
(defun batch-update-autoloads ()
"Update loaddefs.el autoloads in batch mode.
-Calls `update-directory-autoloads' on the command line arguments."
+Calls `update-directory-autoloads' on the command line arguments.
+Definitions are written to `generated-autoload-file' (which
+should be non-nil)."
;; For use during the Emacs build process only.
(unless autoload-excludes
(let* ((ldir (file-name-directory generated-autoload-file))
@@ -725,11 +808,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/avl-tree.el b/lisp/emacs-lisp/avl-tree.el
index 63774bc229f..0a637da0bc1 100644
--- a/lisp/emacs-lisp/avl-tree.el
+++ b/lisp/emacs-lisp/avl-tree.el
@@ -1,6 +1,6 @@
;;; avl-tree.el --- balanced binary trees, AVL-trees
-;; Copyright (C) 1995, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 2007-2011 Free Software Foundation, Inc.
;; Author: Per Cederqvist <ceder@lysator.liu.se>
;; Inge Wallin <inge@lysator.liu.se>
@@ -466,5 +466,4 @@ If there is no such element in the tree, the value is nil."
(provide 'avl-tree)
-;; arch-tag: 47e26701-43c9-4222-bd79-739eac6357a9
;;; avl-tree.el ends here
diff --git a/lisp/emacs-lisp/backquote.el b/lisp/emacs-lisp/backquote.el
index ab608cb4c51..34e316b2e48 100644
--- a/lisp/emacs-lisp/backquote.el
+++ b/lisp/emacs-lisp/backquote.el
@@ -1,11 +1,11 @@
;;; backquote.el --- implement the ` Lisp construct
-;; Copyright (C) 1990, 1992, 1994, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990, 1992, 1994, 2001-2011 Free Software Foundation, Inc.
;; Author: Rick Sladkey <jrs@world.std.com>
;; Maintainer: FSF
;; Keywords: extensions, internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -240,5 +240,4 @@ LEVEL is only used internally and indicates the nesting level:
tail))
(t (cons 'list heads)))))
-;; arch-tag: 1a26206a-6b5e-4c56-8e24-2eef0f7e0e7a
;;; backquote.el ends here
diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el
index 8f6d8a5d9df..86063c512c6 100644
--- a/lisp/emacs-lisp/benchmark.el
+++ b/lisp/emacs-lisp/benchmark.el
@@ -1,7 +1,6 @@
;;; benchmark.el --- support for benchmarking code
-;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2003-2011 Free Software Foundation, Inc.
;; Author: Dave Love <fx@gnu.org>
;; Keywords: lisp, extensions
@@ -116,5 +115,4 @@ For non-interactive use see also `benchmark-run' and
(provide 'benchmark)
-;; arch-tag: be570e24-4b51-4784-adf3-fa2b56c31946
;;; benchmark.el ends here
diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el
index 244b838fa29..fd98b5f41a7 100644
--- a/lisp/emacs-lisp/bindat.el
+++ b/lisp/emacs-lisp/bindat.el
@@ -1,6 +1,6 @@
;;; bindat.el --- binary data structure packing and unpacking.
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Kim F. Storm <storm@cua.dk>
;; Assignment name: struct.el
@@ -649,5 +649,4 @@ The port (if any) is omitted. IP can be a string, as well."
(provide 'bindat)
-;; arch-tag: 5e6708c3-03e2-4ad7-9885-5041b779c3fb
;;; bindat.el ends here
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 75268100c8d..7b98ade2422 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -1,12 +1,12 @@
-;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler
+;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler -*- lexical-binding: t -*-
-;; Copyright (C) 1991, 1994, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1991, 1994, 2000-2011 Free Software Foundation, Inc.
;; Author: Jamie Zawinski <jwz@lucid.com>
;; Hallvard Furuseth <hbf@ulrik.uio.no>
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -186,8 +186,10 @@
(eval-when-compile (require 'cl))
(defun byte-compile-log-lap-1 (format &rest args)
- (if (aref byte-code-vector 0)
- (error "The old version of the disassembler is loaded. Reload new-bytecomp as well"))
+ ;; Newer byte codes for stack-ref make the slot 0 non-nil again.
+ ;; But the "old disassembler" is *really* ancient by now.
+ ;; (if (aref byte-code-vector 0)
+ ;; (error "The old version of the disassembler is loaded. Reload new-bytecomp as well"))
(byte-compile-log-1
(apply 'format format
(let (c a)
@@ -242,58 +244,72 @@
sexp)))
(cdr form))))
-
-;; Splice the given lap code into the current instruction stream.
-;; If it has any labels in it, you're responsible for making sure there
-;; are no collisions, and that byte-compile-tag-number is reasonable
-;; after this is spliced in. The provided list is destroyed.
-(defun byte-inline-lapcode (lap)
- (setq byte-compile-output (nconc (nreverse lap) byte-compile-output)))
-
(defun byte-compile-inline-expand (form)
(let* ((name (car form))
- (fn (or (cdr (assq name byte-compile-function-environment))
- (and (fboundp name) (symbol-function name)))))
- (if (null fn)
- (progn
- (byte-compile-warn "attempt to inline `%s' before it was defined"
- name)
- form)
- ;; else
- (when (and (consp fn) (eq (car fn) 'autoload))
- (load (nth 1 fn))
- (setq fn (or (and (fboundp name) (symbol-function name))
- (cdr (assq name byte-compile-function-environment)))))
- (if (and (consp fn) (eq (car fn) 'autoload))
- (error "File `%s' didn't define `%s'" (nth 1 fn) name))
- (if (and (symbolp fn) (not (eq fn t)))
- (byte-compile-inline-expand (cons fn (cdr form)))
- (if (byte-code-function-p fn)
- (let (string)
- (fetch-bytecode fn)
- (setq string (aref fn 1))
- ;; Isn't it an error for `string' not to be unibyte?? --stef
- (if (fboundp 'string-as-unibyte)
- (setq string (string-as-unibyte string)))
- ;; `byte-compile-splice-in-already-compiled-code'
- ;; takes care of inlining the body.
- (cons `(lambda ,(aref fn 0)
- (byte-code ,string ,(aref fn 2) ,(aref fn 3)))
- (cdr form)))
- (if (eq (car-safe fn) 'lambda)
- (cons fn (cdr form))
- ;; Give up on inlining.
- form))))))
+ (localfn (cdr (assq name byte-compile-function-environment)))
+ (fn (or localfn (and (fboundp name) (symbol-function name)))))
+ (when (and (consp fn) (eq (car fn) 'autoload))
+ (load (nth 1 fn))
+ (setq fn (or (and (fboundp name) (symbol-function name))
+ (cdr (assq name byte-compile-function-environment)))))
+ (pcase fn
+ (`nil
+ (byte-compile-warn "attempt to inline `%s' before it was defined"
+ name)
+ form)
+ (`(autoload . ,_)
+ (error "File `%s' didn't define `%s'" (nth 1 fn) name))
+ ((and (pred symbolp) (guard (not (eq fn t)))) ;A function alias.
+ (byte-compile-inline-expand (cons fn (cdr form))))
+ ((pred byte-code-function-p)
+ ;; (message "Inlining byte-code for %S!" name)
+ ;; The byte-code will be really inlined in byte-compile-unfold-bcf.
+ `(,fn ,@(cdr form)))
+ ((or (and `(lambda ,args . ,body) (let env nil))
+ `(closure ,env ,args . ,body))
+ (if (not (or (eq fn localfn) ;From the same file => same mode.
+ (eq (not lexical-binding) (not env)))) ;Same mode.
+ ;; While byte-compile-unfold-bcf can inline dynbind byte-code into
+ ;; letbind byte-code (or any other combination for that matter), we
+ ;; can only inline dynbind source into dynbind source or letbind
+ ;; source into letbind source.
+ ;; FIXME: we could of course byte-compile the inlined function
+ ;; first, and then inline its byte-code.
+ form
+ (let ((renv ()))
+ ;; Turn the function's closed vars (if any) into local let bindings.
+ (dolist (binding env)
+ (cond
+ ((consp binding)
+ ;; We check shadowing by the args, so that the `let' can be
+ ;; moved within the lambda, which can then be unfolded.
+ ;; FIXME: Some of those bindings might be unused in `body'.
+ (unless (memq (car binding) args) ;Shadowed.
+ (push `(,(car binding) ',(cdr binding)) renv)))
+ ((eq binding t))
+ (t (push `(defvar ,binding) body))))
+ (let ((newfn (byte-compile-preprocess
+ (if (null renv)
+ `(lambda ,args ,@body)
+ `(lambda ,args (let ,(nreverse renv) ,@body))))))
+ (if (eq (car-safe newfn) 'function)
+ (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form)))
+ (byte-compile-log-warning
+ (format "Inlining closure %S failed" name))
+ form)))))
+
+ (t ;; Give up on inlining.
+ form))))
;; ((lambda ...) ...)
(defun byte-compile-unfold-lambda (form &optional name)
+ ;; In lexical-binding mode, let and functions don't bind vars in the same way
+ ;; (let obey special-variable-p, but functions don't). But luckily, this
+ ;; doesn't matter here, because function's behavior is underspecified so it
+ ;; can safely be turned into a `let', even though the reverse is not true.
(or name (setq name "anonymous lambda"))
(let ((lambda (car form))
(values (cdr form)))
- (if (byte-code-function-p lambda)
- (setq lambda (list 'lambda (aref lambda 0)
- (list 'byte-code (aref lambda 1)
- (aref lambda 2) (aref lambda 3)))))
(let ((arglist (nth 1 lambda))
(body (cdr (cdr lambda)))
optionalp restp
@@ -302,6 +318,7 @@
(setq body (cdr body)))
(if (and (consp (car body)) (eq 'interactive (car (car body))))
(setq body (cdr body)))
+ ;; FIXME: The checks below do not belong in an optimization phase.
(while arglist
(cond ((eq (car arglist) '&optional)
;; ok, I'll let this slide because funcall_lambda() does...
@@ -379,8 +396,7 @@
(and (nth 1 form)
(not for-effect)
form))
- ((or (byte-code-function-p fn)
- (eq 'lambda (car-safe fn)))
+ ((eq 'lambda (car-safe fn))
(let ((newform (byte-compile-unfold-lambda form)))
(if (eq newform form)
;; Some error occurred, avoid infinite recursion
@@ -455,8 +471,8 @@
(byte-optimize-form (nth 2 form) for-effect)
(byte-optimize-body (nthcdr 3 form) for-effect)))))
- ((memq fn '(and or)) ; remember, and/or are control structures.
- ;; take forms off the back until we can't any more.
+ ((memq fn '(and or)) ; Remember, and/or are control structures.
+ ;; Take forms off the back until we can't any more.
;; In the future it could conceivably be a problem that the
;; subexpressions of these forms are optimized in the reverse
;; order, but it's ok for now.
@@ -471,7 +487,8 @@
(byte-compile-log
" all subforms of %s called for effect; deleted" form))
(and backwards
- (cons fn (nreverse (mapcar 'byte-optimize-form backwards)))))
+ (cons fn (nreverse (mapcar 'byte-optimize-form
+ backwards)))))
(cons fn (mapcar 'byte-optimize-form (cdr form)))))
((eq fn 'interactive)
@@ -479,8 +496,7 @@
(prin1-to-string form))
nil)
- ((memq fn '(defun defmacro function
- condition-case save-window-excursion))
+ ((memq fn '(defun defmacro function condition-case))
;; These forms are compiled as constants or by breaking out
;; all the subexpressions and compiling them separately.
form)
@@ -511,23 +527,11 @@
;; However, don't actually bother calling `ignore'.
`(prog1 nil . ,(mapcar 'byte-optimize-form (cdr form))))
- ;; If optimization is on, this is the only place that macros are
- ;; expanded. If optimization is off, then macroexpansion happens
- ;; in byte-compile-form. Otherwise, the macros are already expanded
- ;; by the time that is reached.
- ((not (eq form
- (setq form (macroexpand form
- byte-compile-macro-environment))))
- (byte-optimize-form form for-effect))
-
- ;; Support compiler macros as in cl.el.
- ((and (fboundp 'compiler-macroexpand)
- (symbolp (car-safe form))
- (get (car-safe form) 'cl-compiler-macro)
- (not (eq form
- (with-no-warnings
- (setq form (compiler-macroexpand form))))))
- (byte-optimize-form form for-effect))
+ ;; Neeeded as long as we run byte-optimize-form after cconv.
+ ((eq fn 'internal-make-closure) form)
+
+ ((byte-code-function-p fn)
+ (cons fn (mapcar #'byte-optimize-form (cdr form))))
((not (symbolp fn))
(byte-compile-warn "`%s' is a malformed function"
@@ -605,7 +609,7 @@
(defun byte-optimize-body (forms all-for-effect)
- ;; optimize the cdr of a progn or implicit progn; all forms is a list of
+ ;; Optimize the cdr of a progn or implicit progn; all forms is a list of
;; forms, all but the last of which are optimized with the assumption that
;; they are being called for effect. the last is for-effect as well if
;; all-for-effect is true. returns a new list of forms.
@@ -1085,7 +1089,7 @@
(let ((fn (nth 1 form)))
(if (memq (car-safe fn) '(quote function))
(cons (nth 1 fn) (cdr (cdr form)))
- form)))
+ form)))
(defun byte-optimize-apply (form)
;; If the last arg is a literal constant, turn this into a funcall.
@@ -1291,60 +1295,51 @@
(put (car pure-fns) 'pure t)
(setq pure-fns (cdr pure-fns)))
nil)
-
-(defun byte-compile-splice-in-already-compiled-code (form)
- ;; form is (byte-code "..." [...] n)
- (if (not (memq byte-optimize '(t lap)))
- (byte-compile-normal-call form)
- (byte-inline-lapcode
- (byte-decompile-bytecode-1 (nth 1 form) (nth 2 form) t))
- (setq byte-compile-maxdepth (max (+ byte-compile-depth (nth 3 form))
- byte-compile-maxdepth))
- (setq byte-compile-depth (1+ byte-compile-depth))))
-
-(put 'byte-code 'byte-compile 'byte-compile-splice-in-already-compiled-code)
-
(defconst byte-constref-ops
'(byte-constant byte-constant2 byte-varref byte-varset byte-varbind))
+;; Used and set dynamically in byte-decompile-bytecode-1.
+(defvar bytedecomp-op)
+(defvar bytedecomp-ptr)
+
;; This function extracts the bitfields from variable-length opcodes.
;; Originally defined in disass.el (which no longer uses it.)
-
-(defun disassemble-offset ()
+(defun disassemble-offset (bytes)
"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))
+ ;; Fetch and return the offset for the current opcode.
+ ;; Return nil if this opcode has no offset.
+ (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 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))))
- (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))))
-
+ ;; Offset in next 2 bytes.
+ (setq bytedecomp-ptr (1+ bytedecomp-ptr))
+ (+ (aref bytes bytedecomp-ptr)
+ (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr))
+ (lsh (aref bytes bytedecomp-ptr) 8))))
+ (t tem)))) ;Offset was in opcode.
+ ((>= bytedecomp-op byte-constant)
+ (prog1 (- bytedecomp-op byte-constant) ;Offset in opcode.
+ (setq bytedecomp-op byte-constant)))
+ ((or (and (>= bytedecomp-op byte-constant2)
+ (<= bytedecomp-op byte-goto-if-not-nil-else-pop))
+ (= bytedecomp-op byte-stack-set2))
+ ;; Offset in next 2 bytes.
+ (setq bytedecomp-ptr (1+ bytedecomp-ptr))
+ (+ (aref bytes bytedecomp-ptr)
+ (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr))
+ (lsh (aref bytes bytedecomp-ptr) 8))))
+ ((and (>= bytedecomp-op byte-listN)
+ (<= bytedecomp-op byte-discardN))
+ (setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;Offset in next byte.
+ (aref bytes bytedecomp-ptr))))
+
+(defvar byte-compile-tag-number)
;; This de-compiler is used for inline expansion of compiled functions,
;; and by the disassembler.
@@ -1368,62 +1363,62 @@
;; 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
- lap tmp
- endtag)
- (while (not (= ptr length))
+ (bytedecomp-ptr 0) optr tags bytedecomp-op offset
+ lap tmp)
+ (while (not (= bytedecomp-ptr length))
(or make-spliceable
- (setq lap (cons ptr lap)))
- (setq op (aref bytes ptr)
- optr ptr
- offset (disassemble-offset)) ; this does dynamic-scope magic
- (setq op (aref byte-code-vector op))
- (cond ((memq op byte-goto-ops)
- ;; it's a pc
+ (push bytedecomp-ptr lap))
+ (setq bytedecomp-op (aref bytes bytedecomp-ptr)
+ optr bytedecomp-ptr
+ ;; This uses dynamic-scope magic.
+ offset (disassemble-offset bytes))
+ (let ((opcode (aref byte-code-vector bytedecomp-op)))
+ (assert opcode)
+ (setq bytedecomp-op opcode))
+ (cond ((memq bytedecomp-op byte-goto-ops)
+ ;; It's a pc.
(setq offset
(cdr (or (assq offset tags)
- (car (setq tags
- (cons (cons offset
- (byte-compile-make-tag))
- tags)))))))
- ((cond ((eq op 'byte-constant2) (setq op 'byte-constant) t)
- ((memq op byte-constref-ops)))
+ (let ((new (cons offset (byte-compile-make-tag))))
+ (push new tags)
+ new)))))
+ ((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)
- (setq offset (or endtag (setq endtag (byte-compile-make-tag)))
- op 'byte-goto))))
+ (let ((new (list tmp)))
+ (push new byte-compile-variables)
+ new)))))
+ ((eq bytedecomp-op 'byte-stack-set2)
+ (setq bytedecomp-op 'byte-stack-set))
+ ((and (eq bytedecomp-op 'byte-discardN) (>= offset #x80))
+ ;; The top bit of the operand for byte-discardN is a flag,
+ ;; saying whether the top-of-stack is preserved. In
+ ;; lapcode, we represent this by using a different opcode
+ ;; (with the flag removed from the operand).
+ (setq bytedecomp-op 'byte-discardN-preserve-tos)
+ (setq offset (- offset #x80))))
;; lap = ( [ (pc . (op . arg)) ]* )
- (setq lap (cons (cons optr (cons op (or offset 0)))
- lap))
- (setq ptr (1+ ptr)))
- ;; take off the dummy nil op that we replaced a trailing "return" with.
+ (push (cons optr (cons bytedecomp-op (or offset 0)))
+ lap)
+ (setq bytedecomp-ptr (1+ bytedecomp-ptr)))
(let ((rest lap))
(while rest
(cond ((numberp (car rest)))
((setq tmp (assq (car (car rest)) tags))
- ;; this addr is jumped to
+ ;; This addr is jumped to.
(setcdr rest (cons (cons nil (cdr tmp))
(cdr rest)))
(setq tags (delq tmp tags))
(setq rest (cdr rest))))
(setq rest (cdr rest))))
(if tags (error "optimizer error: missed tags %s" tags))
- (if (null (car (cdr (car lap))))
- (setq lap (cdr lap)))
- (if endtag
- (setq lap (cons (cons nil endtag) lap)))
- ;; remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* )
+ ;; Remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* )
(mapcar (function (lambda (elt)
(if (numberp elt)
elt
@@ -1458,7 +1453,7 @@
byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max
byte-point-min byte-following-char byte-preceding-char
byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp
- byte-current-buffer byte-interactive-p))
+ byte-current-buffer byte-stack-ref))
(defconst byte-compile-side-effect-free-ops
(nconc
@@ -1500,7 +1495,7 @@
;; The variable `byte-boolean-vars' is now primitive and updated
;; automatically by DEFVAR_BOOL.
-(defun byte-optimize-lapcode (lap &optional for-effect)
+(defun byte-optimize-lapcode (lap &optional _for-effect)
"Simple peephole optimizer. LAP is both modified and returned.
If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
(let (lap0
@@ -1575,9 +1570,14 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup
;; The latter two can enable other optimizations.
;;
+ ;; For lexical variables, we could do the same
+ ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2
+ ;; but this is a very minor gain, since dup is stack-ref-0,
+ ;; i.e. it's only better if X>5, and even then it comes
+ ;; at the cost cost of an extra stack slot. Let's not bother.
((and (eq 'byte-varref (car lap2))
- (eq (cdr lap1) (cdr lap2))
- (memq (car lap1) '(byte-varset byte-varbind)))
+ (eq (cdr lap1) (cdr lap2))
+ (memq (car lap1) '(byte-varset byte-varbind)))
(if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars))
(not (eq (car lap0) 'byte-constant)))
nil
@@ -1606,14 +1606,17 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;;
;; dup varset-X discard --> varset-X
;; dup varbind-X discard --> varbind-X
+ ;; dup stack-set-X discard --> stack-set-X-1
;; (the varbind variant can emerge from other optimizations)
;;
((and (eq 'byte-dup (car lap0))
(eq 'byte-discard (car lap2))
- (memq (car lap1) '(byte-varset byte-varbind)))
+ (memq (car lap1) '(byte-varset byte-varbind
+ byte-stack-set)))
(byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1)
(setq keep-going t
rest (cdr rest))
+ (if (eq 'byte-stack-set (car lap1)) (decf (cdr lap1)))
(setq lap (delq lap0 (delq lap2 lap))))
;;
;; not goto-X-if-nil --> goto-X-if-non-nil
@@ -1622,8 +1625,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;; it is wrong to do the same thing for the -else-pop variants.
;;
((and (eq 'byte-not (car lap0))
- (or (eq 'byte-goto-if-nil (car lap1))
- (eq 'byte-goto-if-not-nil (car lap1))))
+ (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil)))
(byte-compile-log-lap " not %s\t-->\t%s"
lap1
(cons
@@ -1642,8 +1644,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;;
;; it is wrong to do the same thing for the -else-pop variants.
;;
- ((and (or (eq 'byte-goto-if-nil (car lap0))
- (eq 'byte-goto-if-not-nil (car lap0))) ; gotoX
+ ((and (memq (car lap0)
+ '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX
(eq 'byte-goto (car lap1)) ; gotoY
(eq (cdr lap0) lap2)) ; TAG X
(let ((inverse (if (eq 'byte-goto-if-nil (car lap0))
@@ -1658,40 +1660,51 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;; const goto-if-* --> whatever
;;
((and (eq 'byte-constant (car lap0))
- (memq (car lap1) byte-conditional-ops))
- (cond ((if (or (eq (car lap1) 'byte-goto-if-nil)
- (eq (car lap1) 'byte-goto-if-nil-else-pop))
- (car (cdr lap0))
- (not (car (cdr lap0))))
+ (memq (car lap1) byte-conditional-ops)
+ ;; If the `byte-constant's cdr is not a cons cell, it has
+ ;; to be an index into the constant pool); even though
+ ;; it'll be a constant, that constant is not known yet
+ ;; (it's typically a free variable of a closure, so will
+ ;; only be known when the closure will be built at
+ ;; run-time).
+ (consp (cdr lap0)))
+ (cond ((if (memq (car lap1) '(byte-goto-if-nil
+ byte-goto-if-nil-else-pop))
+ (car (cdr lap0))
+ (not (car (cdr lap0))))
(byte-compile-log-lap " %s %s\t-->\t<deleted>"
lap0 lap1)
(setq rest (cdr rest)
lap (delq lap0 (delq lap1 lap))))
(t
- (if (memq (car lap1) byte-goto-always-pop-ops)
- (progn
- (byte-compile-log-lap " %s %s\t-->\t%s"
- lap0 lap1 (cons 'byte-goto (cdr lap1)))
- (setq lap (delq lap0 lap)))
- (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1
- (cons 'byte-goto (cdr lap1))))
+ (byte-compile-log-lap " %s %s\t-->\t%s"
+ lap0 lap1
+ (cons 'byte-goto (cdr lap1)))
+ (when (memq (car lap1) byte-goto-always-pop-ops)
+ (setq lap (delq lap0 lap)))
(setcar lap1 'byte-goto)))
- (setq keep-going t))
+ (setq keep-going t))
;;
;; varref-X varref-X --> varref-X dup
;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup
+ ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup
;; We don't optimize the const-X variations on this here,
;; because that would inhibit some goto optimizations; we
;; optimize the const-X case after all other optimizations.
;;
- ((and (eq 'byte-varref (car lap0))
+ ((and (memq (car lap0) '(byte-varref byte-stack-ref))
(progn
(setq tmp (cdr rest))
+ (setq tmp2 0)
(while (eq (car (car tmp)) 'byte-dup)
- (setq tmp (cdr tmp)))
+ (setq tmp2 (1+ tmp2))
+ (setq tmp (cdr tmp)))
t)
- (eq (cdr lap0) (cdr (car tmp)))
- (eq 'byte-varref (car (car tmp))))
+ (eq (if (eq 'byte-stack-ref (car lap0))
+ (+ tmp2 1 (cdr lap0))
+ (cdr lap0))
+ (cdr (car tmp)))
+ (eq (car lap0) (car (car tmp))))
(if (memq byte-optimize-log '(t byte))
(let ((str ""))
(setq tmp2 (cdr rest))
@@ -1851,18 +1864,21 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
(cons 'byte-discard byte-conditional-ops)))
(not (eq lap1 (car tmp))))
(setq tmp2 (car tmp))
- (cond ((memq (car tmp2)
- (if (null (car (cdr lap0)))
- '(byte-goto-if-nil byte-goto-if-nil-else-pop)
- '(byte-goto-if-not-nil
- byte-goto-if-not-nil-else-pop)))
+ (cond ((when (consp (cdr lap0))
+ (memq (car tmp2)
+ (if (null (car (cdr lap0)))
+ '(byte-goto-if-nil byte-goto-if-nil-else-pop)
+ '(byte-goto-if-not-nil
+ byte-goto-if-not-nil-else-pop))))
(byte-compile-log-lap " %s goto [%s]\t-->\t%s %s"
lap0 tmp2 lap0 tmp2)
(setcar lap1 (car tmp2))
(setcdr lap1 (cdr tmp2))
;; Let next step fix the (const,goto-if*) sequence.
- (setq rest (cons nil rest)))
- (t
+ (setq rest (cons nil rest))
+ (setq keep-going t))
+ ((or (consp (cdr lap0))
+ (eq (car tmp2) 'byte-discard))
;; Jump one step further
(byte-compile-log-lap
" %s goto [%s]\t-->\t<deleted> goto <skip>"
@@ -1871,13 +1887,18 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
(setcdr tmp (cons (byte-compile-make-tag)
(cdr tmp))))
(setcdr lap1 (car (cdr tmp)))
- (setq lap (delq lap0 lap))))
- (setq keep-going t))
+ (setq lap (delq lap0 lap))
+ (setq keep-going t))))
;;
;; X: varref-Y ... varset-Y goto-X -->
;; X: varref-Y Z: ... dup varset-Y goto-Z
;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.)
;; (This is so usual for while loops that it is worth handling).
+ ;;
+ ;; Here again, we could do it for stack-ref/stack-set, but
+ ;; that's replacing a stack-ref-Y with a stack-ref-0, which
+ ;; is a very minor improvement (if any), at the cost of
+ ;; more stack use and more byte-code. Let's not do it.
;;
((and (eq (car lap1) 'byte-varset)
(eq (car lap2) 'byte-goto)
@@ -1950,16 +1971,16 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;; Rebuild byte-compile-constants / byte-compile-variables.
;; Simple optimizations that would inhibit other optimizations if they
;; were done in the optimizing loop, and optimizations which there is no
- ;; need to do more than once.
+ ;; need to do more than once.
(setq byte-compile-constants nil
byte-compile-variables nil)
(setq rest lap)
+ (byte-compile-log-lap " ---- final pass")
(while rest
(setq lap0 (car rest)
lap1 (nth 1 rest))
(if (memq (car lap0) byte-constref-ops)
- (if (or (eq (car lap0) 'byte-constant)
- (eq (car lap0) 'byte-constant2))
+ (if (memq (car lap0) '(byte-constant byte-constant2))
(unless (memq (cdr lap0) byte-compile-constants)
(setq byte-compile-constants (cons (cdr lap0)
byte-compile-constants)))
@@ -2003,10 +2024,86 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
(byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1
(cons 'byte-unbind
(+ (cdr lap0) (cdr lap1))))
- (setq keep-going t)
(setq lap (delq lap0 lap))
(setcdr lap1 (+ (cdr lap1) (cdr lap0))))
- )
+
+ ;;
+ ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos
+ ;; stack-set-M [discard/discardN ...] --> discardN
+ ;;
+ ((and (eq (car lap0) 'byte-stack-set)
+ (memq (car lap1) '(byte-discard byte-discardN))
+ (progn
+ ;; See if enough discard operations follow to expose or
+ ;; destroy the value stored by the stack-set.
+ (setq tmp (cdr rest))
+ (setq tmp2 (1- (cdr lap0)))
+ (setq tmp3 0)
+ (while (memq (car (car tmp)) '(byte-discard byte-discardN))
+ (setq tmp3
+ (+ tmp3 (if (eq (car (car tmp)) 'byte-discard)
+ 1
+ (cdr (car tmp)))))
+ (setq tmp (cdr tmp)))
+ (>= tmp3 tmp2)))
+ ;; Do the optimization.
+ (setq lap (delq lap0 lap))
+ (setcar lap1
+ (if (= tmp2 tmp3)
+ ;; The value stored is the new TOS, so pop one more
+ ;; value (to get rid of the old value) using the
+ ;; TOS-preserving discard operator.
+ 'byte-discardN-preserve-tos
+ ;; Otherwise, the value stored is lost, so just use a
+ ;; normal discard.
+ 'byte-discardN))
+ (setcdr lap1 (1+ tmp3))
+ (setcdr (cdr rest) tmp)
+ (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s"
+ lap0 lap1))
+
+ ;;
+ ;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y -->
+ ;; discardN-(X+Y)
+ ;;
+ ((and (memq (car lap0)
+ '(byte-discard byte-discardN
+ byte-discardN-preserve-tos))
+ (memq (car lap1) '(byte-discard byte-discardN)))
+ (setq lap (delq lap0 lap))
+ (byte-compile-log-lap
+ " %s %s\t-->\t(discardN %s)"
+ lap0 lap1
+ (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0))
+ (if (eq (car lap1) 'byte-discard) 1 (cdr lap1))))
+ (setcdr lap1 (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0))
+ (if (eq (car lap1) 'byte-discard) 1 (cdr lap1))))
+ (setcar lap1 'byte-discardN))
+
+ ;;
+ ;; discardN-preserve-tos-X discardN-preserve-tos-Y -->
+ ;; discardN-preserve-tos-(X+Y)
+ ;;
+ ((and (eq (car lap0) 'byte-discardN-preserve-tos)
+ (eq (car lap1) 'byte-discardN-preserve-tos))
+ (setq lap (delq lap0 lap))
+ (setcdr lap1 (+ (cdr lap0) (cdr lap1)))
+ (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (car rest)))
+
+ ;;
+ ;; discardN-preserve-tos return --> return
+ ;; dup return --> return
+ ;; stack-set-N return --> return ; where N is TOS-1
+ ;;
+ ((and (eq (car lap1) 'byte-return)
+ (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup))
+ (and (eq (car lap0) 'byte-stack-set)
+ (= (cdr lap0) 1))))
+ ;; The byte-code interpreter will pop the stack for us, so
+ ;; we can just leave stuff on it.
+ (setq lap (delq lap0 lap))
+ (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1))
+ )
(setq rest (cdr rest)))
(setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth)))
lap)
@@ -2035,5 +2132,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 42cd8d9ca55..3fb3d841ed1 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -1,12 +1,12 @@
;;; byte-run.el --- byte-compiler support for inlining
-;; Copyright (C) 1992, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 2001-2011 Free Software Foundation, Inc.
;; Author: Jamie Zawinski <jwz@lucid.com>
;; Hallvard Furuseth <hbf@ulrik.uio.no>
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -65,7 +65,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.
@@ -124,12 +123,10 @@ If CURRENT-NAME is a string, that is the `use instead' message
If provided, WHEN should be a string indicating when the function
was first made obsolete, for example a date or a release number."
(interactive "aMake function obsolete: \nxObsoletion replacement: ")
- (let ((handler (get obsolete-name 'byte-compile)))
- (if (eq 'byte-compile-obsolete handler)
- (setq handler (nth 1 (get obsolete-name 'byte-obsolete-info)))
- (put obsolete-name 'byte-compile 'byte-compile-obsolete))
- (put obsolete-name 'byte-obsolete-info
- (list (purecopy current-name) handler (purecopy when))))
+ (put obsolete-name 'byte-obsolete-info
+ ;; The second entry used to hold the `byte-compile' handler, but
+ ;; is not used any more nowadays.
+ (list (purecopy current-name) nil (purecopy when)))
obsolete-name)
(set-advertised-calling-convention
;; New code should always provide the `when' argument.
@@ -292,5 +289,4 @@ In interpreted code, this is entirely equivalent to `progn'."
;; (file-format emacs19))"
;; nil)
-;; arch-tag: 76f8328a-1f66-4df2-9b6d-5c3666dc05e9
;;; byte-run.el ends here
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 86cfaff77ba..e7f2115a848 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -1,12 +1,13 @@
-;;; bytecomp.el --- compilation of Lisp code into byte code
+;;; bytecomp.el --- compilation of Lisp code into byte code -*- lexical-binding: t -*-
-;; Copyright (C) 1985, 1986, 1987, 1992, 1994, 1998, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1987, 1992, 1994, 1998, 2000-2011
+;; 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 +36,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
@@ -116,12 +118,16 @@
;; Some versions of `file' can be customized to recognize that.
(require 'backquote)
+(require 'macroexp)
+(require 'cconv)
(eval-when-compile (require 'cl))
(or (fboundp 'defsubst)
;; This really ought to be loaded already!
(load "byte-run"))
+;; The feature of compiling in a specific target Emacs version
+;; has been turned off because compile time options are a bad idea.
(defgroup bytecomp nil
"Emacs Lisp byte-compiler."
:group 'lisp)
@@ -225,6 +231,7 @@ the functions you loaded will not be able to run.")
(defvar byte-compile-disable-print-circle nil
"If non-nil, disable `print-circle' on printing a byte-compiled code.")
+(make-obsolete-variable 'byte-compile-disable-print-circle nil "24.1")
;;;###autoload(put 'byte-compile-disable-print-circle 'safe-local-variable 'booleanp)
(defcustom byte-compile-dynamic-docstrings t
@@ -245,10 +252,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 +274,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).
@@ -395,7 +406,7 @@ specify different fields to sort on."
(defvar byte-compile-variables nil
"List of all variables encountered during compilation of this form.")
(defvar byte-compile-bound-variables nil
- "List of variables bound in the context of the current form.
+ "List of dynamic variables bound in the context of the current form.
This list lives partly on the stack.")
(defvar byte-compile-const-variables nil
"List of variables declared as constants during compilation of this file.")
@@ -408,10 +419,13 @@ This list lives partly on the stack.")
'(
;; (byte-compiler-options . (lambda (&rest forms)
;; (apply 'byte-compiler-options-handler forms)))
+ (declare-function . byte-compile-macroexpand-declare-function)
(eval-when-compile . (lambda (&rest body)
- (list 'quote
- (byte-compile-eval (byte-compile-top-level
- (cons 'progn body))))))
+ (list
+ 'quote
+ (byte-compile-eval
+ (byte-compile-top-level
+ (byte-compile-preprocess (cons 'progn body)))))))
(eval-and-compile . (lambda (&rest body)
(byte-compile-eval-before-compile (cons 'progn body))
(cons 'progn body))))
@@ -444,6 +458,10 @@ defined with incorrect args.")
Used for warnings about calling a function that is defined during compilation
but won't necessarily be defined when the compiled file is loaded.")
+;; Variables for lexical binding
+(defvar byte-compile--lexical-environment nil
+ "The current lexical environment.")
+
(defvar byte-compile-tag-number 0)
(defvar byte-compile-output nil
"Alist describing contents to put in byte code string.
@@ -489,11 +507,10 @@ Each element is (INDEX . VALUE)")
(put 'byte-stack+-info 'tmp-compile-time-value nil)))
-;; unused: 0-7
-
;; These opcodes are special in that they pack their argument into the
;; opcode word.
;;
+(byte-defop 0 1 byte-stack-ref "for stack reference")
(byte-defop 8 1 byte-varref "for variable reference")
(byte-defop 16 -1 byte-varset "for setting a variable")
(byte-defop 24 -1 byte-varbind "for binding a variable")
@@ -563,7 +580,7 @@ Each element is (INDEX . VALUE)")
(byte-defop 114 0 byte-save-current-buffer
"To make a binding to record the current buffer")
(byte-defop 115 0 byte-set-mark-OBSOLETE)
-(byte-defop 116 1 byte-interactive-p)
+(byte-defop 116 1 byte-interactive-p-OBSOLETE)
;; These ops are new to v19
(byte-defop 117 0 byte-forward-char)
@@ -599,7 +616,7 @@ otherwise pop it")
(byte-defop 138 0 byte-save-excursion
"to make a binding to record the buffer, point and mark")
-(byte-defop 139 0 byte-save-window-excursion
+(byte-defop 139 0 byte-save-window-excursion-OBSOLETE
"to make a binding to record entire window configuration")
(byte-defop 140 0 byte-save-restriction
"to make a binding to record the current buffer clipping restrictions")
@@ -612,17 +629,8 @@ otherwise pop it")
;; an expression for the body, and a list of clauses.
(byte-defop 143 -2 byte-condition-case)
-;; For entry to with-output-to-temp-buffer.
-;; Takes, on stack, the buffer name.
-;; Binds standard-output and does some other things.
-;; Returns with temp buffer on the stack in place of buffer name.
-(byte-defop 144 0 byte-temp-output-buffer-setup)
-
-;; For exit from with-output-to-temp-buffer.
-;; Expects the temp buffer on the stack underneath value to return.
-;; Pops them both, then pushes the value back on.
-;; Unbinds standard-output and makes the temp buffer visible.
-(byte-defop 145 -1 byte-temp-output-buffer-show)
+(byte-defop 144 0 byte-temp-output-buffer-setup-OBSOLETE)
+(byte-defop 145 -1 byte-temp-output-buffer-show-OBSOLETE)
;; these ops are new to v19
@@ -659,7 +667,21 @@ otherwise pop it")
(byte-defop 176 nil byte-concatN)
(byte-defop 177 nil byte-insertN)
-;; unused: 178-191
+(byte-defop 178 -1 byte-stack-set) ; Stack offset in following one byte.
+(byte-defop 179 -1 byte-stack-set2) ; Stack offset in following two bytes.
+
+;; If (following one byte & 0x80) == 0
+;; discard (following one byte & 0x7F) stack entries
+;; else
+;; discard (following one byte & 0x7F) stack entries _underneath_ TOS
+;; (that is, if the operand = 0x83, ... X Y Z T => ... T)
+(byte-defop 182 nil byte-discardN)
+;; `byte-discardN-preserve-tos' is a pseudo-op that gets turned into
+;; `byte-discardN' with the high bit in the operand set (by
+;; `byte-compile-lapcode').
+(defconst byte-discardN-preserve-tos byte-discardN)
+
+;; unused: 182-191
(byte-defop 192 1 byte-constant "for reference to a constant")
;; codes 193-255 are consumed by byte-constant.
@@ -706,71 +728,114 @@ otherwise pop it")
;; front of the constants-vector than the constant-referencing instructions.
;; Also, this lets us notice references to free variables.
+(defmacro byte-compile-push-bytecodes (&rest args)
+ "Push BYTE... onto BYTES, and increment PC by the number of bytes pushed.
+ARGS is of the form (BYTE... BYTES PC), where BYTES and PC are variable names.
+BYTES and PC are updated after evaluating all the arguments."
+ (let ((byte-exprs (butlast args 2))
+ (bytes-var (car (last args 2)))
+ (pc-var (car (last args))))
+ `(setq ,bytes-var ,(if (null (cdr byte-exprs))
+ `(progn (assert (<= 0 ,(car byte-exprs)))
+ (cons ,@byte-exprs ,bytes-var))
+ `(nconc (list ,@(reverse byte-exprs)) ,bytes-var))
+ ,pc-var (+ ,(length byte-exprs) ,pc-var))))
+
+(defmacro byte-compile-push-bytecode-const2 (opcode const2 bytes pc)
+ "Push OPCODE and the two-byte constant CONST2 onto BYTES, and add 3 to PC.
+CONST2 may be evaulated multiple times."
+ `(byte-compile-push-bytecodes ,opcode (logand ,const2 255) (lsh ,const2 -8)
+ ,bytes ,pc))
+
(defun byte-compile-lapcode (lap)
"Turns lapcode into bytecode. The lapcode is destroyed."
;; Lapcode modifications: changes the ID of a tag to be the tag's PC.
(let ((pc 0) ; Program counter
op off ; Operation & offset
+ opcode ; numeric value of OP
(bytes '()) ; Put the output bytes here
- (patchlist nil)) ; List of tags and goto's to patch
- (while lap
- (setq op (car (car lap))
- off (cdr (car lap)))
- (cond ((not (symbolp op))
- (error "Non-symbolic opcode `%s'" op))
- ((eq op 'TAG)
- (setcar off pc)
- (setq patchlist (cons off patchlist)))
- ((memq op byte-goto-ops)
- (setq pc (+ pc 3))
- (setq bytes (cons (cons pc (cdr off))
- (cons nil
- (cons (symbol-value op) bytes))))
- (setq patchlist (cons bytes patchlist)))
- (t
- (setq bytes
- (cond ((cond ((consp off)
- ;; Variable or constant reference
- (setq off (cdr off))
- (eq op 'byte-constant)))
- (cond ((< off byte-constant-limit)
- (setq pc (1+ pc))
- (cons (+ byte-constant off) bytes))
- (t
- (setq pc (+ 3 pc))
- (cons (lsh off -8)
- (cons (logand off 255)
- (cons byte-constant2 bytes))))))
- ((<= byte-listN (symbol-value op))
- (setq pc (+ 2 pc))
- (cons off (cons (symbol-value op) bytes)))
- ((< off 6)
- (setq pc (1+ pc))
- (cons (+ (symbol-value op) off) bytes))
- ((< off 256)
- (setq pc (+ 2 pc))
- (cons off (cons (+ (symbol-value op) 6) bytes)))
- (t
- (setq pc (+ 3 pc))
- (cons (lsh off -8)
- (cons (logand off 255)
- (cons (+ (symbol-value op) 7)
- bytes))))))))
- (setq lap (cdr lap)))
+ (patchlist nil)) ; List of gotos to patch
+ (dolist (lap-entry lap)
+ (setq op (car lap-entry)
+ off (cdr lap-entry))
+ (cond
+ ((not (symbolp op))
+ (error "Non-symbolic opcode `%s'" op))
+ ((eq op 'TAG)
+ (setcar off pc))
+ (t
+ (setq opcode
+ (if (eq op 'byte-discardN-preserve-tos)
+ ;; byte-discardN-preserve-tos is a pseudo op, which
+ ;; is actually the same as byte-discardN
+ ;; with a modified argument.
+ byte-discardN
+ (symbol-value op)))
+ (cond ((memq op byte-goto-ops)
+ ;; goto
+ (byte-compile-push-bytecodes opcode nil (cdr off) bytes pc)
+ (push bytes patchlist))
+ ((or (and (consp off)
+ ;; Variable or constant reference
+ (progn
+ (setq off (cdr off))
+ (eq op 'byte-constant)))
+ (and (eq op 'byte-constant)
+ (integerp off)))
+ ;; constant ref
+ (if (< off byte-constant-limit)
+ (byte-compile-push-bytecodes (+ byte-constant off)
+ bytes pc)
+ (byte-compile-push-bytecode-const2 byte-constant2 off
+ bytes pc)))
+ ((and (= opcode byte-stack-set)
+ (> off 255))
+ ;; Use the two-byte version of byte-stack-set if the
+ ;; offset is too large for the normal version.
+ (byte-compile-push-bytecode-const2 byte-stack-set2 off
+ bytes pc))
+ ((and (>= opcode byte-listN)
+ (< opcode byte-discardN))
+ ;; These insns all put their operand into one extra byte.
+ (byte-compile-push-bytecodes opcode off bytes pc))
+ ((= opcode byte-discardN)
+ ;; byte-discardN is weird in that it encodes a flag in the
+ ;; top bit of its one-byte argument. If the argument is
+ ;; too large to fit in 7 bits, the opcode can be repeated.
+ (let ((flag (if (eq op 'byte-discardN-preserve-tos) #x80 0)))
+ (while (> off #x7f)
+ (byte-compile-push-bytecodes opcode (logior #x7f flag)
+ bytes pc)
+ (setq off (- off #x7f)))
+ (byte-compile-push-bytecodes opcode (logior off flag)
+ bytes pc)))
+ ((null off)
+ ;; opcode that doesn't use OFF
+ (byte-compile-push-bytecodes opcode bytes pc))
+ ((and (eq opcode byte-stack-ref) (eq off 0))
+ ;; (stack-ref 0) is really just another name for `dup'.
+ (debug) ;FIXME: When would this happen?
+ (byte-compile-push-bytecodes byte-dup bytes pc))
+ ;; The following three cases are for the special
+ ;; insns that encode their operand into 0, 1, or 2
+ ;; extra bytes depending on its magnitude.
+ ((< off 6)
+ (byte-compile-push-bytecodes (+ opcode off) bytes pc))
+ ((< off 256)
+ (byte-compile-push-bytecodes (+ opcode 6) off bytes pc))
+ (t
+ (byte-compile-push-bytecode-const2 (+ opcode 7) off
+ bytes pc))))))
;;(if (not (= pc (length bytes)))
;; (error "Compiler error: pc mismatch - %s %s" pc (length bytes)))
- ;; Patch PC into jumps
- (let (bytes)
- (while patchlist
- (setq bytes (car patchlist))
- (cond ((atom (car bytes))) ; Tag
- (t ; Absolute jump
- (setq pc (car (cdr (car bytes)))) ; Pick PC from tag
- (setcar (cdr bytes) (logand pc 255))
- (setcar bytes (lsh pc -8))
- ;; FIXME: Replace this by some workaround.
- (if (> (car bytes) 255) (error "Bytecode overflow"))))
- (setq patchlist (cdr patchlist))))
+ ;; Patch tag PCs into absolute jumps.
+ (dolist (bytes-tail patchlist)
+ (setq pc (caar bytes-tail)) ; Pick PC from goto's tag.
+ (setcar (cdr bytes-tail) (logand pc 255))
+ (setcar bytes-tail (lsh pc -8))
+ ;; FIXME: Replace this by some workaround.
+ (if (> (car bytes) 255) (error "Bytecode overflow")))
+
(apply 'unibyte-string (nreverse bytes))))
@@ -786,7 +851,7 @@ otherwise pop it")
Each function's symbol gets added to `byte-compile-noruntime-functions'."
(let ((hist-orig load-history)
(hist-nil-orig current-load-list))
- (prog1 (eval form)
+ (prog1 (eval form lexical-binding)
(when (byte-compile-warning-enabled-p 'noruntime)
(let ((hist-new load-history)
(hist-nil-new current-load-list))
@@ -838,7 +903,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(defun byte-compile-eval-before-compile (form)
"Evaluate FORM for `eval-and-compile'."
(let ((hist-nil-orig current-load-list))
- (prog1 (eval form)
+ (prog1 (eval form lexical-binding)
;; (eval-and-compile (require 'cl) turns off warnings for cl functions.
;; FIXME Why does it do that - just as a hack?
;; There are other ways to do this nowadays.
@@ -873,7 +938,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)
@@ -929,7 +994,8 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
read-symbol-positions-list
(byte-compile-delete-first
entry read-symbol-positions-list)))
- (or (and allow-previous (not (= last byte-compile-last-position)))
+ (or (and allow-previous
+ (not (= last byte-compile-last-position)))
(> last byte-compile-last-position)))))))
(defvar byte-compile-last-warned-form nil)
@@ -941,7 +1007,8 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(let* ((inhibit-read-only t)
(dir default-directory)
(file (cond ((stringp byte-compile-current-file)
- (format "%s:" (file-relative-name byte-compile-current-file dir)))
+ (format "%s:" (file-relative-name
+ byte-compile-current-file dir)))
((bufferp byte-compile-current-file)
(format "Buffer %s:"
(buffer-name byte-compile-current-file)))
@@ -975,19 +1042,19 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
;; This no-op function is used as the value of warning-series
;; to tell inner calls to displaying-byte-compile-warnings
;; not to bind warning-series.
-(defun byte-compile-warning-series (&rest ignore)
+(defun byte-compile-warning-series (&rest _ignore)
nil)
;; (compile-mode) will cause this to be loaded.
(declare-function compilation-forget-errors "compile" ())
-;; Log the start of a file in *Compile-Log*, and mark it as done.
+;; 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
@@ -1004,13 +1071,15 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(insert "\f\nCompiling "
(if (stringp byte-compile-current-file)
(concat "file " byte-compile-current-file)
- (concat "buffer " (buffer-name byte-compile-current-file)))
+ (concat "buffer "
+ (buffer-name byte-compile-current-file)))
" at " (current-time-string) "\n")
(insert "\f\nCompiling no file at " (current-time-string) "\n"))
(when dir
(setq default-directory dir)
(unless was-same
- (insert (format "Entering directory `%s'\n" default-directory))))
+ (insert (format "Entering directory `%s'\n"
+ default-directory))))
(setq byte-compile-last-logged-file byte-compile-current-file
byte-compile-last-warned-form nil)
;; Do this after setting default-directory.
@@ -1018,14 +1087,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."
@@ -1057,13 +1126,6 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(byte-compile-log-warning
(error-message-string error-info)
nil :error))
-
-;;; Used by make-obsolete.
-(defun byte-compile-obsolete (form)
- (byte-compile-set-symbol-position (car form))
- (byte-compile-warn-obsolete (car form))
- (funcall (or (cadr (get (car form) 'byte-obsolete-info)) ; handler
- 'byte-compile-normal-call) form))
;;; sanity-checking arglists
@@ -1103,22 +1165,28 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(t fn)))))))
(defun byte-compile-arglist-signature (arglist)
- (let ((args 0)
- opts
- restp)
- (while arglist
- (cond ((eq (car arglist) '&optional)
- (or opts (setq opts 0)))
- ((eq (car arglist) '&rest)
- (if (cdr arglist)
- (setq restp t
- arglist nil)))
- (t
- (if opts
- (setq opts (1+ opts))
+ (if (integerp arglist)
+ ;; New style byte-code arglist.
+ (cons (logand arglist 127) ;Mandatory.
+ (if (zerop (logand arglist 128)) ;No &rest.
+ (lsh arglist -8))) ;Nonrest.
+ ;; Old style byte-code, or interpreted function.
+ (let ((args 0)
+ opts
+ restp)
+ (while arglist
+ (cond ((eq (car arglist) '&optional)
+ (or opts (setq opts 0)))
+ ((eq (car arglist) '&rest)
+ (if (cdr arglist)
+ (setq restp t
+ arglist nil)))
+ (t
+ (if opts
+ (setq opts (1+ opts))
(setq args (1+ args)))))
- (setq arglist (cdr arglist)))
- (cons args (if restp nil (if opts (+ args opts) args)))))
+ (setq arglist (cdr arglist)))
+ (cons args (if restp nil (if opts (+ args opts) args))))))
(defun byte-compile-arglist-signatures-congruent-p (old new)
@@ -1237,7 +1305,7 @@ extra args."
(custom-declare-variable . defcustom))))
(cadr name)))
;; Update the current group, if needed.
- (if (and byte-compile-current-file ;Only when byte-compiling a whole file.
+ (if (and byte-compile-current-file ;Only when compiling a whole file.
(eq (car form) 'custom-declare-group)
(eq (car-safe name) 'quote))
(setq byte-compile-current-group (cadr name))))))
@@ -1245,50 +1313,61 @@ extra args."
;; Warn if the function or macro is being redefined with a different
;; number of arguments.
(defun byte-compile-arglist-warn (form macrop)
- (let ((old (byte-compile-fdefinition (nth 1 form) macrop)))
+ (let* ((name (nth 1 form))
+ (old (byte-compile-fdefinition name macrop))
+ (initial (and macrop
+ (cdr (assq name
+ byte-compile-initial-macro-environment)))))
+ ;; Assumes an element of b-c-i-macro-env that is a symbol points
+ ;; to a defined function. (Bug#8646)
+ (and initial (symbolp initial)
+ (setq old (byte-compile-fdefinition initial nil)))
(if (and old (not (eq old t)))
(progn
(and (eq 'macro (car-safe old))
(eq 'lambda (car-safe (cdr-safe old)))
(setq old (cdr old)))
(let ((sig1 (byte-compile-arglist-signature
- (if (eq 'lambda (car-safe old))
- (nth 1 old)
- (if (byte-code-function-p old)
- (aref old 0)
- '(&rest def)))))
+ (pcase old
+ (`(lambda ,args . ,_) args)
+ (`(closure ,_ ,args . ,_) args)
+ ((pred byte-code-function-p) (aref old 0))
+ (t '(&rest def)))))
(sig2 (byte-compile-arglist-signature (nth 2 form))))
(unless (byte-compile-arglist-signatures-congruent-p sig1 sig2)
- (byte-compile-set-symbol-position (nth 1 form))
+ (byte-compile-set-symbol-position name)
(byte-compile-warn
"%s %s used to take %s %s, now takes %s"
(if (eq (car form) 'defun) "function" "macro")
- (nth 1 form)
+ name
(byte-compile-arglist-signature-string sig1)
(if (equal sig1 '(1 . 1)) "argument" "arguments")
(byte-compile-arglist-signature-string sig2)))))
;; This is the first definition. See if previous calls are compatible.
- (let ((calls (assq (nth 1 form) byte-compile-unresolved-functions))
+ (let ((calls (assq name byte-compile-unresolved-functions))
nums sig min max)
- (if calls
- (progn
- (setq sig (byte-compile-arglist-signature (nth 2 form))
- nums (sort (copy-sequence (cdr calls)) (function <))
- min (car nums)
- max (car (nreverse nums)))
- (when (or (< min (car sig))
- (and (cdr sig) (> max (cdr sig))))
- (byte-compile-set-symbol-position (nth 1 form))
- (byte-compile-warn
- "%s being defined to take %s%s, but was previously called with %s"
- (nth 1 form)
- (byte-compile-arglist-signature-string sig)
- (if (equal sig '(1 . 1)) " arg" " args")
- (byte-compile-arglist-signature-string (cons min max))))
-
- (setq byte-compile-unresolved-functions
- (delq calls byte-compile-unresolved-functions)))))
- )))
+ (when calls
+ (when (and (symbolp name)
+ (eq (get name 'byte-optimizer)
+ 'byte-compile-inline-expand))
+ (byte-compile-warn "defsubst `%s' was used before it was defined"
+ name))
+ (setq sig (byte-compile-arglist-signature (nth 2 form))
+ nums (sort (copy-sequence (cdr calls)) (function <))
+ min (car nums)
+ max (car (nreverse nums)))
+ (when (or (< min (car sig))
+ (and (cdr sig) (> max (cdr sig))))
+ (byte-compile-set-symbol-position name)
+ (byte-compile-warn
+ "%s being defined to take %s%s, but was previously called with %s"
+ name
+ (byte-compile-arglist-signature-string sig)
+ (if (equal sig '(1 . 1)) " arg" " args")
+ (byte-compile-arglist-signature-string (cons min max))))
+
+ (setq byte-compile-unresolved-functions
+ (delq calls byte-compile-unresolved-functions)))))))
(defvar byte-compile-cl-functions nil
"List of functions defined in CL.")
@@ -1324,15 +1403,8 @@ extra args."
;; but such warnings are never useful,
;; so don't warn about them.
macroexpand cl-macroexpand-all
- cl-compiling-file)))
- ;; Avoid warnings for things which are safe because they
- ;; have suitable compiler macros, but those aren't
- ;; expanded at this stage. There should probably be more
- ;; here than caaar and friends.
- (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"
+ cl-compiling-file))))
+ (byte-compile-warn "function `%s' from cl package called at runtime"
func)))
form)
@@ -1394,7 +1466,7 @@ symbol itself."
(if any-value
(or (memq symbol byte-compile-const-variables)
;; FIXME: We should provide a less intrusive way to find out
- ;; is a variable is "constant".
+ ;; if a variable is "constant".
(and (boundp symbol)
(condition-case nil
(progn (set symbol (symbol-value symbol)) nil)
@@ -1407,6 +1479,7 @@ symbol itself."
((byte-compile-const-symbol-p ,form))))
(defmacro byte-compile-close-variables (&rest body)
+ (declare (debug t))
(cons 'let
(cons '(;;
;; Close over these variables to encapsulate the
@@ -1437,11 +1510,12 @@ symbol itself."
body)))
(defmacro displaying-byte-compile-warnings (&rest body)
+ (declare (debug t))
`(let* ((--displaying-byte-compile-warnings-fn (lambda () ,@body))
(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)
@@ -1474,41 +1548,33 @@ Files in subdirectories of DIRECTORY are processed also."
(interactive "DByte force recompile (directory): ")
(byte-recompile-directory directory nil t))
-;; The `bytecomp-' prefix is applied to all local variables with
-;; otherwise common names in this and similar functions for the sake
-;; of the boundp test in byte-compile-variable-ref.
-;; http://lists.gnu.org/archive/html/emacs-devel/2008-01/msg00237.html
-;; http://lists.gnu.org/archive/html/bug-gnu-emacs/2008-02/msg00134.html
-;; Note that similar considerations apply to command-line-1 in startup.el.
;;;###autoload
-(defun byte-recompile-directory (bytecomp-directory &optional bytecomp-arg
- bytecomp-force)
- "Recompile every `.el' file in BYTECOMP-DIRECTORY that needs recompilation.
+(defun byte-recompile-directory (directory &optional arg force)
+ "Recompile every `.el' file in DIRECTORY that needs recompilation.
This happens when a `.elc' file exists but is older than the `.el' file.
-Files in subdirectories of BYTECOMP-DIRECTORY are processed also.
+Files in subdirectories of DIRECTORY are processed also.
If the `.elc' file does not exist, normally this function *does not*
compile the corresponding `.el' file. However, if the prefix argument
-BYTECOMP-ARG is 0, that means do compile all those files. A nonzero
-BYTECOMP-ARG means ask the user, for each such `.el' file, whether to
-compile it. A nonzero BYTECOMP-ARG also means ask about each subdirectory
+ARG is 0, that means do compile all those files. A nonzero
+ARG means ask the user, for each such `.el' file, whether to
+compile it. A nonzero ARG also means ask about each subdirectory
before scanning it.
-If the third argument BYTECOMP-FORCE is non-nil, recompile every `.el' file
+If the third argument FORCE is non-nil, recompile every `.el' file
that already has a `.elc' file."
(interactive "DByte recompile directory: \nP")
- (if bytecomp-arg
- (setq bytecomp-arg (prefix-numeric-value bytecomp-arg)))
+ (if arg (setq arg (prefix-numeric-value arg)))
(if noninteractive
nil
(save-some-buffers)
(force-mode-line-update))
- (with-current-buffer (get-buffer-create "*Compile-Log*")
- (setq default-directory (expand-file-name bytecomp-directory))
+ (with-current-buffer (get-buffer-create byte-compile-log-buffer)
+ (setq default-directory (expand-file-name directory))
;; compilation-mode copies value of default-directory.
(unless (eq major-mode 'compilation-mode)
(compilation-mode))
- (let ((bytecomp-directories (list default-directory))
+ (let ((directories (list default-directory))
(default-directory default-directory)
(skip-count 0)
(fail-count 0)
@@ -1516,57 +1582,36 @@ that already has a `.elc' file."
(dir-count 0)
last-dir)
(displaying-byte-compile-warnings
- (while bytecomp-directories
- (setq bytecomp-directory (car bytecomp-directories))
- (message "Checking %s..." bytecomp-directory)
- (let ((bytecomp-files (directory-files bytecomp-directory))
- bytecomp-source bytecomp-dest)
- (dolist (bytecomp-file bytecomp-files)
- (setq bytecomp-source
- (expand-file-name bytecomp-file bytecomp-directory))
- (if (and (not (member bytecomp-file '("RCS" "CVS")))
- (not (eq ?\. (aref bytecomp-file 0)))
- (file-directory-p bytecomp-source)
- (not (file-symlink-p bytecomp-source)))
- ;; This file is a subdirectory. Handle them differently.
- (when (or (null bytecomp-arg)
- (eq 0 bytecomp-arg)
- (y-or-n-p (concat "Check " bytecomp-source "? ")))
- (setq bytecomp-directories
- (nconc bytecomp-directories (list bytecomp-source))))
- ;; It is an ordinary file. Decide whether to compile it.
- (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)))
- (cond ((eq bytecomp-res 'no-byte-compile)
- (setq skip-count (1+ skip-count)))
- ((eq bytecomp-res t)
- (setq file-count (1+ file-count)))
- ((eq bytecomp-res nil)
- (setq fail-count (1+ fail-count)))))
- (or noninteractive
- (message "Checking %s..." bytecomp-directory))
- (if (not (eq last-dir bytecomp-directory))
- (setq last-dir bytecomp-directory
- dir-count (1+ dir-count)))
- )))))
- (setq bytecomp-directories (cdr bytecomp-directories))))
+ (while directories
+ (setq directory (car directories))
+ (message "Checking %s..." directory)
+ (dolist (file (directory-files directory))
+ (let ((source (expand-file-name file directory)))
+ (if (and (not (member file '("RCS" "CVS")))
+ (not (eq ?\. (aref file 0)))
+ (file-directory-p source)
+ (not (file-symlink-p source)))
+ ;; This file is a subdirectory. Handle them differently.
+ (when (or (null arg) (eq 0 arg)
+ (y-or-n-p (concat "Check " source "? ")))
+ (setq directories (nconc directories (list source))))
+ ;; It is an ordinary file. Decide whether to compile it.
+ (if (and (string-match emacs-lisp-file-regexp source)
+ (file-readable-p source)
+ (not (auto-save-file-name-p source))
+ (not (string-equal dir-locals-file
+ (file-name-nondirectory source))))
+ (progn (case (byte-recompile-file source force arg)
+ (no-byte-compile (setq skip-count (1+ skip-count)))
+ ((t) (setq file-count (1+ file-count)))
+ ((nil) (setq fail-count (1+ fail-count))))
+ (or noninteractive
+ (message "Checking %s..." directory))
+ (if (not (eq last-dir directory))
+ (setq last-dir directory
+ dir-count (1+ dir-count)))
+ )))))
+ (setq directories (cdr directories))))
(message "Done (Total of %d file%s compiled%s%s%s)"
file-count (if (= file-count 1) "" "s")
(if (> fail-count 0) (format ", %d failed" fail-count) "")
@@ -1578,50 +1623,100 @@ that already has a `.elc' file."
"Non-nil to prevent byte-compiling of Emacs Lisp code.
This is normally set in local file variables at the end of the elisp file:
-;; Local Variables:\n;; no-byte-compile: t\n;; End: ")
+\;; Local Variables:\n;; no-byte-compile: t\n;; End: ") ;Backslash for compile-main.
;;;###autoload(put 'no-byte-compile 'safe-local-variable 'booleanp)
+(defun byte-recompile-file (filename &optional force arg load)
+ "Recompile 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 FILENAME. However, if the
+prefix argument FORCE is set, that means do compile
+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 FILENAME. If ARG is 0, that means
+compile the file even if it has never been compiled before.
+A nonzero 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 ((file buffer-file-name)
+ (file-name nil)
+ (file-dir nil))
+ (and file
+ (derived-mode-p 'emacs-lisp-mode)
+ (setq file-name (file-name-nondirectory file)
+ file-dir (file-name-directory file)))
+ (list (read-file-name (if current-prefix-arg
+ "Byte compile file: "
+ "Byte recompile file: ")
+ file-dir file-name nil)
+ current-prefix-arg)))
+ (let ((dest (byte-compile-dest-file filename))
+ ;; Expand now so we get the current buffer's defaults
+ (filename (expand-file-name filename)))
+ (if (if (file-exists-p dest)
+ ;; File was already compiled
+ ;; Compile if forced to, or filename newer
+ (or force
+ (file-newer-than-file-p filename dest))
+ (and arg
+ (or (eq 0 arg)
+ (y-or-n-p (concat "Compile "
+ filename "? ")))))
+ (progn
+ (if (and noninteractive (not byte-compile-verbose))
+ (message "Compiling %s..." filename))
+ (byte-compile-file filename load))
+ (when load (load 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.
-The output file's name is generated by passing BYTECOMP-FILENAME to the
+(defun byte-compile-file (filename &optional load)
+ "Compile a file of Lisp code named FILENAME into a file of byte code.
+The output file's name is generated by passing FILENAME to the
function `byte-compile-dest-file' (which see).
With prefix arg (noninteractively: 2nd arg), LOAD the file after compiling.
The value is non-nil if there were no errors, nil if errors."
;; (interactive "fByte compile file: \nP")
(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)))
+ (let ((file buffer-file-name)
+ (file-name nil)
+ (file-dir nil))
+ (and file
+ (derived-mode-p 'emacs-lisp-mode)
+ (setq file-name (file-name-nondirectory file)
+ file-dir (file-name-directory file)))
(list (read-file-name (if current-prefix-arg
"Byte compile and load file: "
"Byte compile file: ")
- bytecomp-file-dir bytecomp-file-name nil)
+ file-dir file-name nil)
current-prefix-arg)))
;; Expand now so we get the current buffer's defaults
- (setq bytecomp-filename (expand-file-name bytecomp-filename))
+ (setq filename (expand-file-name filename))
;; If we're compiling a file that's in a buffer and is modified, offer
;; to save it first.
(or noninteractive
- (let ((b (get-file-buffer (expand-file-name bytecomp-filename))))
+ (let ((b (get-file-buffer (expand-file-name filename))))
(if (and b (buffer-modified-p b)
(y-or-n-p (format "Save buffer %s first? " (buffer-name b))))
(with-current-buffer b (save-buffer)))))
;; Force logging of the file name for each file compiled.
(setq byte-compile-last-logged-file nil)
- (let ((byte-compile-current-file bytecomp-filename)
+ (let ((byte-compile-current-file filename)
(byte-compile-current-group nil)
(set-auto-coding-for-load t)
target-file input-buffer output-buffer
byte-compile-dest-file)
- (setq target-file (byte-compile-dest-file bytecomp-filename))
+ (setq target-file (byte-compile-dest-file filename))
(setq byte-compile-dest-file target-file)
(with-current-buffer
(setq input-buffer (get-buffer-create " *Compiler Input*"))
@@ -1630,7 +1725,7 @@ The value is non-nil if there were no errors, nil if errors."
;; Always compile an Emacs Lisp file as multibyte
;; unless the file itself forces unibyte with -*-coding: raw-text;-*-
(set-buffer-multibyte t)
- (insert-file-contents bytecomp-filename)
+ (insert-file-contents filename)
;; Mimic the way after-insert-file-set-coding can make the
;; buffer unibyte when visiting this file.
(when (or (eq last-coding-system-used 'no-conversion)
@@ -1640,7 +1735,7 @@ The value is non-nil if there were no errors, nil if errors."
(set-buffer-multibyte nil))
;; Run hooks including the uncompression hook.
;; If they change the file name, then change it for the output also.
- (letf ((buffer-file-name bytecomp-filename)
+ (letf ((buffer-file-name filename)
((default-value 'major-mode) 'emacs-lisp-mode)
;; Ignore unsafe local variables.
;; We only care about a few of them for our purposes.
@@ -1648,15 +1743,15 @@ The value is non-nil if there were no errors, nil if errors."
(enable-local-eval nil))
;; Arg of t means don't alter enable-local-variables.
(normal-mode t)
- (setq bytecomp-filename buffer-file-name))
+ (setq filename buffer-file-name))
;; Set the default directory, in case an eval-when-compile uses it.
- (setq default-directory (file-name-directory bytecomp-filename)))
+ (setq default-directory (file-name-directory filename)))
;; Check if the file's local variables explicitly specify not to
;; compile this file.
(if (with-current-buffer input-buffer no-byte-compile)
(progn
;; (message "%s not compiled because of `no-byte-compile: %s'"
- ;; (file-relative-name bytecomp-filename)
+ ;; (file-relative-name filename)
;; (with-current-buffer input-buffer no-byte-compile))
(when (file-exists-p target-file)
(message "%s deleted because of `no-byte-compile: %s'"
@@ -1666,35 +1761,46 @@ The value is non-nil if there were no errors, nil if errors."
;; We successfully didn't compile this file.
'no-byte-compile)
(when byte-compile-verbose
- (message "Compiling %s..." bytecomp-filename))
+ (message "Compiling %s..." filename))
(setq byte-compiler-error-flag nil)
;; It is important that input-buffer not be current at this call,
;; so that the value of point set in input-buffer
;; within byte-compile-from-buffer lingers in that buffer.
(setq output-buffer
(save-current-buffer
- (byte-compile-from-buffer input-buffer bytecomp-filename)))
+ (byte-compile-from-buffer input-buffer)))
(if byte-compiler-error-flag
nil
(when byte-compile-verbose
- (message "Compiling %s...done" bytecomp-filename))
+ (message "Compiling %s...done" filename))
(kill-buffer input-buffer)
(with-current-buffer output-buffer
(goto-char (point-max))
(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"
@@ -1706,9 +1812,9 @@ The value is non-nil if there were no errors, nil if errors."
(if (and byte-compile-generate-call-tree
(or (eq t byte-compile-generate-call-tree)
(y-or-n-p (format "Report call tree for %s? "
- bytecomp-filename))))
+ filename))))
(save-excursion
- (display-call-tree bytecomp-filename)))
+ (display-call-tree filename)))
(if load
(load target-file))
t))))
@@ -1732,18 +1838,21 @@ With argument ARG, insert value in current buffer after the form."
(let ((read-with-symbol-positions (current-buffer))
(read-symbol-positions-list nil))
(displaying-byte-compile-warnings
- (byte-compile-sexp (read (current-buffer))))))))
+ (byte-compile-sexp (read (current-buffer)))))
+ lexical-binding)))
(cond (arg
(message "Compiling from buffer... done.")
(prin1 value (current-buffer))
(insert "\n"))
((message "%s" (prin1-to-string value)))))))
+;; Dynamically bound in byte-compile-from-buffer.
+;; NB also used in cl.el and cl-macs.el.
+(defvar byte-compile--outbuffer)
-(defun byte-compile-from-buffer (bytecomp-inbuffer &optional bytecomp-filename)
- ;; Filename is used for the loading-into-Emacs-18 error message.
- (let (bytecomp-outbuffer
- (byte-compile-current-buffer bytecomp-inbuffer)
+(defun byte-compile-from-buffer (inbuffer)
+ (let (byte-compile--outbuffer
+ (byte-compile-current-buffer inbuffer)
(byte-compile-read-position nil)
(byte-compile-last-position nil)
;; Prevent truncation of flonums and lists as we read and print them
@@ -1764,29 +1873,24 @@ With argument ARG, insert value in current buffer after the form."
(byte-compile-output nil)
;; This allows us to get the positions of symbols read; it's
;; new in Emacs 22.1.
- (read-with-symbol-positions bytecomp-inbuffer)
+ (read-with-symbol-positions inbuffer)
(read-symbol-positions-list nil)
;; #### This is bound in b-c-close-variables.
;; (byte-compile-warnings byte-compile-warnings)
)
(byte-compile-close-variables
(with-current-buffer
- (setq bytecomp-outbuffer (get-buffer-create " *Compiler Output*"))
+ (setq byte-compile--outbuffer
+ (get-buffer-create " *Compiler Output*"))
(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
- (byte-compile-insert-header bytecomp-filename bytecomp-outbuffer))
+ (with-current-buffer inbuffer
+ (and byte-compile-current-file
+ (byte-compile-insert-header byte-compile-current-file
+ byte-compile--outbuffer))
(goto-char (point-min))
;; Should we always do this? When calling multiple files, it
;; would be useful to delay this warning until all have been
@@ -1803,13 +1907,13 @@ With argument ARG, insert value in current buffer after the form."
(setq byte-compile-read-position (point)
byte-compile-last-position byte-compile-read-position)
(let* ((old-style-backquotes nil)
- (form (read bytecomp-inbuffer)))
+ (form (read inbuffer)))
;; Warn about the use of old-style backquotes.
(when old-style-backquotes
(byte-compile-warn "!! The file uses old-style backquotes !!
This functionality has been obsolete for more than 10 years already
and will be removed soon. See (elisp)Backquote in the manual."))
- (byte-compile-file-form form)))
+ (byte-compile-toplevel-file-form form)))
;; Compile pending forms at end of file.
(byte-compile-flush-pending)
;; Make warnings about unresolved functions
@@ -1818,10 +1922,10 @@ and will be removed soon. See (elisp)Backquote in the manual."))
(byte-compile-warn-about-unresolved-functions))
;; Fix up the header at the front of the output
;; if the buffer contains multibyte characters.
- (and bytecomp-filename
- (with-current-buffer bytecomp-outbuffer
- (byte-compile-fix-header bytecomp-filename)))))
- bytecomp-outbuffer))
+ (and byte-compile-current-file
+ (with-current-buffer byte-compile--outbuffer
+ (byte-compile-fix-header byte-compile-current-file)))))
+ byte-compile--outbuffer))
(defun byte-compile-fix-header (filename)
"If the current buffer has any multibyte characters, insert a version test."
@@ -1909,10 +2013,6 @@ Call from the source buffer."
";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n\n"))))
-;; Dynamically bound in byte-compile-from-buffer.
-;; NB also used in cl.el and cl-macs.el.
-(defvar bytecomp-outbuffer)
-
(defun byte-compile-output-file-form (form)
;; writes the given form to the output buffer, being careful of docstrings
;; in defun, defmacro, defvar, defvaralias, defconst, autoload and
@@ -1920,8 +2020,8 @@ Call from the source buffer."
;; defalias calls are output directly by byte-compile-file-form-defmumble;
;; it does not pay to first build the defalias in defmumble and then parse
;; it here.
- (if (and (memq (car-safe form) '(defun defmacro defvar defvaralias defconst autoload
- custom-declare-variable))
+ (if (and (memq (car-safe form) '(defun defmacro defvar defvaralias defconst
+ autoload custom-declare-variable))
(stringp (nth 3 form)))
(byte-compile-output-docform nil nil '("\n(" 3 ")") form nil
(memq (car form)
@@ -1934,11 +2034,12 @@ Call from the source buffer."
(print-gensym t)
(print-circle ; handle circular data structures
(not byte-compile-disable-print-circle)))
- (princ "\n" bytecomp-outbuffer)
- (prin1 form bytecomp-outbuffer)
+ (princ "\n" byte-compile--outbuffer)
+ (prin1 form byte-compile--outbuffer)
nil)))
(defvar print-gensym-alist) ;Used before print-circle existed.
+(defvar byte-compile--for-effect)
(defun byte-compile-output-docform (preface name info form specindex quoted)
"Print a form with a doc string. INFO is (prefix doc-index postfix).
@@ -1954,7 +2055,7 @@ list that represents a doc string reference.
;; We need to examine byte-compile-dynamic-docstrings
;; in the input buffer (now current), not in the output buffer.
(let ((dynamic-docstrings byte-compile-dynamic-docstrings))
- (with-current-buffer bytecomp-outbuffer
+ (with-current-buffer byte-compile--outbuffer
(let (position)
;; Insert the doc string, and make it a comment with #@LENGTH.
@@ -1978,7 +2079,7 @@ list that represents a doc string reference.
(if preface
(progn
(insert preface)
- (prin1 name bytecomp-outbuffer)))
+ (prin1 name byte-compile--outbuffer)))
(insert (car info))
(let ((print-escape-newlines t)
(print-quoted t)
@@ -1993,7 +2094,7 @@ list that represents a doc string reference.
(print-continuous-numbering t)
print-number-table
(index 0))
- (prin1 (car form) bytecomp-outbuffer)
+ (prin1 (car form) byte-compile--outbuffer)
(while (setq form (cdr form))
(setq index (1+ index))
(insert " ")
@@ -2003,9 +2104,9 @@ list that represents a doc string reference.
;; to objects already output
;; (for instance, gensyms in the arg list).
(let (non-nil)
- (dotimes (i (length print-number-table))
- (if (aref print-number-table i)
- (setq non-nil t)))
+ (when (hash-table-p print-number-table)
+ (maphash (lambda (_k v) (if v (setq non-nil t)))
+ print-number-table))
(not non-nil)))
;; Output the byte code and constants specially
;; for lazy dynamic loading.
@@ -2013,37 +2114,40 @@ list that represents a doc string reference.
(byte-compile-output-as-comment
(cons (car form) (nth 1 form))
t)))
- (setq position (- (position-bytes position) (point-min) -1))
- (princ (format "(#$ . %d) nil" position) bytecomp-outbuffer)
+ (setq position (- (position-bytes position)
+ (point-min) -1))
+ (princ (format "(#$ . %d) nil" position)
+ byte-compile--outbuffer)
(setq form (cdr form))
(setq index (1+ index))))
((= index (nth 1 info))
(if position
(princ (format (if quoted "'(#$ . %d)" "(#$ . %d)")
position)
- bytecomp-outbuffer)
+ byte-compile--outbuffer)
(let ((print-escape-newlines nil))
(goto-char (prog1 (1+ (point))
- (prin1 (car form) bytecomp-outbuffer)))
+ (prin1 (car form)
+ byte-compile--outbuffer)))
(insert "\\\n")
(goto-char (point-max)))))
(t
- (prin1 (car form) bytecomp-outbuffer)))))
+ (prin1 (car form) byte-compile--outbuffer)))))
(insert (nth 2 info)))))
nil)
-(defun byte-compile-keep-pending (form &optional bytecomp-handler)
+(defun byte-compile-keep-pending (form &optional handler)
(if (memq byte-optimize '(t source))
(setq form (byte-optimize-form form t)))
- (if bytecomp-handler
- (let ((for-effect t))
+ (if handler
+ (let ((byte-compile--for-effect t))
;; To avoid consing up monstrously large forms at load time, we split
;; the output regularly.
(and (memq (car-safe form) '(fset defalias))
(nthcdr 300 byte-compile-output)
(byte-compile-flush-pending))
- (funcall bytecomp-handler form)
- (if for-effect
+ (funcall handler form)
+ (if byte-compile--for-effect
(byte-compile-discard)))
(byte-compile-form form t))
nil)
@@ -2061,37 +2165,39 @@ list that represents a doc string reference.
byte-compile-maxdepth 0
byte-compile-output nil))))
+(defun byte-compile-preprocess (form &optional _for-effect)
+ (setq form (macroexpand-all form byte-compile-macro-environment))
+ ;; FIXME: We should run byte-optimize-form here, but it currently does not
+ ;; recurse through all the code, so we'd have to fix this first.
+ ;; Maybe a good fix would be to merge byte-optimize-form into
+ ;; macroexpand-all.
+ ;; (if (memq byte-optimize '(t source))
+ ;; (setq form (byte-optimize-form form for-effect)))
+ (if lexical-binding
+ (cconv-closure-convert form)
+ form))
+
+;; byte-hunk-handlers cannot call this!
+(defun byte-compile-toplevel-file-form (form)
+ (let ((byte-compile-current-form nil)) ; close over this for warnings.
+ (byte-compile-file-form (byte-compile-preprocess form t))))
+
+;; byte-hunk-handlers can call this.
(defun byte-compile-file-form (form)
- (let ((byte-compile-current-form nil) ; close over this for warnings.
- bytecomp-handler)
- (cond
- ((not (consp form))
- (byte-compile-keep-pending form))
- ((and (symbolp (car form))
- (setq bytecomp-handler (get (car form) 'byte-hunk-handler)))
- (cond ((setq form (funcall bytecomp-handler form))
- (byte-compile-flush-pending)
- (byte-compile-output-file-form form))))
- ((eq form (setq form (macroexpand form byte-compile-macro-environment)))
- (byte-compile-keep-pending form))
- (t
- (byte-compile-file-form form)))))
+ (let (handler)
+ (cond ((and (consp form)
+ (symbolp (car form))
+ (setq handler (get (car form) 'byte-hunk-handler)))
+ (cond ((setq form (funcall handler form))
+ (byte-compile-flush-pending)
+ (byte-compile-output-file-form form))))
+ (t
+ (byte-compile-keep-pending form)))))
;; Functions and variables with doc strings must be output separately,
;; so make-docfile can recognise them. Most other things can be output
;; as byte-code.
-(put 'defsubst 'byte-hunk-handler 'byte-compile-file-form-defsubst)
-(defun byte-compile-file-form-defsubst (form)
- (when (assq (nth 1 form) byte-compile-unresolved-functions)
- (setq byte-compile-current-form (nth 1 form))
- (byte-compile-warn "defsubst `%s' was used before it was defined"
- (nth 1 form)))
- (byte-compile-file-form
- (macroexpand form byte-compile-macro-environment))
- ;; Return nil so the form is not output twice.
- nil)
-
(put 'autoload 'byte-hunk-handler 'byte-compile-file-form-autoload)
(defun byte-compile-file-form-autoload (form)
(and (let ((form form))
@@ -2131,6 +2237,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))
@@ -2140,7 +2251,8 @@ list that represents a doc string reference.
(byte-compile-top-level (nth 2 form) nil 'file))))
form))
-(put 'define-abbrev-table 'byte-hunk-handler 'byte-compile-file-form-define-abbrev-table)
+(put 'define-abbrev-table 'byte-hunk-handler
+ 'byte-compile-file-form-define-abbrev-table)
(defun byte-compile-file-form-define-abbrev-table (form)
(if (eq 'quote (car-safe (car-safe (cdr form))))
(push (car-safe (cdr (cadr form))) byte-compile-bound-variables))
@@ -2238,51 +2350,49 @@ by side-effects."
res))
(defun byte-compile-file-form-defmumble (form macrop)
- (let* ((bytecomp-name (car (cdr form)))
- (bytecomp-this-kind (if macrop 'byte-compile-macro-environment
+ (let* ((name (car (cdr form)))
+ (this-kind (if macrop 'byte-compile-macro-environment
'byte-compile-function-environment))
- (bytecomp-that-kind (if macrop 'byte-compile-function-environment
+ (that-kind (if macrop 'byte-compile-function-environment
'byte-compile-macro-environment))
- (bytecomp-this-one (assq bytecomp-name
- (symbol-value bytecomp-this-kind)))
- (bytecomp-that-one (assq bytecomp-name
- (symbol-value bytecomp-that-kind)))
+ (this-one (assq name (symbol-value this-kind)))
+ (that-one (assq name (symbol-value that-kind)))
(byte-compile-free-references nil)
(byte-compile-free-assignments nil))
- (byte-compile-set-symbol-position bytecomp-name)
+ (byte-compile-set-symbol-position name)
;; When a function or macro is defined, add it to the call tree so that
;; we can tell when functions are not used.
(if byte-compile-generate-call-tree
- (or (assq bytecomp-name byte-compile-call-tree)
+ (or (assq name byte-compile-call-tree)
(setq byte-compile-call-tree
- (cons (list bytecomp-name nil nil) byte-compile-call-tree))))
+ (cons (list name nil nil) byte-compile-call-tree))))
- (setq byte-compile-current-form bytecomp-name) ; for warnings
+ (setq byte-compile-current-form name) ; for warnings
(if (byte-compile-warning-enabled-p 'redefine)
(byte-compile-arglist-warn form macrop))
(if byte-compile-verbose
- ;; bytecomp-filename is from byte-compile-from-buffer.
- (message "Compiling %s... (%s)" (or bytecomp-filename "") (nth 1 form)))
- (cond (bytecomp-that-one
+ (message "Compiling %s... (%s)"
+ (or byte-compile-current-file "") (nth 1 form)))
+ (cond (that-one
(if (and (byte-compile-warning-enabled-p 'redefine)
;; don't warn when compiling the stubs in byte-run...
(not (assq (nth 1 form)
byte-compile-initial-macro-environment)))
(byte-compile-warn
- "`%s' defined multiple times, as both function and macro"
- (nth 1 form)))
- (setcdr bytecomp-that-one nil))
- (bytecomp-this-one
+ "`%s' defined multiple times, as both function and macro"
+ (nth 1 form)))
+ (setcdr that-one nil))
+ (this-one
(when (and (byte-compile-warning-enabled-p 'redefine)
- ;; hack: don't warn when compiling the magic internal
- ;; byte-compiler macros in byte-run.el...
- (not (assq (nth 1 form)
- byte-compile-initial-macro-environment)))
+ ;; hack: don't warn when compiling the magic internal
+ ;; byte-compiler macros in byte-run.el...
+ (not (assq (nth 1 form)
+ byte-compile-initial-macro-environment)))
(byte-compile-warn "%s `%s' defined multiple times in this file"
(if macrop "macro" "function")
(nth 1 form))))
- ((and (fboundp bytecomp-name)
- (eq (car-safe (symbol-function bytecomp-name))
+ ((and (fboundp name)
+ (eq (car-safe (symbol-function name))
(if macrop 'lambda 'macro)))
(when (byte-compile-warning-enabled-p 'redefine)
(byte-compile-warn "%s `%s' being redefined as a %s"
@@ -2290,9 +2400,9 @@ by side-effects."
(nth 1 form)
(if macrop "macro" "function")))
;; shadow existing definition
- (set bytecomp-this-kind
- (cons (cons bytecomp-name nil)
- (symbol-value bytecomp-this-kind))))
+ (set this-kind
+ (cons (cons name nil)
+ (symbol-value this-kind))))
)
(let ((body (nthcdr 3 form)))
(when (and (stringp (car body))
@@ -2307,67 +2417,55 @@ by side-effects."
;; Remove declarations from the body of the macro definition.
(when macrop
(dolist (decl (byte-compile-defmacro-declaration form))
- (prin1 decl bytecomp-outbuffer)))
-
- (let* ((new-one (byte-compile-lambda (nthcdr 2 form) t))
- (code (byte-compile-byte-code-maker new-one)))
- (if bytecomp-this-one
- (setcdr bytecomp-this-one new-one)
- (set bytecomp-this-kind
- (cons (cons bytecomp-name new-one)
- (symbol-value bytecomp-this-kind))))
- (if (and (stringp (nth 3 form))
- (eq 'quote (car-safe code))
- (eq 'lambda (car-safe (nth 1 code))))
- (cons (car form)
- (cons bytecomp-name (cdr (nth 1 code))))
- (byte-compile-flush-pending)
- (if (not (stringp (nth 3 form)))
- ;; No doc string. Provide -1 as the "doc string index"
- ;; so that no element will be treated as a doc string.
- (byte-compile-output-docform
- "\n(defalias '"
- bytecomp-name
- (cond ((atom code)
- (if macrop '(" '(macro . #[" -1 "])") '(" #[" -1 "]")))
- ((eq (car code) 'quote)
- (setq code new-one)
- (if macrop '(" '(macro " -1 ")") '(" '(" -1 ")")))
- ((if macrop '(" (cons 'macro (" -1 "))") '(" (" -1 ")"))))
- (append code nil)
- (and (atom code) byte-compile-dynamic
- 1)
- nil)
- ;; Output the form by hand, that's much simpler than having
- ;; b-c-output-file-form analyze the defalias.
- (byte-compile-output-docform
- "\n(defalias '"
- bytecomp-name
- (cond ((atom code)
- (if macrop '(" '(macro . #[" 4 "])") '(" #[" 4 "]")))
- ((eq (car code) 'quote)
- (setq code new-one)
- (if macrop '(" '(macro " 2 ")") '(" '(" 2 ")")))
- ((if macrop '(" (cons 'macro (" 5 "))") '(" (" 5 ")"))))
- (append code nil)
- (and (atom code) byte-compile-dynamic
- 1)
- nil))
- (princ ")" bytecomp-outbuffer)
- nil))))
+ (prin1 decl byte-compile--outbuffer)))
+
+ (let* ((code (byte-compile-lambda (nthcdr 2 form) t)))
+ (if this-one
+ ;; A definition in b-c-initial-m-e should always take precedence
+ ;; during compilation, so don't let it be redefined. (Bug#8647)
+ (or (and macrop
+ (assq name byte-compile-initial-macro-environment))
+ (setcdr this-one code))
+ (set this-kind
+ (cons (cons name code)
+ (symbol-value this-kind))))
+ (byte-compile-flush-pending)
+ (if (not (stringp (nth 3 form)))
+ ;; No doc string. Provide -1 as the "doc string index"
+ ;; so that no element will be treated as a doc string.
+ (byte-compile-output-docform
+ "\n(defalias '"
+ name
+ (if macrop '(" '(macro . #[" -1 "])") '(" #[" -1 "]"))
+ (append code nil) ; Turn byte-code-function-p into list.
+ (and (atom code) byte-compile-dynamic
+ 1)
+ nil)
+ ;; Output the form by hand, that's much simpler than having
+ ;; b-c-output-file-form analyze the defalias.
+ (byte-compile-output-docform
+ "\n(defalias '"
+ name
+ (if macrop '(" '(macro . #[" 4 "])") '(" #[" 4 "]"))
+ (append code nil) ; Turn byte-code-function-p into list.
+ (and (atom code) byte-compile-dynamic
+ 1)
+ nil))
+ (princ ")" byte-compile--outbuffer)
+ nil)))
;; Print Lisp object EXP in the output file, inside a comment,
;; and return the file position it will have.
;; If QUOTED is non-nil, print with quoting; otherwise, print without quoting.
(defun byte-compile-output-as-comment (exp quoted)
(let ((position (point)))
- (with-current-buffer bytecomp-outbuffer
+ (with-current-buffer byte-compile--outbuffer
;; Insert EXP, and make it a comment with #@LENGTH.
(insert " ")
(if quoted
- (prin1 exp bytecomp-outbuffer)
- (princ exp bytecomp-outbuffer))
+ (prin1 exp byte-compile--outbuffer)
+ (princ exp byte-compile--outbuffer))
(goto-char position)
;; Quote certain special characters as needed.
;; get_doc_string in doc.c does the unquoting.
@@ -2409,6 +2507,10 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(if macro
(setq fun (cdr fun)))
(cond ((eq (car-safe fun) 'lambda)
+ ;; Expand macros.
+ (setq fun (byte-compile-preprocess fun))
+ ;; Get rid of the `function' quote added by the `lambda' macro.
+ (if (eq (car-safe fun) 'function) (setq fun (cadr fun)))
(setq fun (if macro
(cons 'macro (byte-compile-lambda fun))
(byte-compile-lambda fun)))
@@ -2420,56 +2522,7 @@ If FORM is a lambda or a macro, byte-compile it as a function."
"Compile and return SEXP."
(displaying-byte-compile-warnings
(byte-compile-close-variables
- (byte-compile-top-level sexp))))
-
-;; Given a function made by byte-compile-lambda, make a form which produces it.
-(defun byte-compile-byte-code-maker (fun)
- (cond
- ;; ## atom is faster than compiled-func-p.
- ((atom fun) ; compiled function.
- ;; generate-emacs19-bytecodes must be on, otherwise byte-compile-lambda
- ;; would have produced a lambda.
- fun)
- ;; b-c-lambda didn't produce a compiled-function, so it's either a trivial
- ;; function, or this is Emacs 18, or generate-emacs19-bytecodes is off.
- ((let (tmp)
- (if (and (setq tmp (assq 'byte-code (cdr-safe (cdr fun))))
- (null (cdr (memq tmp fun))))
- ;; Generate a make-byte-code call.
- (let* ((interactive (assq 'interactive (cdr (cdr fun)))))
- (nconc (list 'make-byte-code
- (list 'quote (nth 1 fun)) ;arglist
- (nth 1 tmp) ;bytes
- (nth 2 tmp) ;consts
- (nth 3 tmp)) ;depth
- (cond ((stringp (nth 2 fun))
- (list (nth 2 fun))) ;doc
- (interactive
- (list nil)))
- (cond (interactive
- (list (if (or (null (nth 1 interactive))
- (stringp (nth 1 interactive)))
- (nth 1 interactive)
- ;; Interactive spec is a list or a variable
- ;; (if it is correct).
- (list 'quote (nth 1 interactive))))))))
- ;; a non-compiled function (probably trivial)
- (list 'quote fun))))))
-
-;; Turn a function into an ordinary lambda. Needed for v18 files.
-(defun byte-compile-byte-code-unmake (function)
- (if (consp function)
- function;;It already is a lambda.
- (setq function (append function nil)) ; turn it into a list
- (nconc (list 'lambda (nth 0 function))
- (and (nth 4 function) (list (nth 4 function)))
- (if (nthcdr 5 function)
- (list (cons 'interactive (if (nth 5 function)
- (nthcdr 5 function)))))
- (list (list 'byte-code
- (nth 1 function) (nth 2 function)
- (nth 3 function))))))
-
+ (byte-compile-top-level (byte-compile-preprocess sexp)))))
(defun byte-compile-check-lambda-list (list)
"Check lambda-list LIST for errors."
@@ -2496,6 +2549,44 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(setq list (cdr list)))))
+(defun byte-compile-arglist-vars (arglist)
+ "Return a list of the variables in the lambda argument list ARGLIST."
+ (remq '&rest (remq '&optional arglist)))
+
+(defun byte-compile-make-lambda-lexenv (form)
+ "Return a new lexical environment for a lambda expression FORM."
+ ;; See if this is a closure or not
+ (let ((args (byte-compile-arglist-vars (cadr form))))
+ (let ((lexenv nil))
+ ;; Fill in the initial stack contents
+ (let ((stackpos 0))
+ ;; Add entries for each argument
+ (dolist (arg args)
+ (push (cons arg stackpos) lexenv)
+ (setq stackpos (1+ stackpos)))
+ ;; Return the new lexical environment
+ lexenv))))
+
+(defun byte-compile-make-args-desc (arglist)
+ (let ((mandatory 0)
+ nonrest (rest 0))
+ (while (and arglist (not (memq (car arglist) '(&optional &rest))))
+ (setq mandatory (1+ mandatory))
+ (setq arglist (cdr arglist)))
+ (setq nonrest mandatory)
+ (when (eq (car arglist) '&optional)
+ (setq arglist (cdr arglist))
+ (while (and arglist (not (eq (car arglist) '&rest)))
+ (setq nonrest (1+ nonrest))
+ (setq arglist (cdr arglist))))
+ (when arglist
+ (setq rest 1))
+ (if (> mandatory 127)
+ (byte-compile-report-error "Too many (>127) mandatory arguments")
+ (logior mandatory
+ (lsh nonrest 8)
+ (lsh rest 7)))))
+
;; Byte-compile a lambda-expression and return a valid function.
;; The value is usually a compiled function but may be the original
;; lambda-expression.
@@ -2503,78 +2594,87 @@ If FORM is a lambda or a macro, byte-compile it as a function."
;; of the list FUN and `byte-compile-set-symbol-position' is not called.
;; Use this feature to avoid calling `byte-compile-set-symbol-position'
;; for symbols generated by the byte compiler itself.
-(defun byte-compile-lambda (bytecomp-fun &optional add-lambda)
+(defun byte-compile-lambda (fun &optional add-lambda reserved-csts)
(if add-lambda
- (setq bytecomp-fun (cons 'lambda bytecomp-fun))
- (unless (eq 'lambda (car-safe bytecomp-fun))
- (error "Not a lambda list: %S" bytecomp-fun))
+ (setq fun (cons 'lambda fun))
+ (unless (eq 'lambda (car-safe fun))
+ (error "Not a lambda list: %S" fun))
(byte-compile-set-symbol-position 'lambda))
- (byte-compile-check-lambda-list (nth 1 bytecomp-fun))
- (let* ((bytecomp-arglist (nth 1 bytecomp-fun))
+ (byte-compile-check-lambda-list (nth 1 fun))
+ (let* ((arglist (nth 1 fun))
(byte-compile-bound-variables
- (nconc (and (byte-compile-warning-enabled-p 'free-vars)
- (delq '&rest
- (delq '&optional (copy-sequence bytecomp-arglist))))
- byte-compile-bound-variables))
- (bytecomp-body (cdr (cdr bytecomp-fun)))
- (bytecomp-doc (if (stringp (car bytecomp-body))
- (prog1 (car bytecomp-body)
- ;; Discard the doc string
- ;; unless it is the last element of the body.
- (if (cdr bytecomp-body)
- (setq bytecomp-body (cdr bytecomp-body))))))
- (bytecomp-int (assq 'interactive bytecomp-body)))
+ (append (and (not lexical-binding)
+ (byte-compile-arglist-vars arglist))
+ byte-compile-bound-variables))
+ (body (cdr (cdr fun)))
+ (doc (if (stringp (car body))
+ (prog1 (car body)
+ ;; Discard the doc string
+ ;; unless it is the last element of the body.
+ (if (cdr body)
+ (setq body (cdr body))))))
+ (int (assq 'interactive body)))
;; Process the interactive spec.
- (when bytecomp-int
+ (when int
(byte-compile-set-symbol-position 'interactive)
;; Skip (interactive) if it is in front (the most usual location).
- (if (eq bytecomp-int (car bytecomp-body))
- (setq bytecomp-body (cdr bytecomp-body)))
- (cond ((consp (cdr bytecomp-int))
- (if (cdr (cdr bytecomp-int))
+ (if (eq int (car body))
+ (setq body (cdr body)))
+ (cond ((consp (cdr int))
+ (if (cdr (cdr int))
(byte-compile-warn "malformed interactive spec: %s"
- (prin1-to-string bytecomp-int)))
+ (prin1-to-string int)))
;; If the interactive spec is a call to `list', don't
;; compile it, because `call-interactively' looks at the
;; args of `list'. Actually, compile it to get warnings,
;; but don't use the result.
- (let ((form (nth 1 bytecomp-int)))
+ (let* ((form (nth 1 int))
+ (newform (byte-compile-top-level form)))
(while (memq (car-safe form) '(let let* progn save-excursion))
(while (consp (cdr form))
(setq form (cdr form)))
(setq form (car form)))
- (if (eq (car-safe form) 'list)
- (byte-compile-top-level (nth 1 bytecomp-int))
- (setq bytecomp-int (list 'interactive
- (byte-compile-top-level
- (nth 1 bytecomp-int)))))))
- ((cdr bytecomp-int)
+ (if (and (eq (car-safe form) 'list)
+ ;; The spec is evaled in callint.c in dynamic-scoping
+ ;; mode, so just leaving the form unchanged would mean
+ ;; it won't be eval'd in the right mode.
+ (not lexical-binding))
+ nil
+ (setq int `(interactive ,newform)))))
+ ((cdr int)
(byte-compile-warn "malformed interactive spec: %s"
- (prin1-to-string bytecomp-int)))))
+ (prin1-to-string int)))))
;; Process the body.
- (let ((compiled (byte-compile-top-level
- (cons 'progn bytecomp-body) nil 'lambda)))
+ (let ((compiled
+ (byte-compile-top-level (cons 'progn body) nil 'lambda
+ ;; If doing lexical binding, push a new
+ ;; lexical environment containing just the
+ ;; args (since lambda expressions should be
+ ;; closed by now).
+ (and lexical-binding
+ (byte-compile-make-lambda-lexenv fun))
+ reserved-csts)))
;; Build the actual byte-coded function.
(if (eq 'byte-code (car-safe compiled))
- (apply 'make-byte-code
- (append (list bytecomp-arglist)
- ;; byte-string, constants-vector, stack depth
- (cdr compiled)
- ;; optionally, the doc string.
- (if (or bytecomp-doc bytecomp-int)
- (list bytecomp-doc))
- ;; optionally, the interactive spec.
- (if bytecomp-int
- (list (nth 1 bytecomp-int)))))
- (setq compiled
- (nconc (if bytecomp-int (list bytecomp-int))
- (cond ((eq (car-safe compiled) 'progn) (cdr compiled))
- (compiled (list compiled)))))
- (nconc (list 'lambda bytecomp-arglist)
- (if (or bytecomp-doc (stringp (car compiled)))
- (cons bytecomp-doc (cond (compiled)
- (bytecomp-body (list nil))))
- compiled))))))
+ (apply 'make-byte-code
+ (if lexical-binding
+ (byte-compile-make-args-desc arglist)
+ arglist)
+ (append
+ ;; byte-string, constants-vector, stack depth
+ (cdr compiled)
+ ;; optionally, the doc string.
+ (cond (lexical-binding
+ (require 'help-fns)
+ (list (help-add-fundoc-usage doc arglist)))
+ ((or doc int)
+ (list doc)))
+ ;; optionally, the interactive spec.
+ (if int
+ (list (nth 1 int)))))
+ (error "byte-compile-top-level did not return byte-code")))))
+
+(defvar byte-compile-reserved-constants 0)
(defun byte-compile-constants-vector ()
;; Builds the constants-vector from the current variables and constants.
@@ -2584,7 +2684,7 @@ If FORM is a lambda or a macro, byte-compile it as a function."
;; Next up to byte-constant-limit are constants, still with one-byte codes.
;; Next variables again, to get 2-byte codes for variable lookup.
;; The rest of the constants and variables need 3-byte byte-codes.
- (let* ((i -1)
+ (let* ((i (1- byte-compile-reserved-constants))
(rest (nreverse byte-compile-variables)) ; nreverse because the first
(other (nreverse byte-compile-constants)) ; vars often are used most.
ret tmp
@@ -2595,11 +2695,15 @@ If FORM is a lambda or a macro, byte-compile it as a function."
limit)
(while (or rest other)
(setq limit (car limits))
- (while (and rest (not (eq i limit)))
- (if (setq tmp (assq (car (car rest)) ret))
- (setcdr (car rest) (cdr tmp))
+ (while (and rest (< i limit))
+ (cond
+ ((numberp (car rest))
+ (assert (< (car rest) byte-compile-reserved-constants)))
+ ((setq tmp (assq (car (car rest)) ret))
+ (setcdr (car rest) (cdr tmp)))
+ (t
(setcdr (car rest) (setq i (1+ i)))
- (setq ret (cons (car rest) ret)))
+ (setq ret (cons (car rest) ret))))
(setq rest (cdr rest)))
(setq limits (cdr limits)
rest (prog1 other
@@ -2608,29 +2712,38 @@ If FORM is a lambda or a macro, byte-compile it as a function."
;; Given an expression FORM, compile it and return an equivalent byte-code
;; expression (a call to the function byte-code).
-(defun byte-compile-top-level (form &optional for-effect output-type)
+(defun byte-compile-top-level (form &optional for-effect output-type
+ lexenv reserved-csts)
;; OUTPUT-TYPE advises about how form is expected to be used:
;; 'eval or nil -> a single form,
;; 'progn or t -> a list of forms,
;; 'lambda -> body of a lambda,
;; 'file -> used at file-level.
- (let ((byte-compile-constants nil)
+ (let ((byte-compile--for-effect for-effect)
+ (byte-compile-constants nil)
(byte-compile-variables nil)
(byte-compile-tag-number 0)
(byte-compile-depth 0)
(byte-compile-maxdepth 0)
+ (byte-compile--lexical-environment lexenv)
+ (byte-compile-reserved-constants (or reserved-csts 0))
(byte-compile-output nil))
- (if (memq byte-optimize '(t source))
- (setq form (byte-optimize-form form for-effect)))
- (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form))))
- (setq form (nth 1 form)))
- (if (and (eq 'byte-code (car-safe form))
- (not (memq byte-optimize '(t byte)))
- (stringp (nth 1 form)) (vectorp (nth 2 form))
- (natnump (nth 3 form)))
- form
- (byte-compile-form form for-effect)
- (byte-compile-out-toplevel for-effect output-type))))
+ (if (memq byte-optimize '(t source))
+ (setq form (byte-optimize-form form byte-compile--for-effect)))
+ (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form))))
+ (setq form (nth 1 form)))
+ ;; Set up things for a lexically-bound function.
+ (when (and lexical-binding (eq output-type 'lambda))
+ ;; See how many arguments there are, and set the current stack depth
+ ;; accordingly.
+ (setq byte-compile-depth (length byte-compile--lexical-environment))
+ ;; If there are args, output a tag to record the initial
+ ;; stack-depth for the optimizer.
+ (when (> byte-compile-depth 0)
+ (byte-compile-out-tag (byte-compile-make-tag))))
+ ;; Now compile FORM
+ (byte-compile-form form byte-compile--for-effect)
+ (byte-compile-out-toplevel byte-compile--for-effect output-type)))
(defun byte-compile-out-toplevel (&optional for-effect output-type)
(if for-effect
@@ -2652,7 +2765,7 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(setq byte-compile-output (nreverse byte-compile-output))
(if (memq byte-optimize '(t byte))
(setq byte-compile-output
- (byte-optimize-lapcode byte-compile-output for-effect)))
+ (byte-optimize-lapcode byte-compile-output)))
;; Decompile trivial functions:
;; only constants and variables, or a single funcall except in lambdas.
@@ -2680,34 +2793,35 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(progn
(setq rest (nreverse
(cdr (memq tmp (reverse byte-compile-output)))))
- (while (cond
- ((memq (car (car rest)) '(byte-varref byte-constant))
- (setq tmp (car (cdr (car rest))))
- (if (if (eq (car (car rest)) 'byte-constant)
- (or (consp tmp)
- (and (symbolp tmp)
- (not (byte-compile-const-symbol-p tmp)))))
- (if maycall
- (setq body (cons (list 'quote tmp) body)))
- (setq body (cons tmp body))))
- ((and maycall
- ;; Allow a funcall if at most one atom follows it.
- (null (nthcdr 3 rest))
- (setq tmp (get (car (car rest)) 'byte-opcode-invert))
- (or (null (cdr rest))
- (and (memq output-type '(file progn t))
- (cdr (cdr rest))
- (eq (car (nth 1 rest)) 'byte-discard)
- (progn (setq rest (cdr rest)) t))))
- (setq maycall nil) ; Only allow one real function call.
- (setq body (nreverse body))
- (setq body (list
- (if (and (eq tmp 'funcall)
- (eq (car-safe (car body)) 'quote))
- (cons (nth 1 (car body)) (cdr body))
- (cons tmp body))))
- (or (eq output-type 'file)
- (not (delq nil (mapcar 'consp (cdr (car body))))))))
+ (while
+ (cond
+ ((memq (car (car rest)) '(byte-varref byte-constant))
+ (setq tmp (car (cdr (car rest))))
+ (if (if (eq (car (car rest)) 'byte-constant)
+ (or (consp tmp)
+ (and (symbolp tmp)
+ (not (byte-compile-const-symbol-p tmp)))))
+ (if maycall
+ (setq body (cons (list 'quote tmp) body)))
+ (setq body (cons tmp body))))
+ ((and maycall
+ ;; Allow a funcall if at most one atom follows it.
+ (null (nthcdr 3 rest))
+ (setq tmp (get (car (car rest)) 'byte-opcode-invert))
+ (or (null (cdr rest))
+ (and (memq output-type '(file progn t))
+ (cdr (cdr rest))
+ (eq (car (nth 1 rest)) 'byte-discard)
+ (progn (setq rest (cdr rest)) t))))
+ (setq maycall nil) ; Only allow one real function call.
+ (setq body (nreverse body))
+ (setq body (list
+ (if (and (eq tmp 'funcall)
+ (eq (car-safe (car body)) 'quote))
+ (cons (nth 1 (car body)) (cdr body))
+ (cons tmp body))))
+ (or (eq output-type 'file)
+ (not (delq nil (mapcar 'consp (cdr (car body))))))))
(setq rest (cdr rest)))
rest))
(let ((byte-compile-vector (byte-compile-constants-vector)))
@@ -2717,94 +2831,108 @@ If FORM is a lambda or a macro, byte-compile it as a function."
((cdr body) (cons 'progn (nreverse body)))
((car body)))))
-;; Given BYTECOMP-BODY, compile it and return a new body.
-(defun byte-compile-top-level-body (bytecomp-body &optional for-effect)
- (setq bytecomp-body
- (byte-compile-top-level (cons 'progn bytecomp-body) for-effect t))
- (cond ((eq (car-safe bytecomp-body) 'progn)
- (cdr bytecomp-body))
- (bytecomp-body
- (list bytecomp-body))))
-
-(put 'declare-function 'byte-hunk-handler 'byte-compile-declare-function)
-(defun byte-compile-declare-function (form)
- (push (cons (nth 1 form)
- (if (and (> (length form) 3)
- (listp (nth 3 form)))
- (list 'declared (nth 3 form))
+;; Given BODY, compile it and return a new body.
+(defun byte-compile-top-level-body (body &optional for-effect)
+ (setq body
+ (byte-compile-top-level (cons 'progn body) for-effect t))
+ (cond ((eq (car-safe body) 'progn)
+ (cdr body))
+ (body
+ (list body))))
+
+;; Special macro-expander used during byte-compilation.
+(defun byte-compile-macroexpand-declare-function (fn file &rest args)
+ (push (cons fn
+ (if (and (consp args) (listp (car args)))
+ (list 'declared (car args))
t)) ; arglist not specified
byte-compile-function-environment)
;; We are stating that it _will_ be defined at runtime.
(setq byte-compile-noruntime-functions
- (delq (nth 1 form) byte-compile-noruntime-functions))
- nil)
+ (delq fn byte-compile-noruntime-functions))
+ ;; Delegate the rest to the normal macro definition.
+ (macroexpand `(declare-function ,fn ,file ,@args)))
;; This is the recursive entry point for compiling each subform of an
;; expression.
;; If for-effect is non-nil, byte-compile-form will output a byte-discard
;; before terminating (ie no value will be left on the stack).
-;; A byte-compile handler may, when for-effect is non-nil, choose output code
-;; which does not leave a value on the stack, and then set for-effect to nil
-;; (to prevent byte-compile-form from outputting the byte-discard).
+;; A byte-compile handler may, when byte-compile--for-effect is non-nil, choose
+;; output code which does not leave a value on the stack, and then set
+;; byte-compile--for-effect to nil (to prevent byte-compile-form from
+;; outputting the byte-discard).
;; If a handler wants to call another handler, it should do so via
-;; byte-compile-form, or take extreme care to handle for-effect correctly.
-;; (Use byte-compile-form-do-effect to reset the for-effect flag too.)
+;; byte-compile-form, or take extreme care to handle byte-compile--for-effect
+;; correctly. (Use byte-compile-form-do-effect to reset the
+;; byte-compile--for-effect flag too.)
;;
(defun byte-compile-form (form &optional for-effect)
- (setq form (macroexpand form byte-compile-macro-environment))
- (cond ((not (consp form))
- (cond ((or (not (symbolp form)) (byte-compile-const-symbol-p form))
- (when (symbolp form)
- (byte-compile-set-symbol-position form))
- (byte-compile-constant form))
- ((and for-effect byte-compile-delete-errors)
- (when (symbolp form)
- (byte-compile-set-symbol-position form))
- (setq for-effect nil))
- (t (byte-compile-variable-ref 'byte-varref form))))
- ((symbolp (car form))
- (let* ((bytecomp-fn (car form))
- (bytecomp-handler (get bytecomp-fn 'byte-compile)))
- (when (byte-compile-const-symbol-p bytecomp-fn)
- (byte-compile-warn "`%s' called as a function" bytecomp-fn))
- (and (byte-compile-warning-enabled-p 'interactive-only)
- (memq bytecomp-fn byte-compile-interactive-only-functions)
- (byte-compile-warn "`%s' used from Lisp code\n\
-That command is designed for interactive use only" bytecomp-fn))
- (when (byte-compile-warning-enabled-p 'callargs)
- (if (memq bytecomp-fn
- '(custom-declare-group custom-declare-variable
- custom-declare-face))
- (byte-compile-nogroup-warn form))
- (byte-compile-callargs-warn form))
- (if (and bytecomp-handler
- ;; Make sure that function exists. This is important
- ;; for CL compiler macros since the symbol may be
- ;; `cl-byte-compile-compiler-macro' but if CL isn't
- ;; loaded, this function doesn't exist.
- (or (not (memq bytecomp-handler
- '(cl-byte-compile-compiler-macro)))
- (functionp bytecomp-handler)))
- (funcall bytecomp-handler form)
- (byte-compile-normal-call form))
- (if (byte-compile-warning-enabled-p 'cl-functions)
- (byte-compile-cl-warn form))))
- ((and (or (byte-code-function-p (car form))
- (eq (car-safe (car form)) 'lambda))
- ;; if the form comes out the same way it went in, that's
- ;; because it was malformed, and we couldn't unfold it.
- (not (eq form (setq form (byte-compile-unfold-lambda form)))))
- (byte-compile-form form for-effect)
- (setq for-effect nil))
- ((byte-compile-normal-call form)))
- (if for-effect
- (byte-compile-discard)))
+ (let ((byte-compile--for-effect for-effect))
+ (cond
+ ((not (consp form))
+ (cond ((or (not (symbolp form)) (byte-compile-const-symbol-p form))
+ (when (symbolp form)
+ (byte-compile-set-symbol-position form))
+ (byte-compile-constant form))
+ ((and byte-compile--for-effect byte-compile-delete-errors)
+ (when (symbolp form)
+ (byte-compile-set-symbol-position form))
+ (setq byte-compile--for-effect nil))
+ (t
+ (byte-compile-variable-ref form))))
+ ((symbolp (car form))
+ (let* ((fn (car form))
+ (handler (get fn 'byte-compile)))
+ (when (byte-compile-const-symbol-p fn)
+ (byte-compile-warn "`%s' called as a function" fn))
+ (and (byte-compile-warning-enabled-p 'interactive-only)
+ (memq fn byte-compile-interactive-only-functions)
+ (byte-compile-warn "`%s' used from Lisp code\n\
+That command is designed for interactive use only" fn))
+ (if (and (fboundp (car form))
+ (eq (car-safe (symbol-function (car form))) 'macro))
+ (byte-compile-report-error
+ (format "Forgot to expand macro %s" (car form))))
+ (if (and handler
+ ;; Make sure that function exists. This is important
+ ;; for CL compiler macros since the symbol may be
+ ;; `cl-byte-compile-compiler-macro' but if CL isn't
+ ;; loaded, this function doesn't exist.
+ (and (not (eq handler
+ ;; Already handled by macroexpand-all.
+ 'cl-byte-compile-compiler-macro))
+ (functionp handler)))
+ (funcall handler form)
+ (byte-compile-normal-call form))
+ (if (byte-compile-warning-enabled-p 'cl-functions)
+ (byte-compile-cl-warn form))))
+ ((and (byte-code-function-p (car form))
+ (memq byte-optimize '(t lap)))
+ (byte-compile-unfold-bcf form))
+ ((and (eq (car-safe (car form)) 'lambda)
+ ;; if the form comes out the same way it went in, that's
+ ;; because it was malformed, and we couldn't unfold it.
+ (not (eq form (setq form (byte-compile-unfold-lambda form)))))
+ (byte-compile-form form byte-compile--for-effect)
+ (setq byte-compile--for-effect nil))
+ ((byte-compile-normal-call form)))
+ (if byte-compile--for-effect
+ (byte-compile-discard))))
(defun byte-compile-normal-call (form)
+ (when (and (byte-compile-warning-enabled-p 'callargs)
+ (symbolp (car form)))
+ (if (memq (car form)
+ '(custom-declare-group custom-declare-variable
+ custom-declare-face))
+ (byte-compile-nogroup-warn form))
+ (when (get (car form) 'byte-obsolete-info)
+ (byte-compile-warn-obsolete (car form)))
+ (byte-compile-callargs-warn form))
(if byte-compile-generate-call-tree
(byte-compile-annotate-call-tree form))
- (when (and for-effect (eq (car form) 'mapcar)
+ (when (and byte-compile--for-effect (eq (car form) 'mapcar)
(byte-compile-warning-enabled-p 'mapcar))
(byte-compile-set-symbol-position 'mapcar)
(byte-compile-warn
@@ -2813,44 +2941,142 @@ That command is designed for interactive use only" bytecomp-fn))
(mapc 'byte-compile-form (cdr form)) ; wasteful, but faster.
(byte-compile-out 'byte-call (length (cdr form))))
-(defun byte-compile-variable-ref (base-op bytecomp-var)
- (when (symbolp bytecomp-var)
- (byte-compile-set-symbol-position bytecomp-var))
- (if (or (not (symbolp bytecomp-var))
- (byte-compile-const-symbol-p bytecomp-var
- (not (eq base-op 'byte-varref))))
- (if (byte-compile-warning-enabled-p 'constants)
- (byte-compile-warn
- (cond ((eq base-op 'byte-varbind) "attempt to let-bind %s `%s'")
- ((eq base-op 'byte-varset) "variable assignment to %s `%s'")
- (t "variable reference to %s `%s'"))
- (if (symbolp bytecomp-var) "constant" "nonvariable")
- (prin1-to-string bytecomp-var)))
- (and (get bytecomp-var 'byte-obsolete-variable)
- (not (memq bytecomp-var byte-compile-not-obsolete-vars))
- (byte-compile-warn-obsolete bytecomp-var))
- (if (eq base-op 'byte-varbind)
- (push bytecomp-var byte-compile-bound-variables)
- (or (not (byte-compile-warning-enabled-p 'free-vars))
- (boundp bytecomp-var)
- (memq bytecomp-var byte-compile-bound-variables)
- (if (eq base-op 'byte-varset)
- (or (memq bytecomp-var byte-compile-free-assignments)
- (progn
- (byte-compile-warn "assignment to free variable `%s'"
- bytecomp-var)
- (push bytecomp-var byte-compile-free-assignments)))
- (or (memq bytecomp-var byte-compile-free-references)
- (progn
- (byte-compile-warn "reference to free variable `%s'"
- bytecomp-var)
- (push bytecomp-var byte-compile-free-references)))))))
- (let ((tmp (assq bytecomp-var byte-compile-variables)))
+
+;; Splice the given lap code into the current instruction stream.
+;; If it has any labels in it, you're responsible for making sure there
+;; are no collisions, and that byte-compile-tag-number is reasonable
+;; after this is spliced in. The provided list is destroyed.
+(defun byte-compile-inline-lapcode (lap end-depth)
+ ;; "Replay" the operations: we used to just do
+ ;; (setq byte-compile-output (nconc (nreverse lap) byte-compile-output))
+ ;; but that fails to update byte-compile-depth, so we had to assume
+ ;; that `lap' ends up adding exactly 1 element to the stack. This
+ ;; happens to be true for byte-code generated by bytecomp.el without
+ ;; lexical-binding, but it's not true in general, and it's not true for
+ ;; code output by bytecomp.el with lexical-binding.
+ (let ((endtag (byte-compile-make-tag)))
+ (dolist (op lap)
+ (cond
+ ((eq (car op) 'TAG) (byte-compile-out-tag op))
+ ((memq (car op) byte-goto-ops) (byte-compile-goto (car op) (cdr op)))
+ ((eq (car op) 'byte-return)
+ (byte-compile-discard (- byte-compile-depth end-depth) t)
+ (byte-compile-goto 'byte-goto endtag))
+ (t (byte-compile-out (car op) (cdr op)))))
+ (byte-compile-out-tag endtag)))
+
+(defun byte-compile-unfold-bcf (form)
+ "Inline call to byte-code-functions."
+ (let* ((byte-compile-bound-variables byte-compile-bound-variables)
+ (fun (car form))
+ (fargs (aref fun 0))
+ (start-depth byte-compile-depth)
+ (fmax2 (if (numberp fargs) (lsh fargs -7))) ;2*max+rest.
+ ;; (fmin (if (numberp fargs) (logand fargs 127)))
+ (alen (length (cdr form)))
+ (dynbinds ()))
+ (fetch-bytecode fun)
+ (mapc 'byte-compile-form (cdr form))
+ (unless fmax2
+ ;; Old-style byte-code.
+ (assert (listp fargs))
+ (while fargs
+ (case (car fargs)
+ (&optional (setq fargs (cdr fargs)))
+ (&rest (setq fmax2 (+ (* 2 (length dynbinds)) 1))
+ (push (cadr fargs) dynbinds)
+ (setq fargs nil))
+ (t (push (pop fargs) dynbinds))))
+ (unless fmax2 (setq fmax2 (* 2 (length dynbinds)))))
+ (cond
+ ((<= (+ alen alen) fmax2)
+ ;; Add missing &optional (or &rest) arguments.
+ (dotimes (i (- (/ (1+ fmax2) 2) alen))
+ (byte-compile-push-constant nil)))
+ ((zerop (logand fmax2 1))
+ (byte-compile-log-warning "Too many arguments for inlined function"
+ nil :error)
+ (byte-compile-discard (- alen (/ fmax2 2))))
+ (t
+ ;; Turn &rest args into a list.
+ (let ((n (- alen (/ (1- fmax2) 2))))
+ (assert (> n 0) nil "problem: fmax2=%S alen=%S n=%S" fmax2 alen n)
+ (if (< n 5)
+ (byte-compile-out
+ (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- n))
+ 0)
+ (byte-compile-out 'byte-listN n)))))
+ (mapc #'byte-compile-dynamic-variable-bind dynbinds)
+ (byte-compile-inline-lapcode
+ (byte-decompile-bytecode-1 (aref fun 1) (aref fun 2) t)
+ (1+ start-depth))
+ ;; Unbind dynamic variables.
+ (when dynbinds
+ (byte-compile-out 'byte-unbind (length dynbinds)))
+ (assert (eq byte-compile-depth (1+ start-depth))
+ nil "Wrong depth start=%s end=%s" start-depth byte-compile-depth)))
+
+(defun byte-compile-check-variable (var &optional binding)
+ "Do various error checks before a use of the variable VAR.
+If BINDING is non-nil, VAR is being bound."
+ (when (symbolp var)
+ (byte-compile-set-symbol-position var))
+ (cond ((or (not (symbolp var)) (byte-compile-const-symbol-p var))
+ (when (byte-compile-warning-enabled-p 'constants)
+ (byte-compile-warn (if binding
+ "attempt to let-bind %s `%s`"
+ "variable reference to %s `%s'")
+ (if (symbolp var) "constant" "nonvariable")
+ (prin1-to-string var))))
+ ((and (get var 'byte-obsolete-variable)
+ (not (memq var byte-compile-not-obsolete-vars)))
+ (byte-compile-warn-obsolete var))))
+
+(defsubst byte-compile-dynamic-variable-op (base-op var)
+ (let ((tmp (assq var byte-compile-variables)))
(unless tmp
- (setq tmp (list bytecomp-var))
+ (setq tmp (list var))
(push tmp byte-compile-variables))
(byte-compile-out base-op tmp)))
+(defun byte-compile-dynamic-variable-bind (var)
+ "Generate code to bind the lexical variable VAR to the top-of-stack value."
+ (byte-compile-check-variable var t)
+ (push var byte-compile-bound-variables)
+ (byte-compile-dynamic-variable-op 'byte-varbind var))
+
+(defun byte-compile-variable-ref (var)
+ "Generate code to push the value of the variable VAR on the stack."
+ (byte-compile-check-variable var)
+ (let ((lex-binding (assq var byte-compile--lexical-environment)))
+ (if lex-binding
+ ;; VAR is lexically bound
+ (byte-compile-stack-ref (cdr lex-binding))
+ ;; VAR is dynamically bound
+ (unless (or (not (byte-compile-warning-enabled-p 'free-vars))
+ (boundp var)
+ (memq var byte-compile-bound-variables)
+ (memq var byte-compile-free-references))
+ (byte-compile-warn "reference to free variable `%S'" var)
+ (push var byte-compile-free-references))
+ (byte-compile-dynamic-variable-op 'byte-varref var))))
+
+(defun byte-compile-variable-set (var)
+ "Generate code to set the variable VAR from the top-of-stack value."
+ (byte-compile-check-variable var)
+ (let ((lex-binding (assq var byte-compile--lexical-environment)))
+ (if lex-binding
+ ;; VAR is lexically bound
+ (byte-compile-stack-set (cdr lex-binding))
+ ;; VAR is dynamically bound
+ (unless (or (not (byte-compile-warning-enabled-p 'free-vars))
+ (boundp var)
+ (memq var byte-compile-bound-variables)
+ (memq var byte-compile-free-assignments))
+ (byte-compile-warn "assignment to free variable `%s'" var)
+ (push var byte-compile-free-assignments))
+ (byte-compile-dynamic-variable-op 'byte-varset var))))
+
(defmacro byte-compile-get-constant (const)
`(or (if (stringp ,const)
;; In a string constant, treat properties as significant.
@@ -2863,20 +3089,20 @@ That command is designed for interactive use only" bytecomp-fn))
(car (setq byte-compile-constants
(cons (list ,const) byte-compile-constants)))))
-;; Use this when the value of a form is a constant. This obeys for-effect.
+;; Use this when the value of a form is a constant.
+;; This obeys byte-compile--for-effect.
(defun byte-compile-constant (const)
- (if for-effect
- (setq for-effect nil)
+ (if byte-compile--for-effect
+ (setq byte-compile--for-effect nil)
(when (symbolp const)
(byte-compile-set-symbol-position const))
(byte-compile-out 'byte-constant (byte-compile-get-constant const))))
;; Use this for a constant that is not the value of its containing form.
-;; This ignores for-effect.
+;; This ignores byte-compile--for-effect.
(defun byte-compile-push-constant (const)
- (let ((for-effect nil))
+ (let ((byte-compile--for-effect nil))
(inline (byte-compile-constant const))))
-
;; Compile those primitive ordinary functions
;; which have special byte codes just for speed.
@@ -2947,7 +3173,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
(byte-defop-compiler bobp 0)
(byte-defop-compiler current-buffer 0)
;;(byte-defop-compiler read-char 0) ;; obsolete
-(byte-defop-compiler interactive-p 0)
+;; (byte-defop-compiler interactive-p 0) ;; Obsolete.
(byte-defop-compiler widen 0)
(byte-defop-compiler end-of-line 0-1)
(byte-defop-compiler forward-char 0-1)
@@ -3030,7 +3256,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
(byte-compile-warn "`%s' called with %d arg%s, but requires %s"
(car form) (length (cdr form))
(if (= 1 (length (cdr form))) "" "s") n)
- ;; get run-time wrong-number-of-args error.
+ ;; Get run-time wrong-number-of-args error.
(byte-compile-normal-call form))
(defun byte-compile-no-args (form)
@@ -3077,12 +3303,66 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
((= len 4) (byte-compile-three-args form))
(t (byte-compile-subr-wrong-args form "2-3")))))
-(defun byte-compile-noop (form)
+(defun byte-compile-noop (_form)
(byte-compile-constant nil))
-(defun byte-compile-discard ()
- (byte-compile-out 'byte-discard 0))
-
+(defun byte-compile-discard (&optional num preserve-tos)
+ "Output byte codes to discard the NUM entries at the top of the stack.
+NUM defaults to 1.
+If PRESERVE-TOS is non-nil, preserve the top-of-stack value, as if it were
+popped before discarding the num values, and then pushed back again after
+discarding."
+ (if (and (null num) (not preserve-tos))
+ ;; common case
+ (byte-compile-out 'byte-discard)
+ ;; general case
+ (unless num
+ (setq num 1))
+ (when (and preserve-tos (> num 0))
+ ;; Preserve the top-of-stack value by writing it directly to the stack
+ ;; location which will be at the top-of-stack after popping.
+ (byte-compile-stack-set (1- (- byte-compile-depth num)))
+ ;; Now we actually discard one less value, since we want to keep
+ ;; the eventual TOS
+ (setq num (1- num)))
+ (while (> num 0)
+ (byte-compile-out 'byte-discard)
+ (setq num (1- num)))))
+
+(defun byte-compile-stack-ref (stack-pos)
+ "Output byte codes to push the value at stack position STACK-POS."
+ (let ((dist (- byte-compile-depth (1+ stack-pos))))
+ (if (zerop dist)
+ ;; A simple optimization
+ (byte-compile-out 'byte-dup)
+ ;; normal case
+ (byte-compile-out 'byte-stack-ref dist))))
+
+(defun byte-compile-stack-set (stack-pos)
+ "Output byte codes to store the TOS value at stack position STACK-POS."
+ (byte-compile-out 'byte-stack-set (- byte-compile-depth (1+ stack-pos))))
+
+(byte-defop-compiler-1 internal-make-closure byte-compile-make-closure)
+(byte-defop-compiler-1 internal-get-closed-var byte-compile-get-closed-var)
+
+(defun byte-compile-make-closure (form)
+ "Byte-compile the special `internal-make-closure' form."
+ (if byte-compile--for-effect (setq byte-compile--for-effect nil)
+ (let* ((vars (nth 1 form))
+ (env (nth 2 form))
+ (body (nthcdr 3 form))
+ (fun
+ (byte-compile-lambda `(lambda ,vars . ,body) nil (length env))))
+ (assert (byte-code-function-p fun))
+ (byte-compile-form `(make-byte-code
+ ',(aref fun 0) ',(aref fun 1)
+ (vconcat (vector . ,env) ',(aref fun 2))
+ ,@(nthcdr 3 (mapcar (lambda (x) `',x) fun)))))))
+
+(defun byte-compile-get-closed-var (form)
+ "Byte-compile the special `internal-get-closed-var' form."
+ (if byte-compile--for-effect (setq byte-compile--for-effect nil)
+ (byte-compile-out 'byte-constant (nth 1 form))))
;; Compile a function that accepts one or more args and is right-associative.
;; We do it by left-associativity so that the operations
@@ -3237,43 +3517,17 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
(byte-compile-warn
"A quoted lambda form is the second argument of `fset'. This is probably
not what you want, as that lambda cannot be compiled. Consider using
- the syntax (function (lambda (...) ...)) instead.")))))
+ the syntax #'(lambda (...) ...) instead.")))))
(byte-compile-two-args form))
-(defun byte-compile-funarg (form)
- ;; (mapcar '(lambda (x) ..) ..) ==> (mapcar (function (lambda (x) ..)) ..)
- ;; for cases where it's guaranteed that first arg will be used as a lambda.
- (byte-compile-normal-call
- (let ((fn (nth 1 form)))
- (if (and (eq (car-safe fn) 'quote)
- (eq (car-safe (nth 1 fn)) 'lambda))
- (cons (car form)
- (cons (cons 'function (cdr fn))
- (cdr (cdr form))))
- form))))
-
-(defun byte-compile-funarg-2 (form)
- ;; (sort ... '(lambda (x) ..)) ==> (sort ... (function (lambda (x) ..)))
- ;; for cases where it's guaranteed that second arg will be used as a lambda.
- (byte-compile-normal-call
- (let ((fn (nth 2 form)))
- (if (and (eq (car-safe fn) 'quote)
- (eq (car-safe (nth 1 fn)) 'lambda))
- (cons (car form)
- (cons (nth 1 form)
- (cons (cons 'function (cdr fn))
- (cdr (cdr (cdr form))))))
- form))))
-
;; (function foo) must compile like 'foo, not like (symbol-function 'foo).
;; Otherwise it will be incompatible with the interpreter,
;; and (funcall (function foo)) will lose with autoloads.
(defun byte-compile-function-form (form)
- (byte-compile-constant
- (cond ((symbolp (nth 1 form))
- (nth 1 form))
- ((byte-compile-lambda (nth 1 form))))))
+ (byte-compile-constant (if (symbolp (nth 1 form))
+ (nth 1 form)
+ (byte-compile-lambda (nth 1 form)))))
(defun byte-compile-indent-to (form)
(let ((len (length form)))
@@ -3308,60 +3562,65 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
(byte-defop-compiler-1 setq)
(byte-defop-compiler-1 setq-default)
(byte-defop-compiler-1 quote)
-(byte-defop-compiler-1 quote-form)
(defun byte-compile-setq (form)
- (let ((bytecomp-args (cdr form)))
- (if bytecomp-args
- (while bytecomp-args
- (byte-compile-form (car (cdr bytecomp-args)))
- (or for-effect (cdr (cdr bytecomp-args))
+ (let ((args (cdr form)))
+ (if args
+ (while args
+ (byte-compile-form (car (cdr args)))
+ (or byte-compile--for-effect (cdr (cdr args))
(byte-compile-out 'byte-dup 0))
- (byte-compile-variable-ref 'byte-varset (car bytecomp-args))
- (setq bytecomp-args (cdr (cdr bytecomp-args))))
+ (byte-compile-variable-set (car args))
+ (setq args (cdr (cdr args))))
;; (setq), with no arguments.
- (byte-compile-form nil for-effect))
- (setq for-effect nil)))
+ (byte-compile-form nil byte-compile--for-effect))
+ (setq byte-compile--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))))
-
-(defun byte-compile-quote-form (form)
- (byte-compile-constant (byte-compile-top-level (nth 1 form))))
-
;;; control structures
-(defun byte-compile-body (bytecomp-body &optional for-effect)
- (while (cdr bytecomp-body)
- (byte-compile-form (car bytecomp-body) t)
- (setq bytecomp-body (cdr bytecomp-body)))
- (byte-compile-form (car bytecomp-body) for-effect))
+(defun byte-compile-body (body &optional for-effect)
+ (while (cdr body)
+ (byte-compile-form (car body) t)
+ (setq body (cdr body)))
+ (byte-compile-form (car body) for-effect))
-(defsubst byte-compile-body-do-effect (bytecomp-body)
- (byte-compile-body bytecomp-body for-effect)
- (setq for-effect nil))
+(defsubst byte-compile-body-do-effect (body)
+ (byte-compile-body body byte-compile--for-effect)
+ (setq byte-compile--for-effect nil))
(defsubst byte-compile-form-do-effect (form)
- (byte-compile-form form for-effect)
- (setq for-effect nil))
+ (byte-compile-form form byte-compile--for-effect)
+ (setq byte-compile--for-effect nil))
(byte-defop-compiler-1 inline byte-compile-progn)
(byte-defop-compiler-1 progn)
@@ -3373,18 +3632,8 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
(byte-defop-compiler-1 or)
(byte-defop-compiler-1 while)
(byte-defop-compiler-1 funcall)
-(byte-defop-compiler-1 apply byte-compile-funarg)
-(byte-defop-compiler-1 mapcar byte-compile-funarg)
-(byte-defop-compiler-1 mapatoms byte-compile-funarg)
-(byte-defop-compiler-1 mapconcat byte-compile-funarg)
-(byte-defop-compiler-1 mapc byte-compile-funarg)
-(byte-defop-compiler-1 maphash byte-compile-funarg)
-(byte-defop-compiler-1 map-char-table byte-compile-funarg)
-(byte-defop-compiler-1 map-char-table byte-compile-funarg-2)
-;; map-charset-chars should be funarg but has optional third arg
-(byte-defop-compiler-1 sort byte-compile-funarg-2)
(byte-defop-compiler-1 let)
-(byte-defop-compiler-1 let*)
+(byte-defop-compiler-1 let* byte-compile-let)
(defun byte-compile-progn (form)
(byte-compile-body-do-effect (cdr form)))
@@ -3449,13 +3698,11 @@ that suppresses all warnings during execution of BODY."
,condition (list 'boundp 'default-boundp)))
;; Maybe add to the bound list.
(byte-compile-bound-variables
- (if bound-list
- (append bound-list byte-compile-bound-variables)
- byte-compile-bound-variables)))
+ (append bound-list byte-compile-bound-variables)))
(unwind-protect
- ;; If things not being bound at all is ok, so must them being obsolete.
- ;; Note that we add to the existing lists since Tramp (ab)uses
- ;; this feature.
+ ;; If things not being bound at all is ok, so must them being
+ ;; obsolete. Note that we add to the existing lists since Tramp
+ ;; (ab)uses this feature.
(let ((byte-compile-not-obsolete-vars
(append byte-compile-not-obsolete-vars bound-list))
(byte-compile-not-obsolete-funcs
@@ -3477,20 +3724,20 @@ that suppresses all warnings during execution of BODY."
(if (null (nthcdr 3 form))
;; No else-forms
(progn
- (byte-compile-goto-if nil for-effect donetag)
+ (byte-compile-goto-if nil byte-compile--for-effect donetag)
(byte-compile-maybe-guarded clause
- (byte-compile-form (nth 2 form) for-effect))
+ (byte-compile-form (nth 2 form) byte-compile--for-effect))
(byte-compile-out-tag donetag))
(let ((elsetag (byte-compile-make-tag)))
(byte-compile-goto 'byte-goto-if-nil elsetag)
(byte-compile-maybe-guarded clause
- (byte-compile-form (nth 2 form) for-effect))
+ (byte-compile-form (nth 2 form) byte-compile--for-effect))
(byte-compile-goto 'byte-goto donetag)
(byte-compile-out-tag elsetag)
(byte-compile-maybe-guarded (list 'not clause)
- (byte-compile-body (cdr (cdr (cdr form))) for-effect))
+ (byte-compile-body (cdr (cdr (cdr form))) byte-compile--for-effect))
(byte-compile-out-tag donetag))))
- (setq for-effect nil))
+ (setq byte-compile--for-effect nil))
(defun byte-compile-cond (clauses)
(let ((donetag (byte-compile-make-tag))
@@ -3507,18 +3754,18 @@ that suppresses all warnings during execution of BODY."
(byte-compile-form (car clause))
(if (null (cdr clause))
;; First clause is a singleton.
- (byte-compile-goto-if t for-effect donetag)
+ (byte-compile-goto-if t byte-compile--for-effect donetag)
(setq nexttag (byte-compile-make-tag))
(byte-compile-goto 'byte-goto-if-nil nexttag)
(byte-compile-maybe-guarded (car clause)
- (byte-compile-body (cdr clause) for-effect))
+ (byte-compile-body (cdr clause) byte-compile--for-effect))
(byte-compile-goto 'byte-goto donetag)
(byte-compile-out-tag nexttag)))))
;; Last clause
(let ((guard (car clause)))
(and (cdr clause) (not (eq guard t))
(progn (byte-compile-form guard)
- (byte-compile-goto-if nil for-effect donetag)
+ (byte-compile-goto-if nil byte-compile--for-effect donetag)
(setq clause (cdr clause))))
(byte-compile-maybe-guarded guard
(byte-compile-body-do-effect clause)))
@@ -3526,10 +3773,10 @@ that suppresses all warnings during execution of BODY."
(defun byte-compile-and (form)
(let ((failtag (byte-compile-make-tag))
- (bytecomp-args (cdr form)))
- (if (null bytecomp-args)
+ (args (cdr form)))
+ (if (null args)
(byte-compile-form-do-effect t)
- (byte-compile-and-recursion bytecomp-args failtag))))
+ (byte-compile-and-recursion args failtag))))
;; Handle compilation of a nontrivial `and' call.
;; We use tail recursion so we can use byte-compile-maybe-guarded.
@@ -3537,7 +3784,7 @@ that suppresses all warnings during execution of BODY."
(if (cdr rest)
(progn
(byte-compile-form (car rest))
- (byte-compile-goto-if nil for-effect failtag)
+ (byte-compile-goto-if nil byte-compile--for-effect failtag)
(byte-compile-maybe-guarded (car rest)
(byte-compile-and-recursion (cdr rest) failtag)))
(byte-compile-form-do-effect (car rest))
@@ -3545,10 +3792,10 @@ that suppresses all warnings during execution of BODY."
(defun byte-compile-or (form)
(let ((wintag (byte-compile-make-tag))
- (bytecomp-args (cdr form)))
- (if (null bytecomp-args)
+ (args (cdr form)))
+ (if (null args)
(byte-compile-form-do-effect nil)
- (byte-compile-or-recursion bytecomp-args wintag))))
+ (byte-compile-or-recursion args wintag))))
;; Handle compilation of a nontrivial `or' call.
;; We use tail recursion so we can use byte-compile-maybe-guarded.
@@ -3556,7 +3803,7 @@ that suppresses all warnings during execution of BODY."
(if (cdr rest)
(progn
(byte-compile-form (car rest))
- (byte-compile-goto-if t for-effect wintag)
+ (byte-compile-goto-if t byte-compile--for-effect wintag)
(byte-compile-maybe-guarded (list 'not (car rest))
(byte-compile-or-recursion (cdr rest) wintag)))
(byte-compile-form-do-effect (car rest))
@@ -3567,44 +3814,131 @@ that suppresses all warnings during execution of BODY."
(looptag (byte-compile-make-tag)))
(byte-compile-out-tag looptag)
(byte-compile-form (car (cdr form)))
- (byte-compile-goto-if nil for-effect endtag)
+ (byte-compile-goto-if nil byte-compile--for-effect endtag)
(byte-compile-body (cdr (cdr form)) t)
(byte-compile-goto 'byte-goto looptag)
(byte-compile-out-tag endtag)
- (setq for-effect nil)))
+ (setq byte-compile--for-effect nil)))
(defun byte-compile-funcall (form)
(mapc 'byte-compile-form (cdr form))
(byte-compile-out 'byte-call (length (cdr (cdr form)))))
+
+;; let binding
+
+(defun byte-compile-push-binding-init (clause)
+ "Emit byte-codes to push the initialization value for CLAUSE on the stack.
+Return the offset in the form (VAR . OFFSET)."
+ (let* ((var (if (consp clause) (car clause) clause)))
+ ;; We record the stack position even of dynamic bindings and
+ ;; variables in non-stack lexical environments; we'll put
+ ;; them in the proper place below.
+ (prog1 (cons var byte-compile-depth)
+ (if (consp clause)
+ (byte-compile-form (cadr clause))
+ (byte-compile-push-constant nil)))))
+
+(defun byte-compile-not-lexical-var-p (var)
+ (or (not (symbolp var))
+ (special-variable-p var)
+ (memq var byte-compile-bound-variables)
+ (memq var '(nil t))
+ (keywordp var)))
+
+(defun byte-compile-bind (var init-lexenv)
+ "Emit byte-codes to bind VAR and update `byte-compile--lexical-environment'.
+INIT-LEXENV should be a lexical-environment alist describing the
+positions of the init value that have been pushed on the stack.
+Return non-nil if the TOS value was popped."
+ ;; The presence of lexical bindings mean that we may have to
+ ;; juggle things on the stack, to move them to TOS for
+ ;; dynamic binding.
+ (cond ((not (byte-compile-not-lexical-var-p var))
+ ;; VAR is a simple stack-allocated lexical variable
+ (push (assq var init-lexenv)
+ byte-compile--lexical-environment)
+ nil)
+ ((eq var (caar init-lexenv))
+ ;; VAR is dynamic and is on the top of the
+ ;; stack, so we can just bind it like usual
+ (byte-compile-dynamic-variable-bind var)
+ t)
+ (t
+ ;; VAR is dynamic, but we have to get its
+ ;; value out of the middle of the stack
+ (let ((stack-pos (cdr (assq var init-lexenv))))
+ (byte-compile-stack-ref stack-pos)
+ (byte-compile-dynamic-variable-bind var)
+ ;; Now we have to store nil into its temporary
+ ;; stack position to avoid problems with GC
+ (byte-compile-push-constant nil)
+ (byte-compile-stack-set stack-pos))
+ nil)))
+
+(defun byte-compile-unbind (clauses init-lexenv
+ &optional preserve-body-value)
+ "Emit byte-codes to unbind the variables bound by CLAUSES.
+CLAUSES is a `let'-style variable binding list. INIT-LEXENV should be a
+lexical-environment alist describing the positions of the init value that
+have been pushed on the stack. If PRESERVE-BODY-VALUE is true,
+then an additional value on the top of the stack, above any lexical binding
+slots, is preserved, so it will be on the top of the stack after all
+binding slots have been popped."
+ ;; Unbind dynamic variables
+ (let ((num-dynamic-bindings 0))
+ (dolist (clause clauses)
+ (unless (assq (if (consp clause) (car clause) clause)
+ byte-compile--lexical-environment)
+ (setq num-dynamic-bindings (1+ num-dynamic-bindings))))
+ (unless (zerop num-dynamic-bindings)
+ (byte-compile-out 'byte-unbind num-dynamic-bindings)))
+ ;; Pop lexical variables off the stack, possibly preserving the
+ ;; return value of the body.
+ (when init-lexenv
+ ;; INIT-LEXENV contains all init values left on the stack
+ (byte-compile-discard (length init-lexenv) preserve-body-value)))
(defun byte-compile-let (form)
- ;; First compute the binding values in the old scope.
- (let ((varlist (car (cdr form))))
- (dolist (var varlist)
- (if (consp var)
- (byte-compile-form (car (cdr var)))
- (byte-compile-push-constant nil))))
- (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope
- (varlist (reverse (car (cdr form)))))
- (dolist (var varlist)
- (byte-compile-variable-ref 'byte-varbind
- (if (consp var) (car var) var)))
- (byte-compile-body-do-effect (cdr (cdr form)))
- (byte-compile-out 'byte-unbind (length (car (cdr form))))))
-
-(defun byte-compile-let* (form)
- (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope
- (varlist (copy-sequence (car (cdr form)))))
- (dolist (var varlist)
- (if (atom var)
- (byte-compile-push-constant nil)
- (byte-compile-form (car (cdr var)))
- (setq var (car var)))
- (byte-compile-variable-ref 'byte-varbind var))
- (byte-compile-body-do-effect (cdr (cdr form)))
- (byte-compile-out 'byte-unbind (length (car (cdr form))))))
+ "Generate code for the `let' form FORM."
+ (let ((clauses (cadr form))
+ (init-lexenv nil))
+ (when (eq (car form) 'let)
+ ;; First compute the binding values in the old scope.
+ (dolist (var clauses)
+ (push (byte-compile-push-binding-init var) init-lexenv)))
+ ;; New scope.
+ (let ((byte-compile-bound-variables byte-compile-bound-variables)
+ (byte-compile--lexical-environment
+ byte-compile--lexical-environment))
+ ;; Bind the variables.
+ ;; For `let', do it in reverse order, because it makes no
+ ;; semantic difference, but it is a lot more efficient since the
+ ;; values are now in reverse order on the stack.
+ (dolist (var (if (eq (car form) 'let) (reverse clauses) clauses))
+ (unless (eq (car form) 'let)
+ (push (byte-compile-push-binding-init var) init-lexenv))
+ (let ((var (if (consp var) (car var) var)))
+ (cond ((null lexical-binding)
+ ;; If there are no lexical bindings, we can do things simply.
+ (byte-compile-dynamic-variable-bind var))
+ ((byte-compile-bind var init-lexenv)
+ (pop init-lexenv)))))
+ ;; Emit the body.
+ (let ((init-stack-depth byte-compile-depth))
+ (byte-compile-body-do-effect (cdr (cdr form)))
+ ;; Unbind the variables.
+ (if lexical-binding
+ ;; Unbind both lexical and dynamic variables.
+ (progn
+ (assert (or (eq byte-compile-depth init-stack-depth)
+ (eq byte-compile-depth (1+ init-stack-depth))))
+ (byte-compile-unbind clauses init-lexenv (> byte-compile-depth
+ init-stack-depth)))
+ ;; Unbind dynamic variables.
+ (byte-compile-out 'byte-unbind (length clauses)))))))
+
(byte-defop-compiler-1 /= byte-compile-negated)
(byte-defop-compiler-1 atom byte-compile-negated)
@@ -3636,77 +3970,94 @@ that suppresses all warnings during execution of BODY."
(byte-defop-compiler-1 save-excursion)
(byte-defop-compiler-1 save-current-buffer)
(byte-defop-compiler-1 save-restriction)
-(byte-defop-compiler-1 save-window-excursion)
-(byte-defop-compiler-1 with-output-to-temp-buffer)
+;; (byte-defop-compiler-1 save-window-excursion) ;Obsolete: now a macro.
+;; (byte-defop-compiler-1 with-output-to-temp-buffer) ;Obsolete: now a macro.
(byte-defop-compiler-1 track-mouse)
(defun byte-compile-catch (form)
(byte-compile-form (car (cdr form)))
- (byte-compile-push-constant
- (byte-compile-top-level (cons 'progn (cdr (cdr form))) for-effect))
+ (pcase (cddr form)
+ (`(:fun-body ,f)
+ (byte-compile-form `(list 'funcall ,f)))
+ (body
+ (byte-compile-push-constant
+ (byte-compile-top-level (cons 'progn body) byte-compile--for-effect))))
(byte-compile-out 'byte-catch 0))
(defun byte-compile-unwind-protect (form)
- (byte-compile-push-constant
- (byte-compile-top-level-body (cdr (cdr form)) t))
+ (pcase (cddr form)
+ (`(:fun-body ,f)
+ (byte-compile-form `(list (list 'funcall ,f))))
+ (handlers
+ (byte-compile-push-constant
+ (byte-compile-top-level-body handlers t))))
(byte-compile-out 'byte-unwind-protect 0)
(byte-compile-form-do-effect (car (cdr form)))
(byte-compile-out 'byte-unbind 1))
(defun byte-compile-track-mouse (form)
(byte-compile-form
- `(funcall '(lambda nil
- (track-mouse ,@(byte-compile-top-level-body (cdr form)))))))
+ (pcase form
+ (`(,_ :fun-body ,f) `(eval (list 'track-mouse (list 'funcall ,f))))
+ (_ `(eval '(track-mouse ,@(byte-compile-top-level-body (cdr form))))))))
(defun byte-compile-condition-case (form)
(let* ((var (nth 1 form))
- (byte-compile-bound-variables
- (if var (cons var byte-compile-bound-variables)
+ (fun-bodies (eq var :fun-body))
+ (byte-compile-bound-variables
+ (if (and var (not fun-bodies))
+ (cons var byte-compile-bound-variables)
byte-compile-bound-variables)))
(byte-compile-set-symbol-position 'condition-case)
(unless (symbolp var)
(byte-compile-warn
"`%s' is not a variable-name or nil (in condition-case)" var))
+ (if fun-bodies (setq var (make-symbol "err")))
(byte-compile-push-constant var)
- (byte-compile-push-constant (byte-compile-top-level
- (nth 2 form) for-effect))
- (let ((clauses (cdr (cdr (cdr form))))
- compiled-clauses)
- (while clauses
- (let* ((clause (car clauses))
- (condition (car clause)))
- (cond ((not (or (symbolp condition)
- (and (listp condition)
- (let ((syms condition) (ok t))
- (while syms
- (if (not (symbolp (car syms)))
- (setq ok nil))
- (setq syms (cdr syms)))
- ok))))
- (byte-compile-warn
- "`%s' is not a condition name or list of such (in condition-case)"
- (prin1-to-string condition)))
-;; ((not (or (eq condition 't)
-;; (and (stringp (get condition 'error-message))
-;; (consp (get condition 'error-conditions)))))
-;; (byte-compile-warn
-;; "`%s' is not a known condition name (in condition-case)"
-;; condition))
- )
- (setq compiled-clauses
- (cons (cons condition
- (byte-compile-top-level-body
- (cdr clause) for-effect))
- compiled-clauses)))
- (setq clauses (cdr clauses)))
- (byte-compile-push-constant (nreverse compiled-clauses)))
+ (if fun-bodies
+ (byte-compile-form `(list 'funcall ,(nth 2 form)))
+ (byte-compile-push-constant
+ (byte-compile-top-level (nth 2 form) byte-compile--for-effect)))
+ (let ((compiled-clauses
+ (mapcar
+ (lambda (clause)
+ (let ((condition (car clause)))
+ (cond ((not (or (symbolp condition)
+ (and (listp condition)
+ (let ((ok t))
+ (dolist (sym condition)
+ (if (not (symbolp sym))
+ (setq ok nil)))
+ ok))))
+ (byte-compile-warn
+ "`%S' is not a condition name or list of such (in condition-case)"
+ condition))
+ ;; (not (or (eq condition 't)
+ ;; (and (stringp (get condition 'error-message))
+ ;; (consp (get condition
+ ;; 'error-conditions)))))
+ ;; (byte-compile-warn
+ ;; "`%s' is not a known condition name
+ ;; (in condition-case)"
+ ;; condition))
+ )
+ (if fun-bodies
+ `(list ',condition (list 'funcall ,(cadr clause) ',var))
+ (cons condition
+ (byte-compile-top-level-body
+ (cdr clause) byte-compile--for-effect)))))
+ (cdr (cdr (cdr form))))))
+ (if fun-bodies
+ (byte-compile-form `(list ,@compiled-clauses))
+ (byte-compile-push-constant compiled-clauses)))
(byte-compile-out 'byte-condition-case 0)))
(defun byte-compile-save-excursion (form)
(if (and (eq 'set-buffer (car-safe (car-safe (cdr form))))
(byte-compile-warning-enabled-p 'suspicious))
- (byte-compile-warn "`save-excursion' defeated by `set-buffer'"))
+ (byte-compile-warn
+ "Use `with-current-buffer' rather than save-excursion+set-buffer"))
(byte-compile-out 'byte-save-excursion 0)
(byte-compile-body-do-effect (cdr form))
(byte-compile-out 'byte-unbind 1))
@@ -3720,17 +4071,6 @@ that suppresses all warnings during execution of BODY."
(byte-compile-out 'byte-save-current-buffer 0)
(byte-compile-body-do-effect (cdr form))
(byte-compile-out 'byte-unbind 1))
-
-(defun byte-compile-save-window-excursion (form)
- (byte-compile-push-constant
- (byte-compile-top-level-body (cdr form) for-effect))
- (byte-compile-out 'byte-save-window-excursion 0))
-
-(defun byte-compile-with-output-to-temp-buffer (form)
- (byte-compile-form (car (cdr form)))
- (byte-compile-out 'byte-temp-output-buffer-setup 0)
- (byte-compile-body (cdr (cdr form)))
- (byte-compile-out 'byte-temp-output-buffer-show 0))
;;; top-level forms elsewhere
@@ -3747,22 +4087,16 @@ that suppresses all warnings during execution of BODY."
(byte-compile-set-symbol-position (car form))
(byte-compile-set-symbol-position 'defun)
(error "defun name must be a symbol, not %s" (car form)))
- ;; We prefer to generate a defalias form so it will record the function
- ;; definition just like interpreting a defun.
- (byte-compile-form
- (list 'defalias
- (list 'quote (nth 1 form))
- (byte-compile-byte-code-maker
- (byte-compile-lambda (cdr (cdr form)) t)))
- t)
- (byte-compile-constant (nth 1 form)))
+ (byte-compile-push-constant 'defalias)
+ (byte-compile-push-constant (nth 1 form))
+ (byte-compile-push-constant (byte-compile-lambda (cdr (cdr form)) t))
+ (byte-compile-out 'byte-call 2))
(defun byte-compile-defmacro (form)
;; This is not used for file-level defmacros with doc strings.
(byte-compile-body-do-effect
(let ((decls (byte-compile-defmacro-declaration form))
- (code (byte-compile-byte-code-maker
- (byte-compile-lambda (cdr (cdr form)) t))))
+ (code (byte-compile-lambda (cdr (cdr form)) t)))
`((defalias ',(nth 1 form)
,(if (eq (car-safe code) 'make-byte-code)
`(cons 'macro ,code)
@@ -3770,8 +4104,24 @@ that suppresses all warnings during execution of BODY."
,@decls
',(nth 1 form)))))
+;; If foo.el declares `toto' as obsolete, it is likely that foo.el will
+;; actually use `toto' in order for this obsolete variable to still work
+;; correctly, so paradoxically, while byte-compiling foo.el, the presence
+;; of a make-obsolete-variable call for `toto' is an indication that `toto'
+;; should not trigger obsolete-warnings in foo.el.
+(byte-defop-compiler-1 make-obsolete-variable)
+(defun byte-compile-make-obsolete-variable (form)
+ (when (eq 'quote (car-safe (nth 1 form)))
+ (push (nth 1 (nth 1 form)) byte-compile-not-obsolete-vars))
+ (byte-compile-normal-call form))
+
(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))
@@ -3794,7 +4144,7 @@ that suppresses all warnings during execution of BODY."
;; Put the defined variable in this library's load-history entry
;; just as a real defvar would, but only in top-level forms.
(when (and (cddr form) (null byte-compile-current-form))
- `(push ',var current-load-list))
+ `(setq current-load-list (cons ',var current-load-list)))
(when (> (length form) 3)
(when (and string (not (stringp string)))
(byte-compile-warn "third arg to `%s %s' is not a string: %s"
@@ -3828,12 +4178,13 @@ that suppresses all warnings during execution of BODY."
;; Lambdas in valid places are handled as special cases by various code.
;; The ones that remain are errors.
-(defun byte-compile-lambda-form (form)
+(defun byte-compile-lambda-form (_form)
(byte-compile-set-symbol-position 'lambda)
(error "`lambda' used as function name is invalid"))
;; Compile normally, but deal with warnings for the function being defined.
(put 'defalias 'byte-hunk-handler 'byte-compile-file-form-defalias)
+;; Used for eieio--defalias as well.
(defun byte-compile-file-form-defalias (form)
(if (and (consp (cdr form)) (consp (nth 1 form))
(eq (car (nth 1 form)) 'quote)
@@ -3903,8 +4254,8 @@ that suppresses all warnings during execution of BODY."
(progn
;; ## remove this someday
(and byte-compile-depth
- (not (= (cdr (cdr tag)) byte-compile-depth))
- (error "Compiler bug: depth conflict at tag %d" (car (cdr tag))))
+ (not (= (cdr (cdr tag)) byte-compile-depth))
+ (error "Compiler bug: depth conflict at tag %d" (car (cdr tag))))
(setq byte-compile-depth (cdr (cdr tag))))
(setcdr (cdr tag) byte-compile-depth)))
@@ -3916,24 +4267,31 @@ that suppresses all warnings during execution of BODY."
(setq byte-compile-depth (and (not (eq opcode 'byte-goto))
(1- byte-compile-depth))))
-(defun byte-compile-out (opcode offset)
- (push (cons opcode offset) byte-compile-output)
- (cond ((eq opcode 'byte-call)
- (setq byte-compile-depth (- byte-compile-depth offset)))
- ((eq opcode 'byte-return)
- ;; This is actually an unnecessary case, because there should be
- ;; no more opcodes behind byte-return.
- (setq byte-compile-depth nil))
- (t
- (setq byte-compile-depth (+ byte-compile-depth
- (or (aref byte-stack+-info
- (symbol-value opcode))
- (- (1- offset))))
- byte-compile-maxdepth (max byte-compile-depth
- byte-compile-maxdepth))))
- ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow"))
- )
-
+(defun byte-compile-stack-adjustment (op operand)
+ "Return the amount by which an operation adjusts the stack.
+OP and OPERAND are as passed to `byte-compile-out'."
+ (if (memq op '(byte-call byte-discardN byte-discardN-preserve-tos))
+ ;; For calls, OPERAND is the number of args, so we pop OPERAND + 1
+ ;; elements, and the push the result, for a total of -OPERAND.
+ ;; For discardN*, of course, we just pop OPERAND elements.
+ (- operand)
+ (or (aref byte-stack+-info (symbol-value op))
+ ;; Ops with a nil entry in `byte-stack+-info' are byte-codes
+ ;; that take OPERAND values off the stack and push a result, for
+ ;; a total of 1 - OPERAND
+ (- 1 operand))))
+
+(defun byte-compile-out (op &optional operand)
+ (push (cons op operand) byte-compile-output)
+ (if (eq op 'byte-return)
+ ;; This is actually an unnecessary case, because there should be no
+ ;; more ops behind byte-return.
+ (setq byte-compile-depth nil)
+ (setq byte-compile-depth
+ (+ byte-compile-depth (byte-compile-stack-adjustment op operand)))
+ (setq byte-compile-maxdepth (max byte-compile-depth byte-compile-maxdepth))
+ ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow"))
+ ))
;;; call tree stuff
@@ -3992,22 +4350,22 @@ invoked interactively."
(if byte-compile-call-tree-sort
(setq byte-compile-call-tree
(sort byte-compile-call-tree
- (cond ((eq byte-compile-call-tree-sort 'callers)
- (function (lambda (x y) (< (length (nth 1 x))
- (length (nth 1 y))))))
- ((eq byte-compile-call-tree-sort 'calls)
- (function (lambda (x y) (< (length (nth 2 x))
- (length (nth 2 y))))))
- ((eq byte-compile-call-tree-sort 'calls+callers)
- (function (lambda (x y) (< (+ (length (nth 1 x))
- (length (nth 2 x)))
- (+ (length (nth 1 y))
- (length (nth 2 y)))))))
- ((eq byte-compile-call-tree-sort 'name)
- (function (lambda (x y) (string< (car x)
- (car y)))))
- (t (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode"
- byte-compile-call-tree-sort))))))
+ (case byte-compile-call-tree-sort
+ (callers
+ (lambda (x y) (< (length (nth 1 x))
+ (length (nth 1 y)))))
+ (calls
+ (lambda (x y) (< (length (nth 2 x))
+ (length (nth 2 y)))))
+ (calls+callers
+ (lambda (x y) (< (+ (length (nth 1 x))
+ (length (nth 2 x)))
+ (+ (length (nth 1 y))
+ (length (nth 2 y))))))
+ (name
+ (lambda (x y) (string< (car x) (car y))))
+ (t (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode"
+ byte-compile-call-tree-sort))))))
(message "Generating call tree...")
(let ((rest byte-compile-call-tree)
(b (current-buffer))
@@ -4115,60 +4473,59 @@ Each file is processed even if an error occurred previously.
For example, invoke \"emacs -batch -f batch-byte-compile $emacs/ ~/*.el\".
If NOFORCE is non-nil, don't recompile a file that seems to be
already up-to-date."
- ;; command-line-args-left is what is left of the command line (from startup.el)
+ ;; command-line-args-left is what is left of the command line, from
+ ;; startup.el.
(defvar command-line-args-left) ;Avoid 'free variable' warning
(if (not noninteractive)
(error "`batch-byte-compile' is to be used only with -batch"))
- (let ((bytecomp-error nil))
+ (let ((error nil))
(while command-line-args-left
(if (file-directory-p (expand-file-name (car command-line-args-left)))
;; Directory as argument.
- (let ((bytecomp-files (directory-files (car command-line-args-left)))
- bytecomp-source bytecomp-dest)
- (dolist (bytecomp-file bytecomp-files)
- (if (and (string-match emacs-lisp-file-regexp bytecomp-file)
- (not (auto-save-file-name-p bytecomp-file))
- (setq bytecomp-source
- (expand-file-name bytecomp-file
+ (let (source dest)
+ (dolist (file (directory-files (car command-line-args-left)))
+ (if (and (string-match emacs-lisp-file-regexp file)
+ (not (auto-save-file-name-p file))
+ (setq source
+ (expand-file-name file
(car command-line-args-left)))
- (setq bytecomp-dest (byte-compile-dest-file
- bytecomp-source))
- (file-exists-p bytecomp-dest)
- (file-newer-than-file-p bytecomp-source bytecomp-dest))
- (if (null (batch-byte-compile-file bytecomp-source))
- (setq bytecomp-error t)))))
+ (setq dest (byte-compile-dest-file source))
+ (file-exists-p dest)
+ (file-newer-than-file-p source dest))
+ (if (null (batch-byte-compile-file source))
+ (setq error t)))))
;; Specific file argument
(if (or (not noforce)
- (let* ((bytecomp-source (car command-line-args-left))
- (bytecomp-dest (byte-compile-dest-file bytecomp-source)))
- (or (not (file-exists-p bytecomp-dest))
- (file-newer-than-file-p bytecomp-source bytecomp-dest))))
+ (let* ((source (car command-line-args-left))
+ (dest (byte-compile-dest-file source)))
+ (or (not (file-exists-p dest))
+ (file-newer-than-file-p source dest))))
(if (null (batch-byte-compile-file (car command-line-args-left)))
- (setq bytecomp-error t))))
+ (setq error t))))
(setq command-line-args-left (cdr command-line-args-left)))
- (kill-emacs (if bytecomp-error 1 0))))
+ (kill-emacs (if error 1 0))))
-(defun batch-byte-compile-file (bytecomp-file)
+(defun batch-byte-compile-file (file)
(if debug-on-error
- (byte-compile-file bytecomp-file)
+ (byte-compile-file file)
(condition-case err
- (byte-compile-file bytecomp-file)
+ (byte-compile-file file)
(file-error
(message (if (cdr err)
">>Error occurred processing %s: %s (%s)"
">>Error occurred processing %s: %s")
- bytecomp-file
+ file
(get (car err) 'error-message)
(prin1-to-string (cdr err)))
- (let ((bytecomp-destfile (byte-compile-dest-file bytecomp-file)))
- (if (file-exists-p bytecomp-destfile)
- (delete-file bytecomp-destfile)))
+ (let ((destfile (byte-compile-dest-file file)))
+ (if (file-exists-p destfile)
+ (delete-file destfile)))
nil)
(error
(message (if (cdr err)
">>Error occurred processing %s: %s (%s)"
">>Error occurred processing %s: %s")
- bytecomp-file
+ file
(get (car err) 'error-message)
(prin1-to-string (cdr err)))
nil))))
@@ -4184,7 +4541,14 @@ Use with caution."
(setq f (car f))
(if (string-match "elc\\'" f) (setq f (substring f 0 -1)))
(when (and (file-readable-p f)
- (file-newer-than-file-p f emacs-file))
+ (file-newer-than-file-p f emacs-file)
+ ;; Don't reload the source version of the files below
+ ;; because that causes subsequent byte-compilation to
+ ;; be a lot slower and need a higher max-lisp-eval-depth,
+ ;; so it can cause recompilation to fail.
+ (not (member (file-name-nondirectory f)
+ '("pcase.el" "bytecomp.el" "macroexp.el"
+ "cconv.el" "byte-opt.el"))))
(message "Reloading stale %s" (file-name-nondirectory f))
(condition-case nil
(load f 'noerror nil 'nosuffix)
@@ -4220,6 +4584,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 +4634,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/cconv.el b/lisp/emacs-lisp/cconv.el
new file mode 100644
index 00000000000..38584c437b8
--- /dev/null
+++ b/lisp/emacs-lisp/cconv.el
@@ -0,0 +1,715 @@
+;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t; coding: utf-8 -*-
+
+;; Copyright (C) 2011 Free Software Foundation, Inc.
+
+;; Author: Igor Kuzmin <kzuminig@iro.umontreal.ca>
+;; Maintainer: FSF
+;; Keywords: lisp
+;; Package: emacs
+
+;; 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 takes a piece of Elisp code, and eliminates all free variables from
+;; lambda expressions. The user entry points are cconv-closure-convert and
+;; cconv-closure-convert-toplevel(for toplevel forms).
+;; All macros should be expanded beforehand.
+;;
+;; Here is a brief explanation how this code works.
+;; Firstly, we analyse the tree by calling cconv-analyse-form.
+;; This function finds all mutated variables, all functions that are suitable
+;; for lambda lifting and all variables captured by closure. It passes the tree
+;; once, returning a list of three lists.
+;;
+;; Then we calculate the intersection of first and third lists returned by
+;; cconv-analyse form to find all mutated variables that are captured by
+;; closure.
+
+;; Armed with this data, we call cconv-closure-convert-rec, that rewrites the
+;; tree recursivly, lifting lambdas where possible, building closures where it
+;; is needed and eliminating mutable variables used in closure.
+;;
+;; We do following replacements :
+;; (lambda (v1 ...) ... fv1 fv2 ...) => (lambda (v1 ... fv1 fv2 ) ... fv1 fv2 .)
+;; if the function is suitable for lambda lifting (if all calls are known)
+;;
+;; (lambda (v0 ...) ... fv0 .. fv1 ...) =>
+;; (internal-make-closure (v0 ...) (fv1 ...)
+;; ... (internal-get-closed-var 0) ... (internal-get-closed-var 1) ...)
+;;
+;; If the function has no free variables, we don't do anything.
+;;
+;; If a variable is mutated (updated by setq), and it is used in a closure
+;; we wrap its definition with list: (list val) and we also replace
+;; var => (car var) wherever this variable is used, and also
+;; (setq var value) => (setcar var value) where it is updated.
+;;
+;; If defun argument is closure mutable, we letbind it and wrap it's
+;; definition with list.
+;; (defun foo (... mutable-arg ...) ...) =>
+;; (defun foo (... m-arg ...) (let ((m-arg (list m-arg))) ...))
+;;
+;;; Code:
+
+;; TODO: (not just for cconv but also for the lexbind changes in general)
+;; - let (e)debug find the value of lexical variables from the stack.
+;; - make eval-region do the eval-sexp-add-defvars danse.
+;; - byte-optimize-form should be applied before cconv.
+;; OTOH, the warnings emitted by cconv-analyze need to come before optimize
+;; since afterwards they can because obnoxious (warnings about an "unused
+;; variable" should not be emitted when the variable use has simply been
+;; optimized away).
+;; - turn defun and defmacro into macros (and remove special handling of
+;; `declare' afterwards).
+;; - let macros specify that some let-bindings come from the same source,
+;; so the unused warning takes all uses into account.
+;; - let interactive specs return a function to build the args (to stash into
+;; command-history).
+;; - canonize code in macro-expand so we don't have to handle (let (var) body)
+;; and other oddities.
+;; - new byte codes for unwind-protect, catch, and condition-case so that
+;; closures aren't needed at all.
+;; - inline source code of different binding mode by first compiling it.
+;; - a reference to a var that is known statically to always hold a constant
+;; should be turned into a byte-constant rather than a byte-stack-ref.
+;; Hmm... right, that's called constant propagation and could be done here,
+;; but when that constant is a function, we have to be careful to make sure
+;; the bytecomp only compiles it once.
+;; - Since we know here when a variable is not mutated, we could pass that
+;; info to the byte-compiler, e.g. by using a new `immutable-let'.
+;; - add tail-calls to bytecode.c and the byte compiler.
+;; - call known non-escaping functions with `goto' rather than `call'.
+;; - optimize mapcar to a while loop.
+
+;; (defmacro dlet (binders &rest body)
+;; ;; Works in both lexical and non-lexical mode.
+;; `(progn
+;; ,@(mapcar (lambda (binder)
+;; `(defvar ,(if (consp binder) (car binder) binder)))
+;; binders)
+;; (let ,binders ,@body)))
+
+;; (defmacro llet (binders &rest body)
+;; ;; Only works in lexical-binding mode.
+;; `(funcall
+;; (lambda ,(mapcar (lambda (binder) (if (consp binder) (car binder) binder))
+;; binders)
+;; ,@body)
+;; ,@(mapcar (lambda (binder) (if (consp binder) (cadr binder)))
+;; binders)))
+
+;; (defmacro letrec (binders &rest body)
+;; ;; Only useful in lexical-binding mode.
+;; ;; As a special-form, we could implement it more efficiently (and cleanly,
+;; ;; making the vars actually unbound during evaluation of the binders).
+;; `(let ,(mapcar (lambda (binder) (if (consp binder) (car binder) binder))
+;; binders)
+;; ,@(delq nil (mapcar (lambda (binder) (if (consp binder) `(setq ,@binder)))
+;; binders))
+;; ,@body))
+
+(eval-when-compile (require 'cl))
+
+(defconst cconv-liftwhen 6
+ "Try to do lambda lifting if the number of arguments + free variables
+is less than this number.")
+;; List of all the variables that are both captured by a closure
+;; and mutated. Each entry in the list takes the form
+;; (BINDER . PARENTFORM) where BINDER is the (VAR VAL) that introduces the
+;; variable (or is just (VAR) for variables not introduced by let).
+(defvar cconv-captured+mutated)
+
+;; List of candidates for lambda lifting.
+;; Each candidate has the form (BINDER . PARENTFORM). A candidate
+;; is a variable that is only passed to `funcall' or `apply'.
+(defvar cconv-lambda-candidates)
+
+;; Alist associating to each function body the list of its free variables.
+(defvar cconv-freevars-alist)
+
+;;;###autoload
+(defun cconv-closure-convert (form)
+ "Main entry point for closure conversion.
+-- FORM is a piece of Elisp code after macroexpansion.
+-- TOPLEVEL(optional) is a boolean variable, true if we are at the root of AST
+
+Returns a form where all lambdas don't have any free variables."
+ ;; (message "Entering cconv-closure-convert...")
+ (let ((cconv-freevars-alist '())
+ (cconv-lambda-candidates '())
+ (cconv-captured+mutated '()))
+ ;; Analyse form - fill these variables with new information.
+ (cconv-analyse-form form '())
+ (setq cconv-freevars-alist (nreverse cconv-freevars-alist))
+ (cconv-convert form nil nil))) ; Env initially empty.
+
+(defconst cconv--dummy-var (make-symbol "ignored"))
+
+(defun cconv--set-diff (s1 s2)
+ "Return elements of set S1 that are not in set S2."
+ (let ((res '()))
+ (dolist (x s1)
+ (unless (memq x s2) (push x res)))
+ (nreverse res)))
+
+(defun cconv--set-diff-map (s m)
+ "Return elements of set S that are not in Dom(M)."
+ (let ((res '()))
+ (dolist (x s)
+ (unless (assq x m) (push x res)))
+ (nreverse res)))
+
+(defun cconv--map-diff (m1 m2)
+ "Return the submap of map M1 that has Dom(M2) removed."
+ (let ((res '()))
+ (dolist (x m1)
+ (unless (assq (car x) m2) (push x res)))
+ (nreverse res)))
+
+(defun cconv--map-diff-elem (m x)
+ "Return the map M minus any mapping for X."
+ ;; Here we assume that X appears at most once in M.
+ (let* ((b (assq x m))
+ (res (if b (remq b m) m)))
+ (assert (null (assq x res))) ;; Check the assumption was warranted.
+ res))
+
+(defun cconv--map-diff-set (m s)
+ "Return the map M minus any mapping for elements of S."
+ ;; Here we assume that X appears at most once in M.
+ (let ((res '()))
+ (dolist (b m)
+ (unless (memq (car b) s) (push b res)))
+ (nreverse res)))
+
+(defun cconv--convert-function (args body env parentform)
+ (assert (equal body (caar cconv-freevars-alist)))
+ (let* ((fvs (cdr (pop cconv-freevars-alist)))
+ (body-new '())
+ (letbind '())
+ (envector ())
+ (i 0)
+ (new-env ()))
+ ;; Build the "formal and actual envs" for the closure-converted function.
+ (dolist (fv fvs)
+ (let ((exp (or (cdr (assq fv env)) fv)))
+ (pcase exp
+ ;; If `fv' is a variable that's wrapped in a cons-cell,
+ ;; we want to put the cons-cell itself in the closure,
+ ;; rather than just a copy of its current content.
+ (`(car ,iexp . ,_)
+ (push iexp envector)
+ (push `(,fv . (car (internal-get-closed-var ,i))) new-env))
+ (_
+ (push exp envector)
+ (push `(,fv . (internal-get-closed-var ,i)) new-env))))
+ (setq i (1+ i)))
+ (setq envector (nreverse envector))
+ (setq new-env (nreverse new-env))
+
+ (dolist (arg args)
+ (if (not (member (cons (list arg) parentform) cconv-captured+mutated))
+ (if (assq arg new-env) (push `(,arg) new-env))
+ (push `(,arg . (car ,arg)) new-env)
+ (push `(,arg (list ,arg)) letbind)))
+
+ (setq body-new (mapcar (lambda (form)
+ (cconv-convert form new-env nil))
+ body))
+
+ (when letbind
+ (let ((special-forms '()))
+ ;; Keep special forms at the beginning of the body.
+ (while (or (stringp (car body-new)) ;docstring.
+ (memq (car-safe (car body-new)) '(interactive declare)))
+ (push (pop body-new) special-forms))
+ (setq body-new
+ `(,@(nreverse special-forms) (let ,letbind . ,body-new)))))
+
+ (cond
+ ((null envector) ;if no freevars - do nothing
+ `(function (lambda ,args . ,body-new)))
+ (t
+ `(internal-make-closure
+ ,args ,envector . ,body-new)))))
+
+(defun cconv-convert (form env extend)
+ ;; This function actually rewrites the tree.
+ "Return FORM with all its lambdas changed so they are closed.
+ENV is a lexical environment mapping variables to the expression
+used to get its value. This is used for variables that are copied into
+closures, moved into cons cells, ...
+ENV is a list where each entry takes the shape either:
+ (VAR . (car EXP)): VAR has been moved into the car of a cons-cell, and EXP
+ is an expression that evaluates to this cons-cell.
+ (VAR . (internal-get-closed-var N)): VAR has been copied into the closure
+ environment's Nth slot.
+ (VAR . (apply-partially F ARG1 ARG2 ..)): VAR has been λ-lifted and takes
+ additional arguments ARGs.
+EXTEND is a list of variables which might need to be accessed even from places
+where they are shadowed, because some part of ENV causes them to be used at
+places where they originally did not directly appear."
+ (assert (not (delq nil (mapcar (lambda (mapping)
+ (if (eq (cadr mapping) 'apply-partially)
+ (cconv--set-diff (cdr (cddr mapping))
+ extend)))
+ env))))
+
+ ;; What's the difference between fvrs and envs?
+ ;; Suppose that we have the code
+ ;; (lambda (..) fvr (let ((fvr 1)) (+ fvr 1)))
+ ;; only the first occurrence of fvr should be replaced by
+ ;; (aref env ...).
+ ;; So initially envs and fvrs are the same thing, but when we descend to
+ ;; the 'let, we delete fvr from fvrs. Why we don't delete fvr from envs?
+ ;; Because in envs the order of variables is important. We use this list
+ ;; to find the number of a specific variable in the environment vector,
+ ;; so we never touch it(unless we enter to the other closure).
+ ;;(if (listp form) (print (car form)) form)
+ (pcase form
+ (`(,(and letsym (or `let* `let)) ,binders . ,body)
+
+ ; let and let* special forms
+ (let ((binders-new '())
+ (new-env env)
+ (new-extend extend))
+
+ (dolist (binder binders)
+ (let* ((value nil)
+ (var (if (not (consp binder))
+ (prog1 binder (setq binder (list binder)))
+ (setq value (cadr binder))
+ (car binder)))
+ (new-val
+ (cond
+ ;; Check if var is a candidate for lambda lifting.
+ ((and (member (cons binder form) cconv-lambda-candidates)
+ (progn
+ (assert (and (eq (car value) 'function)
+ (eq (car (cadr value)) 'lambda)))
+ (assert (equal (cddr (cadr value))
+ (caar cconv-freevars-alist)))
+ ;; Peek at the freevars to decide whether to λ-lift.
+ (let* ((fvs (cdr (car cconv-freevars-alist)))
+ (fun (cadr value))
+ (funargs (cadr fun))
+ (funcvars (append fvs funargs)))
+ ; lambda lifting condition
+ (and fvs (>= cconv-liftwhen (length funcvars))))))
+ ; Lift.
+ (let* ((fvs (cdr (pop cconv-freevars-alist)))
+ (fun (cadr value))
+ (funargs (cadr fun))
+ (funcvars (append fvs funargs))
+ (funcbody (cddr fun))
+ (funcbody-env ()))
+ (push `(,var . (apply-partially ,var . ,fvs)) new-env)
+ (dolist (fv fvs)
+ (pushnew fv new-extend)
+ (if (and (eq 'car (car-safe (cdr (assq fv env))))
+ (not (memq fv funargs)))
+ (push `(,fv . (car ,fv)) funcbody-env)))
+ `(function (lambda ,funcvars .
+ ,(mapcar (lambda (form)
+ (cconv-convert
+ form funcbody-env nil))
+ funcbody)))))
+
+ ;; Check if it needs to be turned into a "ref-cell".
+ ((member (cons binder form) cconv-captured+mutated)
+ ;; Declared variable is mutated and captured.
+ (push `(,var . (car ,var)) new-env)
+ `(list ,(cconv-convert value env extend)))
+
+ ;; Normal default case.
+ (t
+ (if (assq var new-env) (push `(,var) new-env))
+ (cconv-convert value env extend)))))
+
+ ;; The piece of code below letbinds free variables of a λ-lifted
+ ;; function if they are redefined in this let, example:
+ ;; (let* ((fun (lambda (x) (+ x y))) (y 1)) (funcall fun 1))
+ ;; Here we can not pass y as parameter because it is redefined.
+ ;; So we add a (closed-y y) declaration. We do that even if the
+ ;; function is not used inside this let(*). The reason why we
+ ;; ignore this case is that we can't "look forward" to see if the
+ ;; function is called there or not. To treat this case better we'd
+ ;; need to traverse the tree one more time to collect this data, and
+ ;; I think that it's not worth it.
+ (when (memq var new-extend)
+ (let ((closedsym
+ (make-symbol (concat "closed-" (symbol-name var)))))
+ (setq new-env
+ (mapcar (lambda (mapping)
+ (if (not (eq (cadr mapping) 'apply-partially))
+ mapping
+ (assert (eq (car mapping) (nth 2 mapping)))
+ (list* (car mapping)
+ 'apply-partially
+ (car mapping)
+ (mapcar (lambda (arg)
+ (if (eq var arg)
+ closedsym arg))
+ (nthcdr 3 mapping)))))
+ new-env))
+ (setq new-extend (remq var new-extend))
+ (push closedsym new-extend)
+ (push `(,closedsym ,var) binders-new)))
+
+ ;; We push the element after redefined free variables are
+ ;; processed. This is important to avoid the bug when free
+ ;; variable and the function have the same name.
+ (push (list var new-val) binders-new)
+
+ (when (eq letsym 'let*)
+ (setq env new-env)
+ (setq extend new-extend))
+ )) ; end of dolist over binders
+
+ `(,letsym ,(nreverse binders-new)
+ . ,(mapcar (lambda (form)
+ (cconv-convert
+ form new-env new-extend))
+ body))))
+ ;end of let let* forms
+
+ ; first element is lambda expression
+ (`(,(and `(lambda . ,_) fun) . ,args)
+ ;; FIXME: it's silly to create a closure just to call it.
+ ;; Running byte-optimize-form earlier will resolve this.
+ `(funcall
+ ,(cconv-convert `(function ,fun) env extend)
+ ,@(mapcar (lambda (form)
+ (cconv-convert form env extend))
+ args)))
+
+ (`(cond . ,cond-forms) ; cond special form
+ `(cond . ,(mapcar (lambda (branch)
+ (mapcar (lambda (form)
+ (cconv-convert form env extend))
+ branch))
+ cond-forms)))
+
+ (`(function (lambda ,args . ,body) . ,_)
+ (cconv--convert-function args body env form))
+
+ (`(internal-make-closure . ,_)
+ (byte-compile-report-error
+ "Internal error in compiler: cconv called twice?"))
+
+ (`(quote . ,_) form)
+ (`(function . ,_) form)
+
+ ;defconst, defvar
+ (`(,(and sym (or `defconst `defvar)) ,definedsymbol . ,forms)
+ `(,sym ,definedsymbol
+ . ,(mapcar (lambda (form) (cconv-convert form env extend))
+ forms)))
+
+ ;defun, defmacro
+ (`(,(and sym (or `defun `defmacro))
+ ,func ,args . ,body)
+ (assert (equal body (caar cconv-freevars-alist)))
+ (assert (null (cdar cconv-freevars-alist)))
+
+ (let ((new (cconv--convert-function args body env form)))
+ (pcase new
+ (`(function (lambda ,newargs . ,new-body))
+ (assert (equal args newargs))
+ `(,sym ,func ,args . ,new-body))
+ (t (byte-compile-report-error
+ (format "Internal error in cconv of (%s %s ...)" sym func))))))
+
+ ;condition-case
+ (`(condition-case ,var ,protected-form . ,handlers)
+ (let ((newform (cconv--convert-function
+ () (list protected-form) env form)))
+ `(condition-case :fun-body ,newform
+ ,@(mapcar (lambda (handler)
+ (list (car handler)
+ (cconv--convert-function
+ (list (or var cconv--dummy-var))
+ (cdr handler) env form)))
+ handlers))))
+
+ (`(,(and head (or `catch `unwind-protect)) ,form . ,body)
+ `(,head ,(cconv-convert form env extend)
+ :fun-body ,(cconv--convert-function () body env form)))
+
+ (`(track-mouse . ,body)
+ `(track-mouse
+ :fun-body ,(cconv--convert-function () body env form)))
+
+ (`(setq . ,forms) ; setq special form
+ (let ((prognlist ()))
+ (while forms
+ (let* ((sym (pop forms))
+ (sym-new (or (cdr (assq sym env)) sym))
+ (value (cconv-convert (pop forms) env extend)))
+ (push (pcase sym-new
+ ((pred symbolp) `(setq ,sym-new ,value))
+ (`(car ,iexp) `(setcar ,iexp ,value))
+ ;; This "should never happen", but for variables which are
+ ;; mutated+captured+unused, we may end up trying to `setq'
+ ;; on a closed-over variable, so just drop the setq.
+ (_ ;; (byte-compile-report-error
+ ;; (format "Internal error in cconv of (setq %s ..)"
+ ;; sym-new))
+ value))
+ prognlist)))
+ (if (cdr prognlist)
+ `(progn . ,(nreverse prognlist))
+ (car prognlist))))
+
+ (`(,(and (or `funcall `apply) callsym) ,fun . ,args)
+ ;; These are not special forms but we treat them separately for the needs
+ ;; of lambda lifting.
+ (let ((mapping (cdr (assq fun env))))
+ (pcase mapping
+ (`(apply-partially ,_ . ,(and fvs `(,_ . ,_)))
+ (assert (eq (cadr mapping) fun))
+ `(,callsym ,fun
+ ,@(mapcar (lambda (fv)
+ (let ((exp (or (cdr (assq fv env)) fv)))
+ (pcase exp
+ (`(car ,iexp . ,_) iexp)
+ (_ exp))))
+ fvs)
+ ,@(mapcar (lambda (arg)
+ (cconv-convert arg env extend))
+ args)))
+ (_ `(,callsym ,@(mapcar (lambda (arg)
+ (cconv-convert arg env extend))
+ (cons fun args)))))))
+
+ (`(interactive . ,forms)
+ `(interactive . ,(mapcar (lambda (form)
+ (cconv-convert form nil nil))
+ forms)))
+
+ (`(declare . ,_) form) ;The args don't contain code.
+
+ (`(,func . ,forms)
+ ;; First element is function or whatever function-like forms are: or, and,
+ ;; if, progn, prog1, prog2, while, until
+ `(,func . ,(mapcar (lambda (form)
+ (cconv-convert form env extend))
+ forms)))
+
+ (_ (or (cdr (assq form env)) form))))
+
+(unless (fboundp 'byte-compile-not-lexical-var-p)
+ ;; Only used to test the code in non-lexbind Emacs.
+ (defalias 'byte-compile-not-lexical-var-p 'boundp))
+
+(defun cconv--analyse-use (vardata form varkind)
+ "Analyse the use of a variable.
+VARDATA should be (BINDER READ MUTATED CAPTURED CALLED).
+VARKIND is the name of the kind of variable.
+FORM is the parent form that binds this var."
+ ;; use = `(,binder ,read ,mutated ,captured ,called)
+ (pcase vardata
+ (`(,_ nil nil nil nil) nil)
+ (`((,(and (pred (lambda (var) (eq ?_ (aref (symbol-name var) 0)))) var) . ,_)
+ ,_ ,_ ,_ ,_)
+ (byte-compile-log-warning
+ (format "%s `%S' not left unused" varkind var))))
+ (pcase vardata
+ (`((,var . ,_) nil ,_ ,_ nil)
+ ;; FIXME: This gives warnings in the wrong order, with imprecise line
+ ;; numbers and without function name info.
+ (unless (or ;; Uninterned symbols typically come from macro-expansion, so
+ ;; it is often non-trivial for the programmer to avoid such
+ ;; unused vars.
+ (not (intern-soft var))
+ (eq ?_ (aref (symbol-name var) 0))
+ ;; As a special exception, ignore "ignore".
+ (eq var 'ignored))
+ (byte-compile-log-warning (format "Unused lexical %s `%S'"
+ varkind var))))
+ ;; If it's unused, there's no point converting it into a cons-cell, even if
+ ;; it's captured and mutated.
+ (`(,binder ,_ t t ,_)
+ (push (cons binder form) cconv-captured+mutated))
+ (`(,(and binder `(,_ (function (lambda . ,_)))) nil nil nil t)
+ (push (cons binder form) cconv-lambda-candidates))))
+
+(defun cconv--analyse-function (args body env parentform)
+ (let* ((newvars nil)
+ (freevars (list body))
+ ;; We analyze the body within a new environment where all uses are
+ ;; nil, so we can distinguish uses within that function from uses
+ ;; outside of it.
+ (envcopy
+ (mapcar (lambda (vdata) (list (car vdata) nil nil nil nil)) env))
+ (newenv envcopy))
+ ;; Push it before recursing, so cconv-freevars-alist contains entries in
+ ;; the order they'll be used by closure-convert-rec.
+ (push freevars cconv-freevars-alist)
+ (dolist (arg args)
+ (cond
+ ((byte-compile-not-lexical-var-p arg)
+ (byte-compile-log-warning
+ (format "Argument %S is not a lexical variable" arg)))
+ ((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ...
+ (t (let ((varstruct (list arg nil nil nil nil)))
+ (push (cons (list arg) (cdr varstruct)) newvars)
+ (push varstruct newenv)))))
+ (dolist (form body) ;Analyse body forms.
+ (cconv-analyse-form form newenv))
+ ;; Summarize resulting data about arguments.
+ (dolist (vardata newvars)
+ (cconv--analyse-use vardata parentform "argument"))
+ ;; Transfer uses collected in `envcopy' (via `newenv') back to `env';
+ ;; and compute free variables.
+ (while env
+ (assert (and envcopy (eq (caar env) (caar envcopy))))
+ (let ((free nil)
+ (x (cdr (car env)))
+ (y (cdr (car envcopy))))
+ (while x
+ (when (car y) (setcar x t) (setq free t))
+ (setq x (cdr x) y (cdr y)))
+ (when free
+ (push (caar env) (cdr freevars))
+ (setf (nth 3 (car env)) t))
+ (setq env (cdr env) envcopy (cdr envcopy))))))
+
+(defun cconv-analyse-form (form env)
+ "Find mutated variables and variables captured by closure.
+Analyse lambdas if they are suitable for lambda lifting.
+- FORM is a piece of Elisp code after macroexpansion.
+- ENV is an alist mapping each enclosing lexical variable to its info.
+ I.e. each element has the form (VAR . (READ MUTATED CAPTURED CALLED)).
+This function does not return anything but instead fills the
+`cconv-captured+mutated' and `cconv-lambda-candidates' variables
+and updates the data stored in ENV."
+ (pcase form
+ ; let special form
+ (`(,(and (or `let* `let) letsym) ,binders . ,body-forms)
+
+ (let ((orig-env env)
+ (newvars nil)
+ (var nil)
+ (value nil))
+ (dolist (binder binders)
+ (if (not (consp binder))
+ (progn
+ (setq var binder) ; treat the form (let (x) ...) well
+ (setq binder (list binder))
+ (setq value nil))
+ (setq var (car binder))
+ (setq value (cadr binder))
+
+ (cconv-analyse-form value (if (eq letsym 'let*) env orig-env)))
+
+ (unless (byte-compile-not-lexical-var-p var)
+ (let ((varstruct (list var nil nil nil nil)))
+ (push (cons binder (cdr varstruct)) newvars)
+ (push varstruct env))))
+
+ (dolist (form body-forms) ; Analyse body forms.
+ (cconv-analyse-form form env))
+
+ (dolist (vardata newvars)
+ (cconv--analyse-use vardata form "variable"))))
+
+ ; defun special form
+ (`(,(or `defun `defmacro) ,func ,vrs . ,body-forms)
+ (when env
+ (byte-compile-log-warning
+ (format "Function %S will ignore its context %S"
+ func (mapcar #'car env))
+ t :warning))
+ (cconv--analyse-function vrs body-forms nil form))
+
+ (`(function (lambda ,vrs . ,body-forms))
+ (cconv--analyse-function vrs body-forms env form))
+
+ (`(setq . ,forms)
+ ;; If a local variable (member of env) is modified by setq then
+ ;; it is a mutated variable.
+ (while forms
+ (let ((v (assq (car forms) env))) ; v = non nil if visible
+ (when v (setf (nth 2 v) t)))
+ (cconv-analyse-form (cadr forms) env)
+ (setq forms (cddr forms))))
+
+ (`((lambda . ,_) . ,_) ; first element is lambda expression
+ (dolist (exp `((function ,(car form)) . ,(cdr form)))
+ (cconv-analyse-form exp env)))
+
+ (`(cond . ,cond-forms) ; cond special form
+ (dolist (forms cond-forms)
+ (dolist (form forms) (cconv-analyse-form form env))))
+
+ (`(quote . ,_) nil) ; quote form
+ (`(function . ,_) nil) ; same as quote
+
+ (`(condition-case ,var ,protected-form . ,handlers)
+ ;; FIXME: The bytecode for condition-case forces us to wrap the
+ ;; form and handlers in closures (for handlers, it's understandable
+ ;; but not for the protected form).
+ (cconv--analyse-function () (list protected-form) env form)
+ (dolist (handler handlers)
+ (cconv--analyse-function (if var (list var)) (cdr handler) env form)))
+
+ ;; FIXME: The bytecode for catch forces us to wrap the body.
+ (`(,(or `catch `unwind-protect) ,form . ,body)
+ (cconv-analyse-form form env)
+ (cconv--analyse-function () body env form))
+
+ ;; FIXME: The lack of bytecode for track-mouse forces us to wrap the body.
+ ;; `track-mouse' really should be made into a macro.
+ (`(track-mouse . ,body)
+ (cconv--analyse-function () body env form))
+
+ (`(,(or `defconst `defvar) ,var ,value . ,_)
+ (push var byte-compile-bound-variables)
+ (cconv-analyse-form value env))
+
+ (`(,(or `funcall `apply) ,fun . ,args)
+ ;; Here we ignore fun because funcall and apply are the only two
+ ;; functions where we can pass a candidate for lambda lifting as
+ ;; argument. So, if we see fun elsewhere, we'll delete it from
+ ;; lambda candidate list.
+ (let ((fdata (and (symbolp fun) (assq fun env))))
+ (if fdata
+ (setf (nth 4 fdata) t)
+ (cconv-analyse-form fun env)))
+ (dolist (form args) (cconv-analyse-form form env)))
+
+ (`(interactive . ,forms)
+ ;; These appear within the function body but they don't have access
+ ;; to the function's arguments.
+ ;; We could extend this to allow interactive specs to refer to
+ ;; variables in the function's enclosing environment, but it doesn't
+ ;; seem worth the trouble.
+ (dolist (form forms) (cconv-analyse-form form nil)))
+
+ (`(declare . ,_) nil) ;The args don't contain code.
+
+ (`(,_ . ,body-forms) ; First element is a function or whatever.
+ (dolist (form body-forms) (cconv-analyse-form form env)))
+
+ ((pred symbolp)
+ (let ((dv (assq form env))) ; dv = declared and visible
+ (when dv
+ (setf (nth 1 dv) t))))))
+
+(provide 'cconv)
+;;; cconv.el ends here
diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el
index ace94c2bc6d..01eb1efdc3b 100644
--- a/lisp/emacs-lisp/chart.el
+++ b/lisp/emacs-lisp/chart.el
@@ -1,6 +1,6 @@
;;; chart.el --- Draw charts (bar charts, etc)
-;; Copyright (C) 1996, 1998, 1999, 2001, 2004, 2005, 2007, 2008, 2009, 2010, 2011
+;; Copyright (C) 1996, 1998-1999, 2001, 2004-2005, 2007-2011
;; Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -62,21 +62,13 @@
(require 'eieio)
;;; Code:
-(defvar chart-map nil "Keymap used in chart mode.")
-(if chart-map
- ()
- (setq chart-map (make-sparse-keymap))
- )
+(defvar chart-mode-map (make-sparse-keymap) "Keymap used in chart mode.")
+(define-obsolete-variable-alias 'chart-map 'chart-mode-map "24.1")
(defvar chart-local-object nil
"Local variable containing the locally displayed chart object.")
(make-variable-buffer-local 'chart-local-object)
-(defvar chart-face-list nil
- "Faces used to colorize charts.
-List is limited currently, which is ok since you really can't display
-too much in text characters anyways.")
-
(defvar chart-face-color-list '("red" "green" "blue"
"cyan" "yellow" "purple")
"Colors to use when generating `chart-face-list'.
@@ -94,41 +86,42 @@ Useful if new Emacs is used on B&W display.")
:group 'eieio
:type 'boolean)
-(if (and (if (fboundp 'display-color-p)
- (display-color-p)
- window-system)
- (not chart-face-list))
- (let ((cl chart-face-color-list)
- (pl chart-face-pixmap-list)
- nf)
- (while cl
- (setq nf (make-face (intern (concat "chart-" (car cl) "-" (car pl)))))
- (if (condition-case nil
- (> (x-display-color-cells) 4)
- (error t))
- (set-face-background nf (car cl))
- (set-face-background nf "white"))
- (set-face-foreground nf "black")
- (if (and chart-face-use-pixmaps
- pl
- (fboundp 'set-face-background-pixmap))
- (condition-case nil
- (set-face-background-pixmap nf (car pl))
- (error (message "Cannot set background pixmap %s" (car pl)))))
- (setq chart-face-list (cons nf chart-face-list))
- (setq cl (cdr cl)
- pl (cdr pl)))))
-
-(defun chart-mode ()
+(defvar chart-face-list
+ (if (if (fboundp 'display-color-p)
+ (display-color-p)
+ window-system)
+ (let ((cl chart-face-color-list)
+ (pl chart-face-pixmap-list)
+ (faces ())
+ nf)
+ (while cl
+ (setq nf (make-face
+ (intern (concat "chart-" (car cl) "-" (car pl)))))
+ (set-face-background nf (if (condition-case nil
+ (> (x-display-color-cells) 4)
+ (error t))
+ (car cl)
+ "white"))
+ (set-face-foreground nf "black")
+ (if (and chart-face-use-pixmaps
+ pl
+ (fboundp 'set-face-background-pixmap))
+ (condition-case nil
+ (set-face-background-pixmap nf (car pl))
+ (error (message "Cannot set background pixmap %s" (car pl)))))
+ (push nf faces)
+ (setq cl (cdr cl)
+ pl (cdr pl)))
+ faces))
+ "Faces used to colorize charts.
+List is limited currently, which is ok since you really can't display
+too much in text characters anyways.")
+
+(define-derived-mode chart-mode fundamental-mode "CHART"
"Define a mode in Emacs for displaying a chart."
- (kill-all-local-variables)
- (use-local-map chart-map)
- (setq major-mode 'chart-mode
- mode-name "CHART")
(buffer-disable-undo)
(set (make-local-variable 'font-lock-global-modes) nil)
- (font-lock-mode -1)
- (run-hooks 'chart-mode-hook)
+ (font-lock-mode -1) ;Isn't it off already? --Stef
)
(defun chart-new-buffer (obj)
@@ -529,9 +522,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 +743,4 @@ SORT-PRED if desired."
(provide 'chart)
-;; arch-tag: 43847e44-5b45-465e-adc9-e505490a6b59
;;; chart.el ends here
diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el
index a84be940564..e15920ef009 100644
--- a/lisp/emacs-lisp/check-declare.el
+++ b/lisp/emacs-lisp/check-declare.el
@@ -1,6 +1,6 @@
;;; check-declare.el --- Check declare-function statements
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Glenn Morris <rgm@gnu.org>
;; Keywords: lisp, tools, maint
@@ -88,9 +88,11 @@ don't know how to recognize (e.g. some macros)."
;; FIXME we could theoretically be inside a string.
(while (re-search-forward "^[ \t]*\\((declare-function\\)[ \t\n]" nil t)
(goto-char (match-beginning 1))
- (if (and (setq form (ignore-errors (read (current-buffer)))
- len (length form))
- (> len 2) (< len 6)
+ (if (and (setq form (ignore-errors (read (current-buffer))))
+ ;; Exclude element of byte-compile-initial-macro-environment.
+ (or (listp (cdr form)) (setq form nil))
+ (> (setq len (length form)) 2)
+ (< len 6)
(symbolp (setq fn (cadr form)))
(setq fn (symbol-name fn)) ; later we use as a search string
(stringp (setq fnfile (nth 2 form)))
@@ -104,7 +106,7 @@ don't know how to recognize (e.g. some macros)."
(symbolp (setq fileonly (nth 4 form))))
(setq alist (cons (list fnfile fn arglist fileonly) alist))
;; FIXME make this more noticeable.
- (message "Malformed declaration for `%s'" (cadr form)))))
+ (if form (message "Malformed declaration for `%s'" (cadr form))))))
(message "%sdone" m)
alist))
@@ -314,5 +316,4 @@ Returns non-nil if any false statements are found."
(provide 'check-declare)
-;; arch-tag: a4d6cdc4-deb7-4502-b327-0e4ef3d82d96
;;; check-declare.el ends here.
diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el
index 70360eb77cf..9880e2918b0 100644
--- a/lisp/emacs-lisp/checkdoc.el
+++ b/lisp/emacs-lisp/checkdoc.el
@@ -1,7 +1,6 @@
;;; checkdoc.el --- check documentation strings for style requirements
-;; Copyright (C) 1997, 1998, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-1998, 2001-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 0.6.2
@@ -201,9 +200,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 +249,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 +428,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 +510,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 +617,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 +707,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 +821,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 +942,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 +965,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 +1202,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 +1361,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 +1369,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 +1379,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 +1477,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 +1497,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 +1512,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 +1612,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 +1757,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
@@ -2004,49 +1984,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)
@@ -2054,43 +2030,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
@@ -2258,8 +2230,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
@@ -2670,8 +2642,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")
@@ -2681,5 +2652,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 4c633eeba4e..7468a0237cf 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -1,10 +1,10 @@
;;; cl-extra.el --- Common Lisp features, part 2
-;; Copyright (C) 1993, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2000-2011 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Keywords: extensions
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -685,7 +685,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))
@@ -766,20 +766,15 @@ This also does some trivial optimizations to make the form prettier."
(eq (car-safe (car body)) 'interactive))
(push (list 'quote (pop body)) decls))
(put (car (last cl-closure-vars)) 'used t)
- (append
- (list 'list '(quote lambda) '(quote (&rest --cl-rest--)))
- (sublis sub (nreverse decls))
- (list
- (list* 'list '(quote apply)
- (list 'function
- (list* 'lambda
- (append new (cadadr form))
- (sublis sub body)))
- (nconc (mapcar (function
- (lambda (x)
- (list 'list '(quote quote) x)))
- cl-closure-vars)
- '((quote --cl-rest--)))))))
+ `(list 'lambda '(&rest --cl-rest--)
+ ,@(sublis sub (nreverse decls))
+ (list 'apply
+ (list 'quote
+ #'(lambda ,(append new (cadadr form))
+ ,@(sublis sub body)))
+ ,@(nconc (mapcar (lambda (x) `(list 'quote ,x))
+ cl-closure-vars)
+ '((quote --cl-rest--))))))
(list (car form) (list* 'lambda (cadadr form) body))))
(let ((found (assq (cadr form) env)))
(if (and found (ignore-errors
@@ -825,5 +820,4 @@ This also does some trivial optimizations to make the form prettier."
;; generated-autoload-file: "cl-loaddefs.el"
;; End:
-;; arch-tag: bcd03437-0871-43fb-a8f1-ad0e0b5427ed
;;; cl-extra.el ends here
diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el
index cbf35f3e7d4..787f276ecae 100644
--- a/lisp/emacs-lisp/cl-indent.el
+++ b/lisp/emacs-lisp/cl-indent.el
@@ -1,12 +1,12 @@
;;; cl-indent.el --- enhanced lisp-indent mode
-;; Copyright (C) 1987, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1987, 2000-2011 Free Software Foundation, Inc.
;; Author: Richard Mlynarik <mly@eddie.mit.edu>
;; Created: July 1987
;; Maintainer: FSF
;; Keywords: lisp, tools
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -690,5 +690,4 @@ For example, the function `case' has an indent property
;(put 'defclass 'common-lisp-indent-function '((&whole 2 &rest (&whole 2 &rest 1) &rest (&whole 2 &rest 1)))
;(put 'defgeneric 'common-lisp-indent-function 'defun)
-;; arch-tag: 7914d50f-92ec-4476-93fc-0f043a380e03
;;; cl-indent.el ends here
diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el
index 2fb7c0434b5..4c824d4a6d4 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" "de874ef326082f133b0324505ad37330")
+;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "26339d9571f9485bf34fa6d2ae38fc84")
;;; Generated autoloads from cl-extra.el
(autoload 'coerce "cl-extra" "\
@@ -282,7 +282,7 @@ Not documented
;;;;;; 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" "12451ac01f94f10d30cf7a8f92625c42")
+;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "fe8a5acbe14e32846a77578b2165fab5")
;;; Generated autoloads from cl-macs.el
(autoload 'gensym "cl-macs" "\
@@ -319,7 +319,7 @@ its argument list allows full Common Lisp conventions.
\(fn FUNC)" nil (quote macro))
(autoload 'destructuring-bind "cl-macs" "\
-Not documented
+
\(fn ARGS EXPR &rest BODY)" nil (quote macro))
@@ -445,7 +445,7 @@ from OBARRAY.
\(fn (VAR [OBARRAY [RESULT]]) BODY...)" nil (quote macro))
(autoload 'do-all-symbols "cl-macs" "\
-Not documented
+
\(fn SPEC &rest BODY)" nil (quote macro))
@@ -500,16 +500,16 @@ Like `let', but lexically scoped.
The main visible difference is that lambdas inside BODY will create
lexical closures as in Common Lisp.
-\(fn VARLIST BODY)" nil (quote macro))
+\(fn BINDINGS BODY)" nil (quote macro))
(autoload 'lexical-let* "cl-macs" "\
Like `let*', but lexically scoped.
The main visible difference is that lambdas inside BODY, and in
-successive bindings within VARLIST, will create lexical closures
+successive bindings within BINDINGS, will create lexical closures
as in Common Lisp. This is similar to the behavior of `let*' in
Common Lisp.
-\(fn VARLIST BODY)" nil (quote macro))
+\(fn BINDINGS BODY)" nil (quote macro))
(autoload 'multiple-value-bind "cl-macs" "\
Collect multiple return values.
@@ -531,17 +531,17 @@ values. For compatibility, (values A B C) is a synonym for (list A B C).
\(fn (SYM...) FORM)" nil (quote macro))
(autoload 'locally "cl-macs" "\
-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
+
\(fn &rest SPECS)" nil (quote macro))
@@ -601,7 +601,7 @@ before assigning any PLACEs to the corresponding values.
\(fn PLACE VAL PLACE VAL ...)" nil (quote macro))
(autoload 'cl-do-pop "cl-macs" "\
-Not documented
+
\(fn PLACE)" nil nil)
@@ -689,7 +689,7 @@ value, that slot cannot be set via `setf'.
\(fn NAME SLOTS...)" nil (quote macro))
(autoload 'cl-struct-setf-expander "cl-macs" "\
-Not documented
+
\(fn X NAME ACCESSOR PRED-FORM POS)" nil nil)
@@ -735,7 +735,7 @@ and then returning foo.
\(fn FUNC ARGS &rest BODY)" nil (quote macro))
(autoload 'compiler-macroexpand "cl-macs" "\
-Not documented
+
\(fn FORM)" nil nil)
@@ -759,7 +759,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" "50667ae0688aa15dad8a585096e7144f")
+;;;;;; replace fill reduce) "cl-seq" "cl-seq.el" "df375ddc313f0c1c262cacab5cffd3e4")
;;; Generated autoloads from cl-seq.el
(autoload 'reduce "cl-seq" "\
@@ -1242,7 +1242,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 3e9d7c27258..9ce3dd6a7fe 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -1,11 +1,11 @@
;;; cl-macs.el --- Common Lisp macros
-;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2001-2011 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Version: 2.02
;; Keywords: extensions
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -128,6 +128,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
@@ -491,7 +497,7 @@ The result of the body appears to the compiler as a quoted constant."
(symbol-function 'byte-compile-file-form)))
(list 'byte-compile-file-form (list 'quote set))
'(byte-compile-file-form form)))
- (print set (symbol-value 'bytecomp-outbuffer)))
+ (print set (symbol-value 'byte-compile--outbuffer)))
(list 'symbol-value (list 'quote temp)))
(list 'quote (eval form))))
@@ -592,27 +598,6 @@ called from BODY."
(list* 'catch (list 'quote (intern (format "--cl-block-%s--" name)))
body))))
-(defvar cl-active-block-names nil)
-
-(put 'cl-block-wrapper 'byte-compile 'cl-byte-compile-block)
-(defun cl-byte-compile-block (cl-form)
- (if (fboundp 'byte-compile-form-do-effect) ; Check for optimizing compiler
- (progn
- (let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil))
- (cl-active-block-names (cons cl-entry cl-active-block-names))
- (cl-body (byte-compile-top-level
- (cons 'progn (cddr (nth 1 cl-form))))))
- (if (cdr cl-entry)
- (byte-compile-form (list 'catch (nth 1 (nth 1 cl-form)) cl-body))
- (byte-compile-form cl-body))))
- (byte-compile-form (nth 1 cl-form))))
-
-(put 'cl-block-throw 'byte-compile 'cl-byte-compile-throw)
-(defun cl-byte-compile-throw (cl-form)
- (let ((cl-found (assq (nth 1 (nth 1 cl-form)) cl-active-block-names)))
- (if cl-found (setcdr cl-found t)))
- (byte-compile-normal-call (cons 'throw (cdr cl-form))))
-
;;;###autoload
(defmacro return (&optional result)
"Return from the block named nil.
@@ -632,7 +617,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 +625,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 +640,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 +650,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 +691,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 +727,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 +772,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 +782,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 +794,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 +817,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 +829,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 +863,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 +879,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 +899,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 +914,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,17 +942,26 @@ Valid clauses are:
loop-for-steps)))
((memq word '(window windows))
- (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args)))
- (temp (make-symbol "--cl-var--")))
+ (let ((scr (and (memq (car loop-args) '(in of)) (cl-pop2 loop-args)))
+ (temp (make-symbol "--cl-var--"))
+ (minip (make-symbol "--cl-minip--")))
(push (list var (if scr
(list 'frame-selected-window scr)
'(selected-window)))
loop-for-bindings)
+ ;; If we started in the minibuffer, we need to
+ ;; ensure that next-window will bring us back there
+ ;; at some point. (Bug#7492).
+ ;; (Consider using walk-windows instead of loop if
+ ;; you care about such things.)
+ (push (list minip `(minibufferp (window-buffer ,var)))
+ loop-for-bindings)
(push (list temp nil) loop-for-bindings)
(push (list 'prog1 (list 'not (list 'eq var temp))
(list 'or temp (list 'setq temp var)))
loop-body)
- (push (list var (list 'next-window var)) loop-for-steps)))
+ (push (list var (list 'next-window var minip))
+ loop-for-steps)))
(t
(let ((handler (and (symbolp word)
@@ -975,9 +969,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 +987,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 +1000,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 +1015,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 +1046,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 +1074,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 +1101,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 +1152,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)))
@@ -1412,7 +1406,7 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
"Like `let', but lexically scoped.
The main visible difference is that lambdas inside BODY will create
lexical closures as in Common Lisp.
-\n(fn VARLIST BODY)"
+\n(fn BINDINGS BODY)"
(let* ((cl-closure-vars cl-closure-vars)
(vars (mapcar (function
(lambda (x)
@@ -1455,10 +1449,10 @@ lexical closures as in Common Lisp.
(defmacro lexical-let* (bindings &rest body)
"Like `let*', but lexically scoped.
The main visible difference is that lambdas inside BODY, and in
-successive bindings within VARLIST, will create lexical closures
+successive bindings within BINDINGS, will create lexical closures
as in Common Lisp. This is similar to the behavior of `let*' in
Common Lisp.
-\n(fn VARLIST BODY)"
+\n(fn BINDINGS BODY)"
(if (null bindings) (cons 'progn body)
(setq bindings (reverse bindings))
(while bindings
@@ -1741,15 +1735,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 +1748,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 +1792,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*))
@@ -2400,11 +2401,13 @@ value, that slot cannot be set via `setf'.
(push (cons name t) side-eff))))
(if print-auto (nconc print-func (list '(princ ")" cl-s) t)))
(if print-func
- (push (list 'push
- (list 'function
- (list 'lambda '(cl-x cl-s cl-n)
- (list 'and pred-form print-func)))
- 'custom-print-functions) forms))
+ (push `(push
+ ;; The auto-generated function does not pay attention to
+ ;; the depth argument cl-n.
+ (lambda (cl-x cl-s ,(if print-auto '_cl-n 'cl-n))
+ (and ,pred-form ,print-func))
+ custom-print-functions)
+ forms))
(push (list 'setq tag-symbol (list 'list (list 'quote tag))) forms)
(push (list* 'eval-when '(compile load eval)
(list 'put (list 'quote name) '(quote cl-struct-slots)
@@ -2558,7 +2561,7 @@ and then returning foo."
(cl-transform-function-property
func 'cl-compiler-macro
(cons (if (memq '&whole args) (delq '&whole args)
- (cons '--cl-whole-arg-- args)) body))
+ (cons '_cl-whole-arg args)) body))
(list 'or (list 'get (list 'quote func) '(quote byte-compile))
(list 'progn
(list 'put (list 'quote func) '(quote byte-compile)
@@ -2596,6 +2599,27 @@ and then returning foo."
(byte-compile-normal-call form)
(byte-compile-form form)))
+;; Optimize away unused block-wrappers.
+
+(defvar cl-active-block-names nil)
+
+(define-compiler-macro cl-block-wrapper (cl-form)
+ (let* ((cl-entry (cons (nth 1 (nth 1 cl-form)) nil))
+ (cl-active-block-names (cons cl-entry cl-active-block-names))
+ (cl-body (macroexpand-all ;Performs compiler-macro expansions.
+ (cons 'progn (cddr cl-form))
+ macroexpand-all-environment)))
+ ;; FIXME: To avoid re-applying macroexpand-all, we'd like to be able
+ ;; to indicate that this return value is already fully expanded.
+ (if (cdr cl-entry)
+ `(catch ,(nth 1 cl-form) ,@(cdr cl-body))
+ cl-body)))
+
+(define-compiler-macro cl-block-throw (cl-tag cl-value)
+ (let ((cl-found (assq (nth 1 cl-tag) cl-active-block-names)))
+ (if cl-found (setcdr cl-found t)))
+ `(throw ,cl-tag ,cl-value))
+
;;;###autoload
(defmacro defsubst* (name args &rest body)
"Define NAME as a function.
@@ -2616,21 +2640,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 +2792,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 250110528d9..1c578556835 100644
--- a/lisp/emacs-lisp/cl-seq.el
+++ b/lisp/emacs-lisp/cl-seq.el
@@ -1,11 +1,11 @@
;;; cl-seq.el --- Common Lisp features, part 3
-;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2001-2011 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Version: 2.02
;; Keywords: extensions
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -47,6 +47,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 +84,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 +101,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)
@@ -1019,5 +1017,4 @@ Atoms are compared by `eql'; cons cells are compared recursively.
;; generated-autoload-file: "cl-loaddefs.el"
;; End:
-;; arch-tag: ec1cc072-9006-4225-b6ba-d6b07ed1710c
;;; cl-seq.el ends here
diff --git a/lisp/emacs-lisp/cl-specs.el b/lisp/emacs-lisp/cl-specs.el
index c21fbb1a17c..3556b6c1ecf 100644
--- a/lisp/emacs-lisp/cl-specs.el
+++ b/lisp/emacs-lisp/cl-specs.el
@@ -1,9 +1,9 @@
;;; cl-specs.el --- Edebug specs for cl.el -*- no-byte-compile: t -*-
-;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2001-2011 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
@@ -67,7 +67,7 @@
(def-edebug-spec multiple-value-list (form))
(def-edebug-spec multiple-value-call (function-form body))
(def-edebug-spec multiple-value-bind
- ((&rest symbolp) form cl-declarations body))
+ ((&rest symbolp) form body))
(def-edebug-spec multiple-value-setq ((&rest symbolp) form))
(def-edebug-spec multiple-value-prog1 (form body))
@@ -468,5 +468,4 @@
(def-edebug-spec loop-d-type-spec
(&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec))
-;; arch-tag: b29aa3c2-cf67-4af8-9ee1-318fea61b478
;;; cl-specs.el ends here
diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el
index 54e6e9e70c2..526475eb1bd 100644
--- a/lisp/emacs-lisp/cl.el
+++ b/lisp/emacs-lisp/cl.el
@@ -1,7 +1,6 @@
;;; cl.el --- Common Lisp extensions for Emacs
-;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2001-2011 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Version: 2.02
@@ -162,7 +161,14 @@ an element already on the list.
(if (symbolp place)
(if (null keys)
`(let ((x ,x))
- (if (memql x ,place) ,place (setq ,place (cons x ,place))))
+ (if (memql x ,place)
+ ;; This symbol may later on expand to actual code which then
+ ;; trigger warnings like "value unused" since pushnew's return
+ ;; value is rarely used. It should not matter that other
+ ;; warnings may be silenced, since `place' is used earlier and
+ ;; should have triggered them already.
+ (with-no-warnings ,place)
+ (setq ,place (cons x ,place))))
(list 'setq place (list* 'adjoin x place keys)))
(list* 'callf2 'adjoin x place keys)))
@@ -272,9 +278,9 @@ definitions to shadow the loaded ones for use in file byte-compilation.
(defvar cl-compiling-file nil)
(defun cl-compiling-file ()
(or cl-compiling-file
- (and (boundp 'bytecomp-outbuffer)
- (bufferp (symbol-value 'bytecomp-outbuffer))
- (equal (buffer-name (symbol-value 'bytecomp-outbuffer))
+ (and (boundp 'byte-compile--outbuffer)
+ (bufferp (symbol-value 'byte-compile--outbuffer))
+ (equal (buffer-name (symbol-value 'byte-compile--outbuffer))
" *Compiler Output*"))))
(defvar cl-proclaims-deferred nil)
@@ -645,7 +651,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.
@@ -677,5 +682,4 @@ If ALIST is non-nil, the new pairs are prepended to it."
;; byte-compile-warnings: (not cl-functions)
;; End:
-;; arch-tag: 5f07fa74-f153-4524-9303-21f5be125851
;;; cl.el ends here
diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el
index 1caa80be389..582785a0e90 100644
--- a/lisp/emacs-lisp/copyright.el
+++ b/lisp/emacs-lisp/copyright.el
@@ -1,7 +1,6 @@
;;; copyright.el --- update the copyright notice in current buffer
-;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1998, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1991-1995, 1998, 2001-2011 Free Software Foundation, Inc.
;; Author: Daniel Pfeiffer <occitan@esperanto.org>
;; Keywords: maint, tools
@@ -47,6 +46,7 @@ This is useful for ChangeLogs."
:group 'copyright
:type 'boolean
:version "23.1")
+;;;###autoload(put 'copyright-at-end-flag 'safe-local-variable 'booleanp)
(defcustom copyright-regexp
"\\(©\\|@copyright{}\\|[Cc]opyright\\s *:?\\s *\\(?:(C)\\)?\
@@ -66,6 +66,11 @@ someone else or to a group for which you do not work."
:group 'copyright
:type 'regexp)
+;; The worst that can happen is a malicious regexp that overflows in
+;; the regexp matcher, a minor nuisance. It's a pain to be always
+;; prompted if you want to put this in a dir-locals.el.
+;;;###autoload(put 'copyright-names-regexp 'safe-local-variable 'stringp)
+
(defcustom copyright-years-regexp
"\\(\\s *\\)\\([1-9]\\([-0-9, ';/*%#\n\t]\\|\\s<\\|\\s>\\)*[0-9]+\\)"
"Match additional copyright notice years.
@@ -73,6 +78,19 @@ The second \\( \\) construct must match the years."
:group 'copyright
:type 'regexp)
+;; See "Copyright Notices" in maintain.info.
+;; TODO? 'end only for ranges at the end, other for all ranges.
+;; Minimum limit on the size of a range?
+(defcustom copyright-year-ranges nil
+ "Non-nil if individual consecutive years should be replaced with a range.
+For example: 2005, 2006, 2007, 2008 might be replaced with 2005-2008.
+If you use ranges, you should add an explanatory note in a README file.
+The function `copyright-fix-year' respects this variable."
+ :group 'copyright
+ :type 'boolean
+ :version "24.1")
+
+;;;###autoload(put 'copyright-year-ranges 'safe-local-variable 'booleanp)
(defcustom copyright-query 'function
"If non-nil, ask user before changing copyright.
@@ -120,76 +138,88 @@ When this is `function', only ask when called non-interactively."
(< (point) (- (point-max) copyright-limit))
(> (point) (+ (point-min) copyright-limit)))))
+(defun copyright-find-copyright ()
+ "Return non-nil if a copyright header suitable for updating is found.
+The header must match `copyright-regexp' and `copyright-names-regexp', if set.
+This function sets the match-data that `copyright-update-year' uses."
+ (widen)
+ (goto-char (copyright-start-point))
+ (condition-case err
+ ;; (1) Need the extra \\( \\) around copyright-regexp because we
+ ;; goto (match-end 1) below. See note (2) below.
+ (copyright-re-search (concat "\\(" copyright-regexp
+ "\\)\\([ \t]*\n\\)?.*\\(?:"
+ copyright-names-regexp "\\)")
+ (copyright-limit)
+ t)
+ ;; In case the regexp is rejected. This is useful because
+ ;; copyright-update is typically called from before-save-hook where
+ ;; such an error is very inconvenient for the user.
+ (error (message "Can't update copyright: %s" err) nil)))
+
+(defun copyright-find-end ()
+ "Possibly adjust the search performed by `copyright-find-copyright'.
+If the years continue onto multiple lines that are marked as comments,
+skips to the end of all the years."
+ (while (save-excursion
+ (and (eq (following-char) ?,)
+ (progn (forward-char 1) t)
+ (progn (skip-chars-forward " \t") (eolp))
+ comment-start-skip
+ (save-match-data
+ (forward-line 1)
+ (and (looking-at comment-start-skip)
+ (goto-char (match-end 0))))
+ (looking-at-p copyright-years-regexp)))
+ (forward-line 1)
+ (re-search-forward comment-start-skip)
+ ;; (2) Need the extra \\( \\) so that the years are subexp 3, as
+ ;; they are at note (1) above.
+ (re-search-forward (format "\\(%s\\)" copyright-years-regexp))))
+
(defun copyright-update-year (replace noquery)
- (when
- (condition-case err
- ;; (1) Need the extra \\( \\) around copyright-regexp because we
- ;; goto (match-end 1) below. See note (2) below.
- (copyright-re-search (concat "\\(" copyright-regexp
- "\\)\\([ \t]*\n\\)?.*\\(?:"
- copyright-names-regexp "\\)")
- (copyright-limit)
- t)
- ;; In case the regexp is rejected. This is useful because
- ;; copyright-update is typically called from before-save-hook where
- ;; such an error is very inconvenient for the user.
- (error (message "Can't update copyright: %s" err) nil))
- (goto-char (match-end 1))
- ;; If the years are continued onto multiple lines
- ;; that are marked as comments, skip to the end of the years anyway.
- (while (save-excursion
- (and (eq (following-char) ?,)
- (progn (forward-char 1) t)
- (progn (skip-chars-forward " \t") (eolp))
- comment-start-skip
- (save-match-data
- (forward-line 1)
- (and (looking-at comment-start-skip)
- (goto-char (match-end 0))))
- (looking-at-p copyright-years-regexp)))
- (forward-line 1)
- (re-search-forward comment-start-skip)
- ;; (2) Need the extra \\( \\) so that the years are subexp 3, as
- ;; they are at note (1) above.
- (re-search-forward (format "\\(%s\\)" copyright-years-regexp)))
-
- ;; Note that `current-time-string' isn't locale-sensitive.
- (setq copyright-current-year (substring (current-time-string) -4))
- (unless (string= (buffer-substring (- (match-end 3) 2) (match-end 3))
- (substring copyright-current-year -2))
- (if (or noquery
+ ;; This uses the match-data from copyright-find-copyright/end.
+ (goto-char (match-end 1))
+ (copyright-find-end)
+ ;; Note that `current-time-string' isn't locale-sensitive.
+ (setq copyright-current-year (substring (current-time-string) -4))
+ (unless (string= (buffer-substring (- (match-end 3) 2) (match-end 3))
+ (substring copyright-current-year -2))
+ (if (or noquery
+ (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"))))
- (if (and (eq (% (- (string-to-number copyright-current-year)
- (string-to-number (buffer-substring
- (+ (point) size)
- (point))))
- 100)
- 1)
- (or (eq (char-after (+ (point) size -1)) ?-)
- (eq (char-after (+ (point) size -2)) ?-)))
- ;; This is a range so just replace the end part.
- (delete-char size)
- ;; Insert a comma with the preferred number of spaces.
- (insert
- (save-excursion
- (if (re-search-backward "[0-9]\\( *, *\\)[0-9]"
- (line-beginning-position) t)
- (match-string 1)
- ", ")))
- ;; If people use the '91 '92 '93 scheme, do that as well.
- (if (eq (char-after (+ (point) size -3)) ?')
- (insert ?')))
- ;; Finally insert the new year.
- (insert (substring copyright-current-year size))))))))
+ " to copyright? "))))))
+ (if replace
+ (replace-match copyright-current-year t t nil 3)
+ (let ((size (save-excursion (skip-chars-backward "0-9"))))
+ (if (and (eq (% (- (string-to-number copyright-current-year)
+ (string-to-number (buffer-substring
+ (+ (point) size)
+ (point))))
+ 100)
+ 1)
+ (or (eq (char-after (+ (point) size -1)) ?-)
+ (eq (char-after (+ (point) size -2)) ?-)))
+ ;; This is a range so just replace the end part.
+ (delete-char size)
+ ;; Insert a comma with the preferred number of spaces.
+ (insert
+ (save-excursion
+ (if (re-search-backward "[0-9]\\( *, *\\)[0-9]"
+ (line-beginning-position) t)
+ (match-string 1)
+ ", ")))
+ ;; If people use the '91 '92 '93 scheme, do that as well.
+ (if (eq (char-after (+ (point) size -3)) ?')
+ (insert ?')))
+ ;; Finally insert the new year.
+ (insert (substring copyright-current-year size)))))))
;;;###autoload
(defun copyright-update (&optional arg interactivep)
@@ -206,74 +236,110 @@ interactively."
(and (eq copyright-query 'function) interactivep))))
(save-excursion
(save-restriction
- (widen)
- (goto-char (copyright-start-point))
- (copyright-update-year arg noquery)
- (goto-char (copyright-start-point))
- (and copyright-current-gpl-version
- ;; match the GPL version comment in .el files, including the
- ;; bilingual Esperanto one in two-column, and in texinfo.tex
- (copyright-re-search
- "\\(the Free Software Foundation;\
- either \\|; a\\^u eldono \\([0-9]+\\)a, ? a\\^u (la\\^u via \\)\
-version \\([0-9]+\\), or (at"
- (copyright-limit) t)
- ;; Don't update if the file is already using a more recent
- ;; version than the "current" one.
- (< (string-to-number (match-string 3))
- (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))))
- (progn
- (if (match-end 2)
- ;; Esperanto bilingual comment in two-column.el
- (replace-match copyright-current-gpl-version t t nil 2))
- (replace-match copyright-current-gpl-version t t nil 3))))
+ ;; If names-regexp doesn't match, we should not mess with
+ ;; the years _or_ the GPL version.
+ ;; TODO there may be multiple copyrights we should update.
+ (when (copyright-find-copyright)
+ (copyright-update-year arg noquery)
+ (goto-char (copyright-start-point))
+ (and copyright-current-gpl-version
+ ;; Match the GPL version comment in .el files.
+ ;; This is sensitive to line-breaks. :(
+ (copyright-re-search
+ "the Free Software Foundation[,;\n].*either version \
+\\([0-9]+\\)\\(?: of the License\\)?, or[ \n].*any later version"
+ (copyright-limit) t)
+ ;; Don't update if the file is already using a more recent
+ ;; version than the "current" one.
+ (< (string-to-number (match-string 1))
+ (string-to-number copyright-current-gpl-version))
+ (or noquery
+ (save-match-data
+ (goto-char (match-end 1))
+ (save-window-excursion
+ (switch-to-buffer (current-buffer))
+ (y-or-n-p
+ (format "Replace GPL version %s with version %s? "
+ (match-string-no-properties 1)
+ copyright-current-gpl-version)))))
+ (replace-match copyright-current-gpl-version t t nil 1))))
(set (make-local-variable 'copyright-update) nil)))
;; If a write-file-hook returns non-nil, the file is presumed to be written.
nil))
-;; FIXME should be within 50 years of present (cf calendar).
+;; FIXME heuristic should be within 50 years of present (cf calendar).
;;;###autoload
(defun copyright-fix-years ()
"Convert 2 digit years to 4 digit years.
-Uses heuristic: year >= 50 means 19xx, < 50 means 20xx."
+Uses heuristic: year >= 50 means 19xx, < 50 means 20xx.
+If `copyright-year-ranges' (which see) is non-nil, also
+independently replaces consecutive years with a range."
(interactive)
- (widen)
- (goto-char (copyright-start-point))
- (if (copyright-re-search copyright-regexp (copyright-limit) t)
- (let ((s (match-beginning 2))
- (e (copy-marker (1+ (match-end 2))))
+ ;; TODO there may be multiple copyrights we should fix.
+ (if (copyright-find-copyright)
+ (let ((s (match-beginning 3))
(p (make-marker))
- last)
+ ;; Not line-beg-pos, so we don't mess up leading whitespace.
+ (copystart (match-beginning 0))
+ e last sep year prev-year first-year range-start range-end)
+ ;; In case years are continued over multiple, commented lines.
+ (goto-char (match-end 1))
+ (copyright-find-end)
+ (setq e (copy-marker (1+ (match-end 3))))
(goto-char s)
(while (re-search-forward "[0-9]+" e t)
(set-marker p (point))
(goto-char (match-beginning 0))
- (let ((sep (char-before))
- (year (string-to-number (match-string 0))))
- (when (and sep
- (/= (char-syntax sep) ?\s)
- (/= sep ?-))
- (insert " "))
- (when (< year 100)
- (insert (if (>= year 50) "19" "20"))))
+ (setq year (string-to-number (match-string 0)))
+ (and (setq sep (char-before))
+ (/= (char-syntax sep) ?\s)
+ (/= sep ?-)
+ (insert " "))
+ (when (< year 100)
+ (insert (if (>= year 50) "19" "20"))
+ (setq year (+ year (if (>= year 50) 1900 2000))))
(goto-char p)
- (setq last p))
+ (when copyright-year-ranges
+ ;; If the previous thing was a range, don't try to tack more on.
+ ;; Ie not 2000-2005 -> 2000-2005-2007
+ ;; TODO should merge into existing range if possible.
+ (if (eq sep ?-)
+ (setq prev-year nil
+ year nil)
+ (if (and prev-year (= year (1+ prev-year)))
+ (setq range-end (point))
+ (when (and first-year prev-year
+ (> prev-year first-year))
+ (goto-char range-end)
+ (delete-region range-start range-end)
+ (insert (format "-%d" prev-year))
+ (goto-char p))
+ (setq first-year year
+ range-start (point)))))
+ (setq prev-year year
+ last p))
(when last
+ (when (and copyright-year-ranges
+ first-year prev-year
+ (> prev-year first-year))
+ (goto-char range-end)
+ (delete-region range-start range-end)
+ (insert (format "-%d" prev-year)))
(goto-char last)
;; Don't mess up whitespace after the years.
(skip-chars-backward " \t")
- (save-restriction
- (narrow-to-region (copyright-start-point) (point))
- (let ((fill-prefix " "))
- (fill-region s last))))
+ (save-restriction
+ (narrow-to-region copystart (point))
+ ;; This is clearly wrong, eg what about comment markers?
+ ;;; (let ((fill-prefix " "))
+ ;; TODO do not break copyright owner over lines.
+ (fill-region (point-min) (point-max))))
(set-marker e nil)
- (set-marker p nil)
- (copyright-update nil t))
+ (set-marker p nil))
+ ;; Simply reformatting the years is not copyrightable, so it does
+ ;; not seem right to call this. Also it messes with ranges.
+;;; (copyright-update nil t))
(message "No copyright message")))
;;;###autoload
@@ -288,17 +354,24 @@ Uses heuristic: year >= 50 means 19xx, < 50 means 20xx."
(message "Copyright extends beyond `copyright-limit' and won't be updated automatically."))
comment-end \n)
+;; TODO: recurse, exclude COPYING etc.
;;;###autoload
-(defun copyright-update-directory (directory match)
- "Update copyright notice for all files in DIRECTORY matching MATCH."
+(defun copyright-update-directory (directory match &optional fix)
+ "Update copyright notice for all files in DIRECTORY matching MATCH.
+If FIX is non-nil, run `copyright-fix-years' instead."
(interactive "DDirectory: \nMFilenames matching (regexp): ")
(dolist (file (directory-files directory t match nil))
- (message "Updating file `%s'" file)
- (find-file file)
- (let ((copyright-query nil))
- (copyright-update))
- (save-buffer)
- (kill-buffer (current-buffer))))
+ (unless (file-directory-p file)
+ (message "Updating file `%s'" file)
+ (find-file file)
+ (let ((inhibit-read-only t)
+ (enable-local-variables :safe)
+ copyright-query)
+ (if fix
+ (copyright-fix-years)
+ (copyright-update)))
+ (save-buffer)
+ (kill-buffer (current-buffer)))))
(provide 'copyright)
@@ -307,5 +380,4 @@ Uses heuristic: year >= 50 means 19xx, < 50 means 20xx."
;; coding: utf-8
;; End:
-;; arch-tag: b4991afb-b6b1-4590-bebe-e076d9d4aee8
;;; copyright.el ends here
diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el
index 8c7d48d7e0c..3848ab7e6ea 100644
--- a/lisp/emacs-lisp/crm.el
+++ b/lisp/emacs-lisp/crm.el
@@ -1,7 +1,6 @@
;;; crm.el --- read multiple strings with completion
-;; Copyright (C) 1985, 1986, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1986, 1993-2011 Free Software Foundation, Inc.
;; Author: Sen Nagata <sen@eccosys.com>
;; Keywords: completion, minibuffer, multiple elements
@@ -321,5 +320,4 @@ INHERIT-INPUT-METHOD."
(provide 'crm)
-;; arch-tag: db1911d9-86c6-4a42-b32a-4910701b15a6
;;; crm.el ends here
diff --git a/lisp/emacs-lisp/cust-print.el b/lisp/emacs-lisp/cust-print.el
index 5b8ce9909bd..e7f9aae1c60 100644
--- a/lisp/emacs-lisp/cust-print.el
+++ b/lisp/emacs-lisp/cust-print.el
@@ -1,7 +1,6 @@
;;; cust-print.el --- handles print-level and print-circle
-;; Copyright (C) 1992, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 2001-2011 Free Software Foundation, Inc.
;; Author: Daniel LaLiberte <liberte@holonexus.org>
;; Adapted-By: ESR
@@ -681,5 +680,4 @@ See `custom-format' for the details."
(provide 'cust-print)
-;; arch-tag: 3a5a8650-622c-48c4-87d8-e01bf72ec580
;;; cust-print.el ends here
diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el
index a752d4bfaf0..88633eaaa46 100644
--- a/lisp/emacs-lisp/debug.el
+++ b/lisp/emacs-lisp/debug.el
@@ -1,7 +1,6 @@
;;; debug.el --- debuggers and related commands for Emacs
-;; Copyright (C) 1985, 1986, 1994, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1986, 1994, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: lisp, tools, maint
@@ -514,9 +513,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
@@ -890,5 +889,4 @@ To specify a nil argument interactively, exit with an empty minibuffer."
(provide 'debug)
-;; arch-tag: b6ec7047-f801-4103-9c63-d69322db9d3b
;;; debug.el ends here
diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el
index 36298e47a72..1db98ac39c8 100644
--- a/lisp/emacs-lisp/derived.el
+++ b/lisp/emacs-lisp/derived.el
@@ -1,12 +1,12 @@
;;; derived.el --- allow inheritance of major modes
;; (formerly mode-clone.el)
-;; Copyright (C) 1993, 1994, 1999, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1994, 1999, 2001-2011 Free Software Foundation, Inc.
;; Author: David Megginson (dmeggins@aix1.uottawa.ca)
;; Maintainer: FSF
;; Keywords: extensions
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -201,7 +201,7 @@ No problems result if this variable is not bound.
name))))
(unless (boundp ',map)
(put ',map 'definition-name ',child))
- (defvar ,map (make-sparse-keymap))
+ (with-no-warnings (defvar ,map (make-sparse-keymap)))
(unless (get ',map 'variable-documentation)
(put ',map 'variable-documentation
(purecopy ,(format "Keymap for `%s'." child))))
@@ -230,7 +230,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)
@@ -456,5 +456,4 @@ Where the new table already has an entry, nothing is copied from the old one."
(provide 'derived)
-;; arch-tag: 630be248-47d1-4f02-afa0-8207de0ebea0
;;; derived.el ends here
diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el
index ae69f13143e..4fd10185c17 100644
--- a/lisp/emacs-lisp/disass.el
+++ b/lisp/emacs-lisp/disass.el
@@ -1,7 +1,6 @@
;;; disass.el --- disassembler for compiled Emacs Lisp code
-;; Copyright (C) 1986, 1991, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1986, 1991, 2002-2011 Free Software Foundation, Inc.
;; Author: Doug Cutting <doug@csli.stanford.edu>
;; Jamie Zawinski <jwz@lucid.com>
@@ -79,13 +78,14 @@ redefine OBJECT if it is a symbol."
obj (symbol-function obj)))
(if (subrp obj)
(error "Can't disassemble #<subr %s>" name))
- (if (and (listp obj) (eq (car obj) 'autoload))
- (progn
- (load (nth 1 obj))
- (setq obj (symbol-function name))))
+ (when (and (listp obj) (eq (car obj) 'autoload))
+ (load (nth 1 obj))
+ (setq obj (symbol-function name)))
(if (eq (car-safe obj) 'macro) ;handle macros
(setq macro t
obj (cdr obj)))
+ (when (and (listp obj) (eq (car obj) 'closure))
+ (error "Don't know how to compile an interpreted closure"))
(if (and (listp obj) (eq (car obj) 'byte-code))
(setq obj (list 'lambda nil obj)))
(if (and (listp obj) (not (eq (car obj) 'lambda)))
@@ -216,7 +216,9 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler."
(cond ((memq op byte-goto-ops)
(insert (int-to-string (nth 1 arg))))
((memq op '(byte-call byte-unbind
- byte-listN byte-concatN byte-insertN))
+ byte-listN byte-concatN byte-insertN
+ byte-stack-ref byte-stack-set byte-stack-set2
+ byte-discardN byte-discardN-preserve-tos))
(insert (int-to-string arg)))
((memq op '(byte-varref byte-varset byte-varbind))
(prin1 (car arg) (current-buffer)))
@@ -264,5 +266,4 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler."
(provide 'disass)
-;; arch-tag: 89482fe4-a087-4761-8dc6-d771054e763a
;;; disass.el ends here
diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el
index 3876e291d1b..46dc1f162ba 100644
--- a/lisp/emacs-lisp/easy-mmode.el
+++ b/lisp/emacs-lisp/easy-mmode.el
@@ -1,10 +1,10 @@
;;; easy-mmode.el --- easy definition for major and minor modes
-;; Copyright (C) 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2000-2011 Free Software Foundation, Inc.
;; Author: Georges Brun-Cottan <Georges.Brun-Cottan@inria.fr>
;; Maintainer: Stefan Monnier <monnier@gnu.org>
+;; Package: emacs
;; Keywords: extensions lisp
@@ -115,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!\"
@@ -146,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")))
@@ -166,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
@@ -182,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."
@@ -206,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.
@@ -220,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)
@@ -260,9 +277,15 @@ With zero or negative ARG turn mode off.
(t (error "Invalid keymap %S" m))))
,(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
@@ -342,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))
@@ -365,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 ()
@@ -559,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 2ddbad7d92d..79573437146 100644
--- a/lisp/emacs-lisp/easymenu.el
+++ b/lisp/emacs-lisp/easymenu.el
@@ -1,10 +1,10 @@
;;; easymenu.el --- support the easymenu interface for defining a menu
-;; Copyright (C) 1994, 1996, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 1996, 1998-2011 Free Software Foundation, Inc.
;; Keywords: emulations
;; Author: Richard Stallman <rms@gnu.org>
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -29,6 +29,8 @@
;;; Code:
+(eval-when-compile (require 'cl))
+
(defvar easy-menu-precalculate-equivalent-keybindings nil
"Determine when equivalent key bindings are computed for easy-menu menus.
It can take some time to calculate the equivalent key bindings that are shown
@@ -43,8 +45,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.
@@ -67,8 +67,8 @@ expression has a non-nil value. `:included' is an alias for `:visible'.
:active ENABLE
-ENABLE is an expression; the menu is enabled for selection
-whenever this expression's value is non-nil.
+ENABLE is an expression; the menu is enabled for selection whenever
+this expression's value is non-nil. `:enable' is an alias for `:active'.
The rest of the elements in MENU, are menu items.
@@ -105,8 +105,8 @@ keyboard equivalent.
:active ENABLE
-ENABLE is an expression; the item is enabled for selection
-whenever this expression's value is non-nil.
+ENABLE is an expression; the item is enabled for selection whenever
+this expression's value is non-nil. `:enable' is an alias for `:active'.
:visible INCLUDE
@@ -150,6 +150,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)))
@@ -163,10 +164,13 @@ This is expected to be bound to a mouse event."
(prog1 (get menu 'menu-prop)
(setq menu (symbol-function menu))))))
(cons 'menu-item
- (cons (or item-name
- (if (keymapp menu)
- (keymap-prompt menu))
- "")
+ (cons (if (eq :label (car props))
+ (prog1 (cadr props)
+ (setq props (cddr props)))
+ (or item-name
+ (if (keymapp menu)
+ (keymap-prompt menu))
+ ""))
(cons menu props)))))
;;;###autoload
@@ -232,15 +236,14 @@ possibly preceded by keyword pairs as described in `easy-menu-define'."
(keywordp (setq keyword (car menu-items))))
(setq arg (cadr menu-items))
(setq menu-items (cddr menu-items))
- (cond
- ((eq keyword :filter)
+ (case keyword
+ (:filter
(setq filter `(lambda (menu)
(easy-menu-filter-return (,arg menu) ,menu-name))))
- ((eq keyword :active) (setq enable (or arg ''nil)))
- ((eq keyword :label) (setq label arg))
- ((eq keyword :help) (setq help arg))
- ((or (eq keyword :included) (eq keyword :visible))
- (setq visible (or arg ''nil)))))
+ ((:enable :active) (setq enable (or arg ''nil)))
+ (:label (setq label arg))
+ (:help (setq help arg))
+ ((:included :visible) (setq visible (or arg ''nil)))))
(if (equal visible ''nil)
nil ; Invisible menu entry, return nil.
(if (and visible (not (easy-menu-always-true-p visible)))
@@ -249,14 +252,14 @@ possibly preceded by keyword pairs as described in `easy-menu-define'."
(setq prop (cons :enable (cons enable prop))))
(if filter (setq prop (cons :filter (cons filter prop))))
(if help (setq prop (cons :help (cons help prop))))
- (if label (setq prop (cons nil (cons label prop))))
- (if filter
- ;; The filter expects the menu in its XEmacs form and the pre-filter
- ;; form will only be passed to the filter anyway, so we'd better
- ;; not convert it at all (it will be converted on the fly by
- ;; easy-menu-filter-return).
- (setq menu menu-items)
- (setq menu (append menu (mapcar 'easy-menu-convert-item menu-items))))
+ (if label (setq prop (cons :label (cons label prop))))
+ (setq menu (if filter
+ ;; The filter expects the menu in its XEmacs form and the
+ ;; pre-filter form will only be passed to the filter
+ ;; anyway, so we'd better not convert it at all (it will
+ ;; be converted on the fly by easy-menu-filter-return).
+ menu-items
+ (append menu (mapcar 'easy-menu-convert-item menu-items))))
(when prop
(setq menu (easy-menu-make-symbol menu 'noexp))
(put menu 'menu-prop prop))
@@ -312,7 +315,7 @@ ITEM defines an item as in `easy-menu-define'."
;; Invisible menu item. Don't insert into keymap.
(setq remove t)
(when (and (symbolp command) (setq prop (get command 'menu-prop)))
- (when (null (car prop))
+ (when (eq :label (car prop))
(setq label (cadr prop))
(setq prop (cddr prop)))
(setq command (symbol-function command)))))
@@ -331,30 +334,28 @@ ITEM defines an item as in `easy-menu-define'."
(setq keyword (aref item count))
(setq arg (aref item (1+ count)))
(setq count (+ 2 count))
- (cond
- ((or (eq keyword :included) (eq keyword :visible))
- (setq visible (or arg ''nil)))
- ((eq keyword :key-sequence)
- (setq cache arg cache-specified t))
- ((eq keyword :keys) (setq keys arg no-name nil))
- ((eq keyword :label) (setq label arg))
- ((eq keyword :active) (setq active (or arg ''nil)))
- ((eq keyword :help) (setq prop (cons :help (cons arg prop))))
- ((eq keyword :suffix) (setq suffix arg))
- ((eq keyword :style) (setq style arg))
- ((eq keyword :selected) (setq selected (or arg ''nil)))))
+ (case keyword
+ ((:included :visible) (setq visible (or arg ''nil)))
+ (:key-sequence (setq cache arg cache-specified t))
+ (:keys (setq keys arg no-name nil))
+ (:label (setq label arg))
+ ((:active :enable) (setq active (or arg ''nil)))
+ (:help (setq prop (cons :help (cons arg prop))))
+ (:suffix (setq suffix arg))
+ (:style (setq style arg))
+ (:selected (setq selected (or arg ''nil)))))
(if suffix
(setq label
(if (stringp suffix)
(if (stringp label) (concat label " " suffix)
- (list 'concat label (concat " " suffix)))
+ `(concat ,label ,(concat " " suffix)))
(if (stringp label)
- (list 'concat (concat label " ") suffix)
- (list 'concat label " " suffix)))))
+ `(concat ,(concat label " ") ,suffix)
+ `(concat ,label " " ,suffix)))))
(cond
((eq style 'button)
(setq label (if (stringp label) (concat "[" label "]")
- (list 'concat "[" label "]"))))
+ `(concat "[" ,label "]"))))
((and selected
(setq style (assq style easy-menu-button-prefix)))
(setq prop (cons :button
@@ -674,5 +675,4 @@ In some cases we use that to select between the local and global maps."
(provide 'easymenu)
-;; arch-tag: 2a04020d-90d2-476d-a7c6-71e072007a4a
;;; easymenu.el ends here
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index cfd80b80927..f84de0308bf 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -1,8 +1,6 @@
;;; 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, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1988-1995, 1997, 1999-2011 Free Software Foundation, Inc.
;; Author: Daniel LaLiberte <liberte@holonexus.org>
;; Maintainer: FSF
@@ -521,7 +519,8 @@ the minibuffer."
((and (eq (car form) 'defcustom)
(default-boundp (nth 1 form)))
;; Force variable to be bound.
- (set-default (nth 1 form) (eval (nth 2 form))))
+ ;; FIXME: Shouldn't this use the :setter or :initializer?
+ (set-default (nth 1 form) (eval (nth 2 form) lexical-binding)))
((eq (car form) 'defface)
;; Reset the face.
(setq face-new-frame-defaults
@@ -534,7 +533,7 @@ the minibuffer."
(put ',(nth 1 form) 'customized-face
,(nth 2 form)))
(put (nth 1 form) 'saved-face nil)))))
- (setq edebug-result (eval form))
+ (setq edebug-result (eval (eval-sexp-add-defvars form) lexical-binding))
(if (not edebugging)
(princ edebug-result)
edebug-result)))
@@ -567,7 +566,8 @@ already is one.)"
;; but this causes problems while edebugging edebug.
(let ((edebug-all-forms t)
(edebug-all-defs t))
- (edebug-read-top-level-form))))
+ (eval-sexp-add-defvars
+ (edebug-read-top-level-form)))))
(defun edebug-read-top-level-form ()
@@ -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)
@@ -2149,8 +2131,6 @@ expressions; a `progn' form will be returned enclosing these forms."
(def-edebug-spec with-custom-print body)
-(def-edebug-spec sregexq (&rest sexp))
-(def-edebug-spec rx (&rest sexp))
;;; The debugger itself
@@ -2484,6 +2464,7 @@ MSG is printed after `::::} '."
(if edebug-global-break-condition
(condition-case nil
(setq edebug-global-break-result
+ ;; FIXME: lexbind.
(eval edebug-global-break-condition))
(error nil))))
(edebug-break))
@@ -2495,6 +2476,7 @@ MSG is printed after `::::} '."
(and edebug-break-data
(or (not edebug-break-condition)
(setq edebug-break-result
+ ;; FIXME: lexbind.
(eval edebug-break-condition))))))
(if (and edebug-break
(nth 2 edebug-break-data)) ; is it temporary?
@@ -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))
@@ -3416,7 +3398,7 @@ go to the end of the last sexp, or if that is the same point, then step."
;; Return the function symbol, or nil if not instrumented.
(let ((func-marker (get func 'edebug)))
(cond
- ((markerp func-marker)
+ ((and (markerp func-marker) (marker-buffer func-marker))
;; It is uninstrumented, so instrument it.
(with-current-buffer (marker-buffer func-marker)
(goto-char func-marker)
@@ -3655,9 +3637,10 @@ Return the result of the last expression."
(defun edebug-eval (edebug-expr)
;; Are there cl lexical variables active?
- (if (bound-and-true-p cl-debug-env)
- (eval (cl-macroexpand-all edebug-expr cl-debug-env))
- (eval edebug-expr)))
+ (eval (if (bound-and-true-p cl-debug-env)
+ (cl-macroexpand-all edebug-expr cl-debug-env)
+ edebug-expr)
+ lexical-binding))
(defun edebug-safe-eval (edebug-expr)
;; Evaluate EXPR safely.
@@ -4029,18 +4012,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)
@@ -4261,8 +4242,8 @@ It is removed when you hit any char."
;;; Menus
(defun edebug-toggle (variable)
- (set variable (not (eval variable)))
- (message "%s: %s" variable (eval variable)))
+ (set variable (not (symbol-value variable)))
+ (message "%s: %s" variable (symbol-value variable)))
;; We have to require easymenu (even for Emacs 18) just so
;; the easy-menu-define macro call is compiled correctly.
@@ -4455,7 +4436,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 +4447,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 3676910faad..139f5e6a4ce 100644
--- a/lisp/emacs-lisp/eieio-base.el
+++ b/lisp/emacs-lisp/eieio-base.el
@@ -1,11 +1,12 @@
;;; eieio-base.el --- Base classes for EIEIO.
-;;; Copyright (C) 2000, 2001, 2002, 2004, 2005, 2007, 2008, 2009, 2010, 2011
+;;; Copyright (C) 2000-2002, 2004-2005, 2007-2011
;;; Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 0.2
;; Keywords: OO, lisp
+;; Package: eieio
;; This file is part of GNU Emacs.
@@ -328,5 +329,4 @@ a set type."
(provide 'eieio-base)
-;; arch-tag: 6260571e-9e8a-41a0-880f-a937b0c2ea8b
;;; eieio-base.el ends here
diff --git a/lisp/emacs-lisp/eieio-comp.el b/lisp/emacs-lisp/eieio-comp.el
deleted file mode 100644
index 70981a1b347..00000000000
--- a/lisp/emacs-lisp/eieio-comp.el
+++ /dev/null
@@ -1,142 +0,0 @@
-;;; eieio-comp.el -- eieio routines to help with byte compilation
-
-;; Copyright (C) 1995,1996, 1998, 1999, 2000, 2001, 2002, 2005, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Version: 0.2
-;; Keywords: oop, lisp, 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 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:
-
-;; Byte compiler functions for defmethod. This will affect the new GNU
-;; byte compiler for Emacs 19 and better. This function will be called by
-;; the byte compiler whenever a `defmethod' is encountered in a file.
-;; It will output a function call to `eieio-defmethod' with the byte
-;; compiled function as a parameter.
-
-;;; Code:
-
-(declare-function eieio-defgeneric-form "eieio" (method doc-string))
-
-;; Some compatibility stuff
-(eval-and-compile
- (if (not (fboundp 'byte-compile-compiled-obj-to-list))
- (defun byte-compile-compiled-obj-to-list (moose) nil))
-
- (if (not (boundp 'byte-compile-outbuffer))
- (defvar byte-compile-outbuffer nil))
- )
-
-;; 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',
-but it's been modified to handle the special syntax of the `defmethod'
-command. There should probably be one for `defgeneric' as well, but
-that is called but rarely. Argument FORM is the body of the method."
- (setq form (cdr form))
- (let* ((meth (car form))
- (key (progn (setq form (cdr form))
- (cond ((or (eq ':BEFORE (car form))
- (eq ':before (car form)))
- (setq form (cdr form))
- ":before ")
- ((or (eq ':AFTER (car form))
- (eq ':after (car form)))
- (setq form (cdr form))
- ":after ")
- ((or (eq ':PRIMARY (car form))
- (eq ':primary (car form)))
- (setq form (cdr form))
- ":primary ")
- ((or (eq ':STATIC (car form))
- (eq ':static (car form)))
- (setq form (cdr form))
- ":static ")
- (t ""))))
- (params (car form))
- (lamparams (byte-compile-defmethod-param-convert params))
- (arg1 (car params))
- (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))))
- )
- (let ((name (format "%s::%s" (or class "#<generic>") meth)))
- (if byte-compile-verbose
- ;; #### filename used free
- (message "Compiling %s... (%s)" (or filename "") name))
- (setq byte-compile-current-form name) ; for warnings
- )
- ;; Flush any pending output
- (byte-compile-flush-pending)
- ;; Byte compile the body. For the byte compiled forms, add the
- ;; rest arguments, which will get ignored by the engine which will
- ;; add them later (I hope)
- (let* ((new-one (byte-compile-lambda
- (append (list 'lambda lamparams)
- (cdr form))))
- (code (byte-compile-byte-code-maker new-one)))
- (princ "\n(eieio-defmethod '" my-outbuffer)
- (princ meth my-outbuffer)
- (princ " '(" my-outbuffer)
- (princ key my-outbuffer)
- (prin1 params my-outbuffer)
- (princ " " my-outbuffer)
- (prin1 code my-outbuffer)
- (princ "))" my-outbuffer)
- )
- ;; Now add this function to the list of known functions.
- ;; Don't bother with a doc string. Not relevant here.
- (add-to-list 'byte-compile-function-environment
- (cons meth
- (eieio-defgeneric-form meth "")))
-
- ;; Remove it from the undefined list if it is there.
- (let ((elt (assq meth byte-compile-unresolved-functions)))
- (if elt (setq byte-compile-unresolved-functions
- (delq elt byte-compile-unresolved-functions))))
-
- ;; nil prevents cruft from appearing in the output buffer.
- nil))
-
-(defun byte-compile-defmethod-param-convert (paramlist)
- "Convert method params into the params used by the `defmethod' thingy.
-Argument PARAMLIST is the parameter list to convert."
- (let ((argfix nil))
- (while paramlist
- (setq argfix (cons (if (listp (car paramlist))
- (car (car paramlist))
- (car paramlist))
- argfix))
- (setq paramlist (cdr paramlist)))
- (nreverse argfix)))
-
-(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 e547fa77fe3..e8d7bea50fa 100644
--- a/lisp/emacs-lisp/eieio-custom.el
+++ b/lisp/emacs-lisp/eieio-custom.el
@@ -1,11 +1,11 @@
;;; eieio-custom.el -- eieio object customization
-;; Copyright (C) 1999, 2000, 2001, 2005, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1999-2001, 2005, 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 0.2
;; Keywords: OO, lisp
+;; Package: eieio
;; This file is part of GNU Emacs.
@@ -326,6 +326,7 @@ User made commands should also call this method when applying changes.
Argument OBJ is the object that has been customized."
nil)
+;;;###autoload
(defun customize-object (obj &optional group)
"Customize OBJ in a custom buffer.
Optional argument GROUP is the sub-group of slots to display."
@@ -460,5 +461,8 @@ Return the symbol for the group, or nil"
(provide 'eieio-custom)
-;; arch-tag: bc122762-a771-48d5-891b-7835b16dd924
+;; Local variables:
+;; generated-autoload-file: "eieio.el"
+;; End:
+
;;; eieio-custom.el ends here
diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el
index 06c47f47e41..60510e1816c 100644
--- a/lisp/emacs-lisp/eieio-datadebug.el
+++ b/lisp/emacs-lisp/eieio-datadebug.el
@@ -1,9 +1,10 @@
;;; eieio-datadebug.el --- EIEIO extensions to the data debugger.
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: OO, lisp
+;; Package: eieio
;; This file is part of GNU Emacs.
@@ -144,5 +145,4 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
(provide 'eieio-datadebug)
-;; arch-tag: 6c7c2890-7614-41b0-816b-c61f3f6a8130
;;; eieio-datadebug.el ends here
diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el
index 245a2dbfff5..1b101cef875 100644
--- a/lisp/emacs-lisp/eieio-opt.el
+++ b/lisp/emacs-lisp/eieio-opt.el
@@ -1,11 +1,12 @@
;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar)
-;; Copyright (C) 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2005, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1998-2003, 2005, 2008-2011
+;; Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 0.2
;; Keywords: OO, lisp
+;; Package: eieio
;; This file is part of GNU Emacs.
@@ -31,6 +32,7 @@
(require 'eieio)
;;; Code:
+;;;###autoload
(defun eieio-browse (&optional root-class)
"Create an object browser window to show all objects.
If optional ROOT-CLASS, then start with that, otherwise start with
@@ -70,8 +72,10 @@ Argument CH-PREFIX is another character prefix to display."
;;; CLASS COMPLETION / DOCUMENTATION
+;;;###autoload
(defalias 'describe-class 'eieio-describe-class)
+;;;###autoload
(defun eieio-describe-class (class &optional headerfcn)
"Describe a CLASS defined by a string or symbol.
If CLASS is actually an object, then also display current values of that object.
@@ -237,6 +241,7 @@ Outputs to the standard output."
prot (cdr prot)
i (1+ i)))))
+;;;###autoload
(defun eieio-describe-constructor (fcn)
"Describe the constructor function FCN.
Uses `eieio-describe-class' to describe the class being constructed."
@@ -300,9 +305,11 @@ are not abstract."
;;; METHOD COMPLETION / DOC
(defalias 'describe-method 'eieio-describe-generic)
+;;;###autoload
(defalias 'describe-generic 'eieio-describe-generic)
(defalias 'eieio-describe-method 'eieio-describe-generic)
+;;;###autoload
(defun eieio-describe-generic (generic)
"Describe the generic function GENERIC.
Also extracts information about all methods specific to this generic."
@@ -549,6 +556,7 @@ Optional argument HISTORYVAR is the variable to use as history."
;;; HELP AUGMENTATION
;;
+;;;###autoload
(defun eieio-help-mode-augmentation-maybee (&rest unused)
"For buffers thrown into help mode, augment for EIEIO.
Arguments UNUSED are not used."
@@ -692,5 +700,8 @@ INDENT is the current indentation level."
(provide 'eieio-opt)
-;; arch-tag: 71eab5f5-462f-4fa1-8ed1-f5ca1bf9adb6
+;; Local variables:
+;; generated-autoload-file: "eieio.el"
+;; End:
+
;;; eieio-opt.el ends here
diff --git a/lisp/emacs-lisp/eieio-speedbar.el b/lisp/emacs-lisp/eieio-speedbar.el
index 73f15fd5d88..d28ecd9615b 100644
--- a/lisp/emacs-lisp/eieio-speedbar.el
+++ b/lisp/emacs-lisp/eieio-speedbar.el
@@ -1,11 +1,11 @@
;;; eieio-speedbar.el -- Classes for managing speedbar displays.
-;; Copyright (C) 1999, 2000, 2001, 2002, 2005, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1999-2002, 2005, 2007-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 0.2
;; Keywords: OO, tools
+;; Package: eieio
;; This file is part of GNU Emacs.
@@ -421,5 +421,4 @@ to create a speedbar button."
(provide 'eieio-speedbar)
-;; arch-tag: eaac1283-10b0-4419-a929-982b87e83234
;;; eieio-speedbar.el ends here
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index 4adec99f61b..6abf9aa3657 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -1,8 +1,7 @@
;;; eieio.el --- Enhanced Implementation of Emacs Interpreted Objects
;;; or maybe Eric's Implementation of Emacs Intrepreted Objects
-;; Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-1996, 1998-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 1.3
@@ -46,8 +45,7 @@
;;; Code:
(eval-when-compile
- (require 'cl)
- (require 'eieio-comp))
+ (require 'cl))
(defvar eieio-version "1.3"
"Current version of EIEIO.")
@@ -98,6 +96,7 @@ default setting for optimization purposes.")
"Non-nil means to optimize the method dispatch on primary methods.")
;; State Variables
+;; FIXME: These two constants below should have an `eieio-' prefix added!!
(defvar this nil
"Inside a method, this variable is the object in question.
DO NOT SET THIS YOURSELF unless you are trying to simulate friendly slots.
@@ -124,6 +123,7 @@ execute a `call-next-method'. DO NOT SET THIS YOURSELF!")
;; while it is being built itself.
(defvar eieio-default-superclass nil)
+;; FIXME: The constants below should have an `eieio-' prefix added!!
(defconst class-symbol 1 "Class's symbol (self-referencing.).")
(defconst class-parent 2 "Class parent slot.")
(defconst class-children 3 "Class children class slot.")
@@ -182,10 +182,6 @@ Stored outright without modifications or stripping.")
(t key) ;; already generic.. maybe.
))
-;; How to specialty compile stuff.
-(autoload 'byte-compile-file-form-defmethod "eieio-comp"
- "This function is used to byte compile methods in a nice way.")
-(put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod)
;;; Important macros used in eieio.
;;
@@ -424,6 +420,7 @@ It creates an autoload function for CNAME's constructor."
(load-library (car (cdr (symbol-function cname))))))
(defun eieio-defclass (cname superclasses slots options-and-doc)
+ ;; FIXME: Most of this should be moved to the `defclass' macro.
"Define CNAME as a new subclass of SUPERCLASSES.
SLOTS are the slots residing in that class definition, and options or
documentation OPTIONS-AND-DOC is the toplevel documentation for this class.
@@ -660,14 +657,14 @@ See `defclass' for more information."
;; so that users can `setf' the space returned by this function
(if acces
(progn
- (eieio-defmethod acces
- (list (if (eq alloc :class) :static :primary)
- (list (list 'this cname))
- (format
+ (eieio--defmethod
+ acces (if (eq alloc :class) :static :primary) cname
+ `(lambda (this)
+ ,(format
"Retrieves the slot `%s' from an object of class `%s'"
name cname)
- (list 'if (list 'slot-boundp 'this (list 'quote name))
- (list 'eieio-oref 'this (list 'quote name))
+ (if (slot-boundp this ',name)
+ (eieio-oref this ',name)
;; Else - Some error? nil?
nil)))
@@ -687,22 +684,21 @@ See `defclass' for more information."
;; If a writer is defined, then create a generic method of that
;; name whose purpose is to set the value of the slot.
(if writer
- (progn
- (eieio-defmethod writer
- (list (list (list 'this cname) 'value)
- (format "Set the slot `%s' of an object of class `%s'"
+ (eieio--defmethod
+ writer nil cname
+ `(lambda (this value)
+ ,(format "Set the slot `%s' of an object of class `%s'"
name cname)
- `(setf (slot-value this ',name) value)))
- ))
+ (setf (slot-value this ',name) value))))
;; If a reader is defined, then create a generic method
;; of that name whose purpose is to access this slot value.
(if reader
- (progn
- (eieio-defmethod reader
- (list (list (list 'this cname))
- (format "Access the slot `%s' from object of class `%s'"
+ (eieio--defmethod
+ reader nil cname
+ `(lambda (this)
+ ,(format "Access the slot `%s' from object of class `%s'"
name cname)
- `(slot-value this ',name)))))
+ (slot-value this ',name))))
)
(setq slots (cdr slots)))
@@ -1144,6 +1140,17 @@ a string."
;;; CLOS methods and generics
;;
+
+(put 'eieio--defalias 'byte-hunk-handler
+ #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler)
+(defun eieio--defalias (name body)
+ "Like `defalias', but with less side-effects.
+More specifically, it has no side-effects at all when the new function
+definition is the same (`eq') as the old one."
+ (unless (and (fboundp name)
+ (eq (symbol-function name) body))
+ (defalias name body)))
+
(defmacro defgeneric (method args &optional doc-string)
"Create a generic function METHOD.
DOC-STRING is the base documentation for this class. A generic
@@ -1152,7 +1159,21 @@ is appropriate to use. Uses `defmethod' to create methods, and calls
`defgeneric' for you. With this implementation the ARGS are
currently ignored. You can use `defgeneric' to apply specialized
top level documentation to a method."
- `(eieio-defgeneric (quote ,method) ,doc-string))
+ `(eieio--defalias ',method
+ (eieio--defgeneric-init-form ',method ,doc-string)))
+
+(defun eieio--defgeneric-init-form (method doc-string)
+ "Form to use for the initial definition of a generic."
+ (cond
+ ((or (not (fboundp method))
+ (eq 'autoload (car-safe (symbol-function method))))
+ ;; Make sure the method tables are installed.
+ (eieiomt-install method)
+ ;; Construct the actual body of this function.
+ (eieio-defgeneric-form method doc-string))
+ ((generic-p method) (symbol-function method)) ;Leave it as-is.
+ (t (error "You cannot create a generic/method over an existing symbol: %s"
+ method))))
(defun eieio-defgeneric-form (method doc-string)
"The lambda form that would be used as the function defined on METHOD.
@@ -1193,10 +1214,8 @@ IMPL is the symbol holding the method implementation."
;; is faster to execute this for not byte-compiled. ie, install this,
;; then measure calls going through here. I wonder why.
(require 'bytecomp)
- (let ((byte-compile-free-references nil)
- (byte-compile-warnings nil)
- )
- (byte-compile-lambda
+ (let ((byte-compile-warnings nil))
+ (byte-compile
`(lambda (&rest local-args)
,doc-string
;; This is a cool cheat. Usually we need to look up in the
@@ -1206,7 +1225,8 @@ IMPL is the symbol holding the method implementation."
;; of that one implementation, then clearly, there is no method def.
(if (not (eieio-object-p (car local-args)))
;; Not an object. Just signal.
- (signal 'no-method-definition (list ,(list 'quote method) local-args))
+ (signal 'no-method-definition
+ (list ,(list 'quote method) local-args))
;; We do have an object. Make sure it is the right type.
(if ,(if (eq class eieio-default-superclass)
@@ -1229,9 +1249,7 @@ IMPL is the symbol holding the method implementation."
)
(apply ,(list 'quote impl) local-args)
;(,impl local-args)
- ))))
- )
- ))
+ )))))))
(defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method)
"Setup METHOD to call the generic form."
@@ -1245,26 +1263,6 @@ IMPL is the symbol holding the method implementation."
(cdr entry)
))))
-(defun eieio-defgeneric (method doc-string)
- "Engine part to `defgeneric' macro defining METHOD with DOC-STRING."
- (if (and (fboundp method) (not (generic-p method))
- (or (byte-code-function-p (symbol-function method))
- (not (eq 'autoload (car (symbol-function method)))))
- )
- (error "You cannot create a generic/method over an existing symbol: %s"
- method))
- ;; Don't do this over and over.
- (unless (fboundp 'method)
- ;; This defun tells emacs where the first definition of this
- ;; method is defined.
- `(defun ,method nil)
- ;; Make sure the method tables are installed.
- (eieiomt-install method)
- ;; Apply the actual body of this function.
- (fset method (eieio-defgeneric-form method doc-string))
- ;; Return the method
- 'method))
-
(defun eieio-unbind-method-implementations (method)
"Make the generic method METHOD have no implementations.
It will leave the original generic function in place,
@@ -1297,66 +1295,59 @@ Summary:
((typearg class-name) arg2 &optional opt &rest rest)
\"doc-string\"
body)"
- `(eieio-defmethod (quote ,method) (quote ,args)))
-
-(defun eieio-defmethod (method args)
+ (let* ((key (if (keywordp (car args)) (pop args)))
+ (params (car args))
+ (arg1 (car params))
+ (fargs (if (consp arg1)
+ (cons (car arg1) (cdr params))
+ params))
+ (class (if (consp arg1) (nth 1 arg1)))
+ (code `(lambda ,fargs ,@(cdr args))))
+ `(progn
+ ;; Make sure there is a generic and the byte-compiler sees it.
+ (defgeneric ,method ,args
+ ,(or (documentation code)
+ (format "Generically created method `%s'." method)))
+ (eieio--defmethod ',method ',key ',class ',code))))
+
+(defun eieio--defmethod (method kind argclass code)
"Work part of the `defmethod' macro defining METHOD with ARGS."
- (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa)
+ (let ((key
;; find optional keys
- (setq key
- (cond ((or (eq ':BEFORE (car args))
- (eq ':before (car args)))
- (setq args (cdr args))
+ (cond ((or (eq ':BEFORE kind)
+ (eq ':before kind))
method-before)
- ((or (eq ':AFTER (car args))
- (eq ':after (car args)))
- (setq args (cdr args))
+ ((or (eq ':AFTER kind)
+ (eq ':after kind))
method-after)
- ((or (eq ':PRIMARY (car args))
- (eq ':primary (car args)))
- (setq args (cdr args))
+ ((or (eq ':PRIMARY kind)
+ (eq ':primary kind))
method-primary)
- ((or (eq ':STATIC (car args))
- (eq ':static (car args)))
- (setq args (cdr args))
+ ((or (eq ':STATIC kind)
+ (eq ':static kind))
method-static)
;; Primary key
- (t method-primary)))
- ;; get body, and fix contents of args to be the arguments of the fn.
- (setq body (cdr args)
- args (car args))
- (setq loopa args)
- ;; Create a fixed version of the arguments
- (while loopa
- (setq argfix (cons (if (listp (car loopa)) (car (car loopa)) (car loopa))
- argfix))
- (setq loopa (cdr loopa)))
- ;; make sure there is a generic
- (eieio-defgeneric
- method
- (if (stringp (car body))
- (car body) (format "Generically created method `%s'." method)))
+ (t method-primary))))
+ ;; Make sure there is a generic (when called from defclass).
+ (eieio--defalias
+ method (eieio--defgeneric-init-form
+ method (or (documentation code)
+ (format "Generically created method `%s'." method))))
;; create symbol for property to bind to. If the first arg is of
;; the form (varname vartype) and `vartype' is a class, then
;; that class will be the type symbol. If not, then it will fall
;; under the type `primary' which is a non-specific calling of the
;; function.
- (setq firstarg (car args))
- (if (listp firstarg)
- (progn
- (setq argclass (nth 1 firstarg))
+ (if argclass
(if (not (class-p argclass))
(error "Unknown class type %s in method parameters"
- (nth 1 firstarg))))
+ argclass))
(if (= key -1)
(signal 'wrong-type-argument (list :static 'non-class-arg)))
;; generics are higher
(setq key (eieio-specialized-key-to-generic-key key)))
;; Put this lambda into the symbol so we can find it
- (if (byte-code-function-p (car-safe body))
- (eieiomt-add method (car-safe body) key argclass)
- (eieiomt-add method (append (list 'lambda (reverse argfix)) body)
- key argclass))
+ (eieiomt-add method code key argclass)
)
(when eieio-optimize-primary-methods-flag
@@ -1629,6 +1620,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 +1629,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.
@@ -1869,11 +1859,11 @@ OBJECT can be an instance or a class."
;; Skip typechecking while retrieving this value.
(let ((eieio-skip-typecheck t))
;; Return nil if the magic symbol is in there.
- (if (eieio-object-p object)
- (if (eq (eieio-oref object slot) eieio-unbound) nil t)
- (if (class-p object)
- (if (eq (eieio-oref-default object slot) eieio-unbound) nil t)
- (signal 'wrong-type-argument (list 'eieio-object-p object))))))
+ (not (eq (cond
+ ((eieio-object-p object) (eieio-oref object slot))
+ ((class-p object) (eieio-oref-default object slot))
+ (t (signal 'wrong-type-argument (list 'eieio-object-p object))))
+ eieio-unbound))))
(defun slot-makeunbound (object slot)
"In OBJECT, make SLOT unbound."
@@ -2945,17 +2935,66 @@ Optional argument NOESCAPE is passed to `prin1-to-string' when appropriate."
;;; Autoloading some external symbols, and hooking into the help system
;;
-(autoload 'eieio-help-mode-augmentation-maybee "eieio-opt" "For buffers thrown into help mode, augment for EIEIO.")
-(autoload 'eieio-browse "eieio-opt" "Create an object browser window." t)
-(autoload 'eieio-describe-class "eieio-opt" "Describe CLASS defined by a string or symbol" t)
-(autoload 'eieio-describe-constructor "eieio-opt" "Describe the constructor function FCN." t)
-(autoload 'describe-class "eieio-opt" "Describe CLASS defined by a string or symbol." t)
-(autoload 'eieio-describe-generic "eieio-opt" "Describe GENERIC defined by a string or symbol." t)
-(autoload 'describe-generic "eieio-opt" "Describe GENERIC defined by a string or symbol." t)
+
+;;; Start of automatically extracted autoloads.
+
+;;;### (autoloads (customize-object) "eieio-custom" "eieio-custom.el"
+;;;;;; "cf1bd64c76a6e6406545e8c5a5530d43")
+;;; Generated autoloads from eieio-custom.el
+
+(autoload 'customize-object "eieio-custom" "\
+Customize OBJ in a custom buffer.
+Optional argument GROUP is the sub-group of slots to display.
+
+\(fn OBJ &optional GROUP)" nil nil)
+
+;;;***
+
+;;;### (autoloads (eieio-help-mode-augmentation-maybee eieio-describe-generic
+;;;;;; eieio-describe-constructor eieio-describe-class eieio-browse)
+;;;;;; "eieio-opt" "eieio-opt.el" "1bed0a56310f402683419139ebc18d7f")
+;;; Generated autoloads from eieio-opt.el
+
+(autoload 'eieio-browse "eieio-opt" "\
+Create an object browser window to show all objects.
+If optional ROOT-CLASS, then start with that, otherwise start with
+variable `eieio-default-superclass'.
+
+\(fn &optional ROOT-CLASS)" t nil)
+
+(defalias 'describe-class 'eieio-describe-class)
+
+(autoload 'eieio-describe-class "eieio-opt" "\
+Describe a CLASS defined by a string or symbol.
+If CLASS is actually an object, then also display current values of that object.
+Optional HEADERFCN should be called to insert a few bits of info first.
-(autoload 'customize-object "eieio-custom" "Create a custom buffer editing OBJ.")
+\(fn CLASS &optional HEADERFCN)" t nil)
+
+(autoload 'eieio-describe-constructor "eieio-opt" "\
+Describe the constructor function FCN.
+Uses `eieio-describe-class' to describe the class being constructed.
+
+\(fn FCN)" t nil)
+
+(defalias 'describe-generic 'eieio-describe-generic)
+
+(autoload 'eieio-describe-generic "eieio-opt" "\
+Describe the generic function GENERIC.
+Also extracts information about all methods specific to this generic.
+
+\(fn GENERIC)" t nil)
+
+(autoload 'eieio-help-mode-augmentation-maybee "eieio-opt" "\
+For buffers thrown into help mode, augment for EIEIO.
+Arguments UNUSED are not used.
+
+\(fn &rest UNUSED)" nil nil)
+
+;;;***
+
+;;; End of automatically extracted autoloads.
(provide 'eieio)
-;; arch-tag: c1aeab9c-2938-41a3-842b-1a38bd26e9f2
;;; eieio ends here
diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el
index b9dc69ec819..cd9b779bee9 100644
--- a/lisp/emacs-lisp/eldoc.el
+++ b/lisp/emacs-lisp/eldoc.el
@@ -1,7 +1,6 @@
;;; eldoc.el --- show function arglist or variable docstring in echo area
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Noah Friedman <friedman@splode.com>
;; Maintainer: friedman@splode.com
@@ -530,15 +529,14 @@ 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)
-;; arch-tag: c9a58f9d-2055-46c1-9b82-7248b71a8375
;;; eldoc.el ends here
diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el
index 1583e101d11..0b8aa034500 100644
--- a/lisp/emacs-lisp/elint.el
+++ b/lisp/emacs-lisp/elint.el
@@ -1,7 +1,6 @@
;;; elint.el --- Lint Emacs Lisp
-;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Peter Liljenberg <petli@lysator.liu.se>
;; Created: May 1997
@@ -123,7 +122,6 @@ are as follows, and suppress messages about the indicated features:
;; FIXME I don't see why they shouldn't just get doc-strings.
'(vc-mode local-write-file-hooks activate-menubar-hook buffer-name-history
coding-system-history extended-command-history
- kbd-macro-termination-hook read-expression-history
yes-or-no-p-history)
"Standard variables, excluding `elint-builtin-variables'.
These are variables that we cannot detect automatically for some reason.")
@@ -394,40 +392,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 +439,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 +470,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 +488,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 +1170,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/elp.el b/lisp/emacs-lisp/elp.el
index 9a665272851..73af3a5708f 100644
--- a/lisp/emacs-lisp/elp.el
+++ b/lisp/emacs-lisp/elp.el
@@ -1,7 +1,7 @@
;;; elp.el --- Emacs Lisp Profiler
-;; Copyright (C) 1994, 1995, 1997, 1998, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1995, 1997-1998, 2001-2011
+;; Free Software Foundation, Inc.
;; Author: Barry A. Warsaw
;; Maintainer: FSF
@@ -630,7 +630,7 @@ displayed."
'display (list 'space :align-to column)
'face 'fixed-pitch)
title)
- (setq column (+ column 1
+ (setq column (+ column 2
(if (= column 0)
elp-field-len
(length title))))))
@@ -660,5 +660,4 @@ displayed."
(provide 'elp)
-;; arch-tag: c4eef311-9b3e-4bb2-8a54-3485d41b4eb1
;;; elp.el ends here
diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el
new file mode 100644
index 00000000000..39d4a4e814a
--- /dev/null
+++ b/lisp/emacs-lisp/ert-x.el
@@ -0,0 +1,290 @@
+;;; ert-x.el --- Staging area for experimental extensions to ERT
+
+;; Copyright (C) 2008, 2010-2011 Free Software Foundation, Inc.
+
+;; Author: Lennart Borgman (lennart O borgman A gmail O com)
+;; Author: Christian Ohler <ohler@gnu.org>
+
+;; This file is part of GNU Emacs.
+
+;; This program is free software: you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see `http://www.gnu.org/licenses/'.
+
+;;; Commentary:
+
+;; This file includes some extra helper functions to use while writing
+;; automated tests with ERT. These have been proposed as extensions
+;; to ERT but are not mature yet and likely to change.
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl))
+(require 'ert)
+
+
+;;; Test buffers.
+
+(defun ert--text-button (string &rest properties)
+ "Return a string containing STRING as a text button with PROPERTIES.
+
+See `make-text-button'."
+ (with-temp-buffer
+ (insert string)
+ (apply #'make-text-button (point-min) (point-max) properties)
+ (buffer-string)))
+
+(defun ert--format-test-buffer-name (base-name)
+ "Compute a test buffer name based on BASE-NAME.
+
+Helper function for `ert--test-buffers'."
+ (format "*Test buffer (%s)%s*"
+ (or (and (ert-running-test)
+ (ert-test-name (ert-running-test)))
+ "<anonymous test>")
+ (if base-name
+ (format ": %s" base-name)
+ "")))
+
+(defvar ert--test-buffers (make-hash-table :weakness t)
+ "Table of all test buffers. Keys are the buffer objects, values are t.
+
+The main use of this table is for `ert-kill-all-test-buffers'.
+Not all buffers in this table are necessarily live, but all live
+test buffers are in this table.")
+
+(define-button-type 'ert--test-buffer-button
+ 'action #'ert--test-buffer-button-action
+ 'help-echo "mouse-2, RET: Pop to test buffer")
+
+(defun ert--test-buffer-button-action (button)
+ "Pop to the test buffer that BUTTON is associated with."
+ (pop-to-buffer (button-get button 'ert--test-buffer)))
+
+(defun ert--call-with-test-buffer (ert--base-name ert--thunk)
+ "Helper function for `ert-with-test-buffer'.
+
+Create a test buffer with a name based on ERT--BASE-NAME and run
+ERT--THUNK with that buffer as current."
+ (let* ((ert--buffer (generate-new-buffer
+ (ert--format-test-buffer-name ert--base-name)))
+ (ert--button (ert--text-button (buffer-name ert--buffer)
+ :type 'ert--test-buffer-button
+ 'ert--test-buffer ert--buffer)))
+ (puthash ert--buffer 't ert--test-buffers)
+ ;; We don't use `unwind-protect' here since we want to kill the
+ ;; buffer only on success.
+ (prog1 (with-current-buffer ert--buffer
+ (ert-info (ert--button :prefix "Buffer: ")
+ (funcall ert--thunk)))
+ (kill-buffer ert--buffer)
+ (remhash ert--buffer ert--test-buffers))))
+
+(defmacro* ert-with-test-buffer ((&key ((:name name-form)))
+ &body body)
+ "Create a test buffer and run BODY in that buffer.
+
+To be used in ERT tests. If BODY finishes successfully, the test
+buffer is killed; if there is an error, the test buffer is kept
+around on error for further inspection. Its name is derived from
+the name of the test and the result of NAME-FORM."
+ (declare (debug ((form) body))
+ (indent 1))
+ `(ert--call-with-test-buffer ,name-form (lambda () ,@body)))
+
+;; We use these `put' forms in addition to the (declare (indent)) in
+;; the defmacro form since the `declare' alone does not lead to
+;; correct indentation before the .el/.elc file is loaded.
+;; Autoloading these `put' forms solves this.
+;;;###autoload
+(progn
+ ;; TODO(ohler): Figure out what these mean and make sure they are correct.
+ (put 'ert-with-test-buffer 'lisp-indent-function 1))
+
+;;;###autoload
+(defun ert-kill-all-test-buffers ()
+ "Kill all test buffers that are still live."
+ (interactive)
+ (let ((count 0))
+ (maphash (lambda (buffer dummy)
+ (when (or (not (buffer-live-p buffer))
+ (kill-buffer buffer))
+ (incf count)))
+ ert--test-buffers)
+ (message "%s out of %s test buffers killed"
+ count (hash-table-count ert--test-buffers)))
+ ;; It could be that some test buffers were actually kept alive
+ ;; (e.g., due to `kill-buffer-query-functions'). I'm not sure what
+ ;; to do about this. For now, let's just forget them.
+ (clrhash ert--test-buffers)
+ nil)
+
+
+;;; Simulate commands.
+
+(defun ert-simulate-command (command)
+ ;; FIXME: add unread-events
+ "Simulate calling COMMAND the way the Emacs command loop would call it.
+
+This effectively executes
+
+ \(apply (car COMMAND) (cdr COMMAND)\)
+
+and returns the same value, but additionally runs hooks like
+`pre-command-hook' and `post-command-hook', and sets variables
+like `this-command' and `last-command'.
+
+COMMAND should be a list where the car is the command symbol and
+the rest are arguments to the command.
+
+NOTE: Since the command is not called by `call-interactively'
+test for `called-interactively' in the command will fail."
+ (assert (listp command) t)
+ (assert (commandp (car command)) t)
+ (assert (not unread-command-events) t)
+ (let (return-value)
+ ;; For the order of things here see command_loop_1 in keyboard.c.
+ ;;
+ ;; The command loop will reset the command-related variables so
+ ;; there is no reason to let-bind them. They are set here,
+ ;; however, to be able to test several commands in a row and how
+ ;; they affect each other.
+ (setq deactivate-mark nil
+ this-original-command (car command)
+ ;; remap through active keymaps
+ this-command (or (command-remapping this-original-command)
+ this-original-command))
+ (run-hooks 'pre-command-hook)
+ (setq return-value (apply (car command) (cdr command)))
+ (run-hooks 'post-command-hook)
+ (when deferred-action-list
+ (run-hooks 'deferred-action-function))
+ (setq real-last-command (car command)
+ last-command this-command)
+ (when (boundp 'last-repeatable-command)
+ (setq last-repeatable-command real-last-command))
+ (when (and deactivate-mark transient-mark-mode) (deactivate-mark))
+ (assert (not unread-command-events) t)
+ return-value))
+
+(defun ert-run-idle-timers ()
+ "Run all idle timers (from `timer-idle-list')."
+ (dolist (timer (copy-sequence timer-idle-list))
+ (timer-event-handler timer)))
+
+
+;;; Miscellaneous utilities.
+
+(defun ert-filter-string (s &rest regexps)
+ "Return a copy of S with all matches of REGEXPS removed.
+
+Elements of REGEXPS may also be two-element lists \(REGEXP
+SUBEXP\), where SUBEXP is the number of a subexpression in
+REGEXP. In that case, only that subexpression will be removed
+rather than the entire match."
+ ;; Use a temporary buffer since replace-match copies strings, which
+ ;; would lead to N^2 runtime.
+ (with-temp-buffer
+ (insert s)
+ (dolist (x regexps)
+ (destructuring-bind (regexp subexp) (if (listp x) x `(,x nil))
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ (replace-match "" t t nil subexp))))
+ (buffer-string)))
+
+
+(defun ert-propertized-string (&rest args)
+ "Return a string with properties as specified by ARGS.
+
+ARGS is a list of strings and plists. The strings in ARGS are
+concatenated to produce an output string. In the output string,
+each string from ARGS will be have the preceding plist as its
+property list, or no properties if there is no plist before it.
+
+As a simple example,
+
+\(ert-propertized-string \"foo \" '(face italic) \"bar\" \" baz\" nil \
+\" quux\"\)
+
+would return the string \"foo bar baz quux\" where the substring
+\"bar baz\" has a `face' property with the value `italic'.
+
+None of the ARGS are modified, but the return value may share
+structure with the plists in ARGS."
+ (with-temp-buffer
+ (loop with current-plist = nil
+ for x in args do
+ (etypecase x
+ (string (let ((begin (point)))
+ (insert x)
+ (set-text-properties begin (point) current-plist)))
+ (list (unless (zerop (mod (length x) 2))
+ (error "Odd number of args in plist: %S" x))
+ (setq current-plist x))))
+ (buffer-string)))
+
+
+(defun ert-call-with-buffer-renamed (buffer-name thunk)
+ "Protect the buffer named BUFFER-NAME from side-effects and run THUNK.
+
+Renames the buffer BUFFER-NAME to a new temporary name, creates a
+new buffer named BUFFER-NAME, executes THUNK, kills the new
+buffer, and renames the original buffer back to BUFFER-NAME.
+
+This is useful if THUNK has undesirable side-effects on an Emacs
+buffer with a fixed name such as *Messages*."
+ (lexical-let ((new-buffer-name (generate-new-buffer-name
+ (format "%s orig buffer" buffer-name))))
+ (with-current-buffer (get-buffer-create buffer-name)
+ (rename-buffer new-buffer-name))
+ (unwind-protect
+ (progn
+ (get-buffer-create buffer-name)
+ (funcall thunk))
+ (when (get-buffer buffer-name)
+ (kill-buffer buffer-name))
+ (with-current-buffer new-buffer-name
+ (rename-buffer buffer-name)))))
+
+(defmacro* ert-with-buffer-renamed ((buffer-name-form) &body body)
+ "Protect the buffer named BUFFER-NAME from side-effects and run BODY.
+
+See `ert-call-with-buffer-renamed' for details."
+ (declare (indent 1))
+ `(ert-call-with-buffer-renamed ,buffer-name-form (lambda () ,@body)))
+
+
+(defun ert-buffer-string-reindented (&optional buffer)
+ "Return the contents of BUFFER after reindentation.
+
+BUFFER defaults to current buffer. Does not modify BUFFER."
+ (with-current-buffer (or buffer (current-buffer))
+ (let ((clone nil))
+ (unwind-protect
+ (progn
+ ;; `clone-buffer' doesn't work if `buffer-file-name' is non-nil.
+ (let ((buffer-file-name nil))
+ (setq clone (clone-buffer)))
+ (with-current-buffer clone
+ (let ((inhibit-read-only t))
+ (indent-region (point-min) (point-max)))
+ (buffer-string)))
+ (when clone
+ (let ((kill-buffer-query-functions nil))
+ (kill-buffer clone)))))))
+
+
+(provide 'ert-x)
+
+;;; ert-x.el ends here
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
new file mode 100644
index 00000000000..b2e20843856
--- /dev/null
+++ b/lisp/emacs-lisp/ert.el
@@ -0,0 +1,2548 @@
+;;; ert.el --- Emacs Lisp Regression Testing
+
+;; Copyright (C) 2007-2008, 2010-2011 Free Software Foundation, Inc.
+
+;; Author: Christian Ohler <ohler@gnu.org>
+;; Keywords: lisp, tools
+
+;; This file is part of GNU Emacs.
+
+;; This program is free software: you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see `http://www.gnu.org/licenses/'.
+
+;;; Commentary:
+
+;; ERT is a tool for automated testing in Emacs Lisp. Its main
+;; features are facilities for defining and running test cases and
+;; reporting the results as well as for debugging test failures
+;; interactively.
+;;
+;; The main entry points are `ert-deftest', which is similar to
+;; `defun' but defines a test, and `ert-run-tests-interactively',
+;; which runs tests and offers an interactive interface for inspecting
+;; results and debugging. There is also
+;; `ert-run-tests-batch-and-exit' for non-interactive use.
+;;
+;; The body of `ert-deftest' forms resembles a function body, but the
+;; additional operators `should', `should-not' and `should-error' are
+;; available. `should' is similar to cl's `assert', but signals a
+;; different error when its condition is violated that is caught and
+;; processed by ERT. In addition, it analyzes its argument form and
+;; records information that helps debugging (`assert' tries to do
+;; something similar when its second argument SHOW-ARGS is true, but
+;; `should' is more sophisticated). For information on `should-not'
+;; and `should-error', see their docstrings.
+;;
+;; See ERT's info manual as well as the docstrings for more details.
+;; To compile the manual, run `makeinfo ert.texinfo' in the ERT
+;; directory, then C-u M-x info ert.info in Emacs to view it.
+;;
+;; To see some examples of tests written in ERT, see its self-tests in
+;; ert-tests.el. Some of these are tricky due to the bootstrapping
+;; problem of writing tests for a testing tool, others test simple
+;; functions and are straightforward.
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl))
+(require 'button)
+(require 'debug)
+(require 'easymenu)
+(require 'ewoc)
+(require 'find-func)
+(require 'help)
+
+
+;;; UI customization options.
+
+(defgroup ert ()
+ "ERT, the Emacs Lisp regression testing tool."
+ :prefix "ert-"
+ :group 'lisp)
+
+(defface ert-test-result-expected '((((class color) (background light))
+ :background "green1")
+ (((class color) (background dark))
+ :background "green3"))
+ "Face used for expected results in the ERT results buffer."
+ :group 'ert)
+
+(defface ert-test-result-unexpected '((((class color) (background light))
+ :background "red1")
+ (((class color) (background dark))
+ :background "red3"))
+ "Face used for unexpected results in the ERT results buffer."
+ :group 'ert)
+
+
+;;; Copies/reimplementations of cl functions.
+
+(defun ert--cl-do-remf (plist tag)
+ "Copy of `cl-do-remf'. Modify PLIST by removing TAG."
+ (let ((p (cdr plist)))
+ (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p))))
+ (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t))))
+
+(defun ert--remprop (sym tag)
+ "Copy of `cl-remprop'. Modify SYM's plist by removing TAG."
+ (let ((plist (symbol-plist sym)))
+ (if (and plist (eq tag (car plist)))
+ (progn (setplist sym (cdr (cdr plist))) t)
+ (ert--cl-do-remf plist tag))))
+
+(defun ert--remove-if-not (ert-pred ert-list)
+ "A reimplementation of `remove-if-not'.
+
+ERT-PRED is a predicate, ERT-LIST is the input list."
+ (loop for ert-x in ert-list
+ if (funcall ert-pred ert-x)
+ collect ert-x))
+
+(defun ert--intersection (a b)
+ "A reimplementation of `intersection'. Intersect the sets A and B.
+
+Elements are compared using `eql'."
+ (loop for x in a
+ if (memql x b)
+ collect x))
+
+(defun ert--set-difference (a b)
+ "A reimplementation of `set-difference'. Subtract the set B from the set A.
+
+Elements are compared using `eql'."
+ (loop for x in a
+ unless (memql x b)
+ collect x))
+
+(defun ert--set-difference-eq (a b)
+ "A reimplementation of `set-difference'. Subtract the set B from the set A.
+
+Elements are compared using `eq'."
+ (loop for x in a
+ unless (memq x b)
+ collect x))
+
+(defun ert--union (a b)
+ "A reimplementation of `union'. Compute the union of the sets A and B.
+
+Elements are compared using `eql'."
+ (append a (ert--set-difference b a)))
+
+(eval-and-compile
+ (defvar ert--gensym-counter 0))
+
+(eval-and-compile
+ (defun ert--gensym (&optional prefix)
+ "Only allows string PREFIX, not compatible with CL."
+ (unless prefix (setq prefix "G"))
+ (make-symbol (format "%s%s"
+ prefix
+ (prog1 ert--gensym-counter
+ (incf ert--gensym-counter))))))
+
+(defun ert--coerce-to-vector (x)
+ "Coerce X to a vector."
+ (when (char-table-p x) (error "Not supported"))
+ (if (vectorp x)
+ x
+ (vconcat x)))
+
+(defun* ert--remove* (x list &key key test)
+ "Does not support all the keywords of remove*."
+ (unless key (setq key #'identity))
+ (unless test (setq test #'eql))
+ (loop for y in list
+ unless (funcall test x (funcall key y))
+ collect y))
+
+(defun ert--string-position (c s)
+ "Return the position of the first occurrence of C in S, or nil if none."
+ (loop for i from 0
+ for x across s
+ when (eql x c) return i))
+
+(defun ert--mismatch (a b)
+ "Return index of first element that differs between A and B.
+
+Like `mismatch'. Uses `equal' for comparison."
+ (cond ((or (listp a) (listp b))
+ (ert--mismatch (ert--coerce-to-vector a)
+ (ert--coerce-to-vector b)))
+ ((> (length a) (length b))
+ (ert--mismatch b a))
+ (t
+ (let ((la (length a))
+ (lb (length b)))
+ (assert (arrayp a) t)
+ (assert (arrayp b) t)
+ (assert (<= la lb) t)
+ (loop for i below la
+ when (not (equal (aref a i) (aref b i))) return i
+ finally (return (if (/= la lb)
+ la
+ (assert (equal a b) t)
+ nil)))))))
+
+(defun ert--subseq (seq start &optional end)
+ "Return a subsequence of SEQ from START to END."
+ (when (char-table-p seq) (error "Not supported"))
+ (let ((vector (substring (ert--coerce-to-vector seq) start end)))
+ (etypecase seq
+ (vector vector)
+ (string (concat vector))
+ (list (append vector nil))
+ (bool-vector (loop with result = (make-bool-vector (length vector) nil)
+ for i below (length vector) do
+ (setf (aref result i) (aref vector i))
+ finally (return result)))
+ (char-table (assert nil)))))
+
+(defun ert-equal-including-properties (a b)
+ "Return t if A and B have similar structure and contents.
+
+This is like `equal-including-properties' except that it compares
+the property values of text properties structurally (by
+recursing) rather than with `eq'. Perhaps this is what
+`equal-including-properties' should do in the first place; see
+Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'."
+ ;; This implementation is inefficient. Rather than making it
+ ;; efficient, let's hope bug 6581 gets fixed so that we can delete
+ ;; it altogether.
+ (not (ert--explain-equal-including-properties a b)))
+
+
+;;; Defining and locating tests.
+
+;; The data structure that represents a test case.
+(defstruct ert-test
+ (name nil)
+ (documentation nil)
+ (body (assert nil))
+ (most-recent-result nil)
+ (expected-result-type ':passed)
+ (tags '()))
+
+(defun ert-test-boundp (symbol)
+ "Return non-nil if SYMBOL names a test."
+ (and (get symbol 'ert--test) t))
+
+(defun ert-get-test (symbol)
+ "If SYMBOL names a test, return that. Signal an error otherwise."
+ (unless (ert-test-boundp symbol) (error "No test named `%S'" symbol))
+ (get symbol 'ert--test))
+
+(defun ert-set-test (symbol definition)
+ "Make SYMBOL name the test DEFINITION, and return DEFINITION."
+ (when (eq symbol 'nil)
+ ;; We disallow nil since `ert-test-at-point' and related functions
+ ;; want to return a test name, but also need an out-of-band value
+ ;; on failure. Nil is the most natural out-of-band value; using 0
+ ;; or "" or signalling an error would be too awkward.
+ ;;
+ ;; Note that nil is still a valid value for the `name' slot in
+ ;; ert-test objects. It designates an anonymous test.
+ (error "Attempt to define a test named nil"))
+ (put symbol 'ert--test definition)
+ definition)
+
+(defun ert-make-test-unbound (symbol)
+ "Make SYMBOL name no test. Return SYMBOL."
+ (ert--remprop symbol 'ert--test)
+ symbol)
+
+(defun ert--parse-keys-and-body (keys-and-body)
+ "Split KEYS-AND-BODY into keyword-and-value pairs and the remaining body.
+
+KEYS-AND-BODY should have the form of a property list, with the
+exception that only keywords are permitted as keys and that the
+tail -- the body -- is a list of forms that does not start with a
+keyword.
+
+Returns a two-element list containing the keys-and-values plist
+and the body."
+ (let ((extracted-key-accu '())
+ (remaining keys-and-body))
+ (while (and (consp remaining) (keywordp (first remaining)))
+ (let ((keyword (pop remaining)))
+ (unless (consp remaining)
+ (error "Value expected after keyword %S in %S"
+ keyword keys-and-body))
+ (when (assoc keyword extracted-key-accu)
+ (warn "Keyword %S appears more than once in %S" keyword
+ keys-and-body))
+ (push (cons keyword (pop remaining)) extracted-key-accu)))
+ (setq extracted-key-accu (nreverse extracted-key-accu))
+ (list (loop for (key . value) in extracted-key-accu
+ collect key
+ collect value)
+ remaining)))
+
+;;;###autoload
+(defmacro* ert-deftest (name () &body docstring-keys-and-body)
+ "Define NAME (a symbol) as a test.
+
+BODY is evaluated as a `progn' when the test is run. It should
+signal a condition on failure or just return if the test passes.
+
+`should', `should-not' and `should-error' are useful for
+assertions in BODY.
+
+Use `ert' to run tests interactively.
+
+Tests that are expected to fail can be marked as such
+using :expected-result. See `ert-test-result-type-p' for a
+description of valid values for RESULT-TYPE.
+
+\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \
+\[:tags '(TAG...)] BODY...)"
+ (declare (debug (&define :name test
+ name sexp [&optional stringp]
+ [&rest keywordp sexp] def-body))
+ (doc-string 3)
+ (indent 2))
+ (let ((documentation nil)
+ (documentation-supplied-p nil))
+ (when (stringp (first docstring-keys-and-body))
+ (setq documentation (pop docstring-keys-and-body)
+ documentation-supplied-p t))
+ (destructuring-bind ((&key (expected-result nil expected-result-supplied-p)
+ (tags nil tags-supplied-p))
+ body)
+ (ert--parse-keys-and-body docstring-keys-and-body)
+ `(progn
+ (ert-set-test ',name
+ (make-ert-test
+ :name ',name
+ ,@(when documentation-supplied-p
+ `(:documentation ,documentation))
+ ,@(when expected-result-supplied-p
+ `(:expected-result-type ,expected-result))
+ ,@(when tags-supplied-p
+ `(:tags ,tags))
+ :body (lambda () ,@body)))
+ ;; This hack allows `symbol-file' to associate `ert-deftest'
+ ;; forms with files, and therefore enables `find-function' to
+ ;; work with tests. However, it leads to warnings in
+ ;; `unload-feature', which doesn't know how to undefine tests
+ ;; and has no mechanism for extension.
+ (push '(ert-deftest . ,name) current-load-list)
+ ',name))))
+
+;; We use these `put' forms in addition to the (declare (indent)) in
+;; the defmacro form since the `declare' alone does not lead to
+;; correct indentation before the .el/.elc file is loaded.
+;; Autoloading these `put' forms solves this.
+;;;###autoload
+(progn
+ ;; TODO(ohler): Figure out what these mean and make sure they are correct.
+ (put 'ert-deftest 'lisp-indent-function 2)
+ (put 'ert-info 'lisp-indent-function 1))
+
+(defvar ert--find-test-regexp
+ (concat "^\\s-*(ert-deftest"
+ find-function-space-re
+ "%s\\(\\s-\\|$\\)")
+ "The regexp the `find-function' mechanisms use for finding test definitions.")
+
+
+(put 'ert-test-failed 'error-conditions '(error ert-test-failed))
+(put 'ert-test-failed 'error-message "Test failed")
+
+(defun ert-pass ()
+ "Terminate the current test and mark it passed. Does not return."
+ (throw 'ert--pass nil))
+
+(defun ert-fail (data)
+ "Terminate the current test and mark it failed. Does not return.
+DATA is displayed to the user and should state the reason of the failure."
+ (signal 'ert-test-failed (list data)))
+
+
+;;; The `should' macros.
+
+(defvar ert--should-execution-observer nil)
+
+(defun ert--signal-should-execution (form-description)
+ "Tell the current `should' form observer (if any) about FORM-DESCRIPTION."
+ (when ert--should-execution-observer
+ (funcall ert--should-execution-observer form-description)))
+
+(defun ert--special-operator-p (thing)
+ "Return non-nil if THING is a symbol naming a special operator."
+ (and (symbolp thing)
+ (let ((definition (indirect-function thing t)))
+ (and (subrp definition)
+ (eql (cdr (subr-arity definition)) 'unevalled)))))
+
+(defun ert--expand-should-1 (whole form inner-expander)
+ "Helper function for the `should' macro and its variants."
+ (let ((form
+ ;; If `cl-macroexpand' isn't bound, the code that we're
+ ;; compiling doesn't depend on cl and thus doesn't need an
+ ;; environment arg for `macroexpand'.
+ (if (fboundp 'cl-macroexpand)
+ ;; Suppress warning about run-time call to cl funtion: we
+ ;; only call it if it's fboundp.
+ (with-no-warnings
+ (cl-macroexpand form (and (boundp 'cl-macro-environment)
+ cl-macro-environment)))
+ (macroexpand form))))
+ (cond
+ ((or (atom form) (ert--special-operator-p (car form)))
+ (let ((value (ert--gensym "value-")))
+ `(let ((,value (ert--gensym "ert-form-evaluation-aborted-")))
+ ,(funcall inner-expander
+ `(setq ,value ,form)
+ `(list ',whole :form ',form :value ,value)
+ value)
+ ,value)))
+ (t
+ (let ((fn-name (car form))
+ (arg-forms (cdr form)))
+ (assert (or (symbolp fn-name)
+ (and (consp fn-name)
+ (eql (car fn-name) 'lambda)
+ (listp (cdr fn-name)))))
+ (let ((fn (ert--gensym "fn-"))
+ (args (ert--gensym "args-"))
+ (value (ert--gensym "value-"))
+ (default-value (ert--gensym "ert-form-evaluation-aborted-")))
+ `(let ((,fn (function ,fn-name))
+ (,args (list ,@arg-forms)))
+ (let ((,value ',default-value))
+ ,(funcall inner-expander
+ `(setq ,value (apply ,fn ,args))
+ `(nconc (list ',whole)
+ (list :form `(,,fn ,@,args))
+ (unless (eql ,value ',default-value)
+ (list :value ,value))
+ (let ((-explainer-
+ (and (symbolp ',fn-name)
+ (get ',fn-name 'ert-explainer))))
+ (when -explainer-
+ (list :explanation
+ (apply -explainer- ,args)))))
+ value)
+ ,value))))))))
+
+(defun ert--expand-should (whole form inner-expander)
+ "Helper function for the `should' macro and its variants.
+
+Analyzes FORM and returns an expression that has the same
+semantics under evaluation but records additional debugging
+information.
+
+INNER-EXPANDER should be a function and is called with two
+arguments: INNER-FORM and FORM-DESCRIPTION-FORM, where INNER-FORM
+is an expression equivalent to FORM, and FORM-DESCRIPTION-FORM is
+an expression that returns a description of FORM. INNER-EXPANDER
+should return code that calls INNER-FORM and performs the checks
+and error signalling specific to the particular variant of
+`should'. The code that INNER-EXPANDER returns must not call
+FORM-DESCRIPTION-FORM before it has called INNER-FORM."
+ (lexical-let ((inner-expander inner-expander))
+ (ert--expand-should-1
+ whole form
+ (lambda (inner-form form-description-form value-var)
+ (let ((form-description (ert--gensym "form-description-")))
+ `(let (,form-description)
+ ,(funcall inner-expander
+ `(unwind-protect
+ ,inner-form
+ (setq ,form-description ,form-description-form)
+ (ert--signal-should-execution ,form-description))
+ `,form-description
+ value-var)))))))
+
+(defmacro* should (form)
+ "Evaluate FORM. If it returns nil, abort the current test as failed.
+
+Returns the value of FORM."
+ (ert--expand-should `(should ,form) form
+ (lambda (inner-form form-description-form value-var)
+ `(unless ,inner-form
+ (ert-fail ,form-description-form)))))
+
+(defmacro* should-not (form)
+ "Evaluate FORM. If it returns non-nil, abort the current test as failed.
+
+Returns nil."
+ (ert--expand-should `(should-not ,form) form
+ (lambda (inner-form form-description-form value-var)
+ `(unless (not ,inner-form)
+ (ert-fail ,form-description-form)))))
+
+(defun ert--should-error-handle-error (form-description-fn
+ condition type exclude-subtypes)
+ "Helper function for `should-error'.
+
+Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES,
+and aborts the current test as failed if it doesn't."
+ (let ((signalled-conditions (get (car condition) 'error-conditions))
+ (handled-conditions (etypecase type
+ (list type)
+ (symbol (list type)))))
+ (assert signalled-conditions)
+ (unless (ert--intersection signalled-conditions handled-conditions)
+ (ert-fail (append
+ (funcall form-description-fn)
+ (list
+ :condition condition
+ :fail-reason (concat "the error signalled did not"
+ " have the expected type")))))
+ (when exclude-subtypes
+ (unless (member (car condition) handled-conditions)
+ (ert-fail (append
+ (funcall form-description-fn)
+ (list
+ :condition condition
+ :fail-reason (concat "the error signalled was a subtype"
+ " of the expected type"))))))))
+
+;; FIXME: The expansion will evaluate the keyword args (if any) in
+;; nonstandard order.
+(defmacro* should-error (form &rest keys &key type exclude-subtypes)
+ "Evaluate FORM and check that it signals an error.
+
+The error signalled needs to match TYPE. TYPE should be a list
+of condition names. (It can also be a non-nil symbol, which is
+equivalent to a singleton list containing that symbol.) If
+EXCLUDE-SUBTYPES is nil, the error matches TYPE if one of its
+condition names is an element of TYPE. If EXCLUDE-SUBTYPES is
+non-nil, the error matches TYPE if it is an element of TYPE.
+
+If the error matches, returns (ERROR-SYMBOL . DATA) from the
+error. If not, or if no error was signalled, abort the test as
+failed."
+ (unless type (setq type ''error))
+ (ert--expand-should
+ `(should-error ,form ,@keys)
+ form
+ (lambda (inner-form form-description-form value-var)
+ (let ((errorp (ert--gensym "errorp"))
+ (form-description-fn (ert--gensym "form-description-fn-")))
+ `(let ((,errorp nil)
+ (,form-description-fn (lambda () ,form-description-form)))
+ (condition-case -condition-
+ ,inner-form
+ ;; We can't use ,type here because we want to evaluate it.
+ (error
+ (setq ,errorp t)
+ (ert--should-error-handle-error ,form-description-fn
+ -condition-
+ ,type ,exclude-subtypes)
+ (setq ,value-var -condition-)))
+ (unless ,errorp
+ (ert-fail (append
+ (funcall ,form-description-fn)
+ (list
+ :fail-reason "did not signal an error")))))))))
+
+
+;;; Explanation of `should' failures.
+
+;; TODO(ohler): Rework explanations so that they are displayed in a
+;; similar way to `ert-info' messages; in particular, allow text
+;; buttons in explanations that give more detail or open an ediff
+;; buffer. Perhaps explanations should be reported through `ert-info'
+;; rather than as part of the condition.
+
+(defun ert--proper-list-p (x)
+ "Return non-nil if X is a proper list, nil otherwise."
+ (loop
+ for firstp = t then nil
+ for fast = x then (cddr fast)
+ for slow = x then (cdr slow) do
+ (when (null fast) (return t))
+ (when (not (consp fast)) (return nil))
+ (when (null (cdr fast)) (return t))
+ (when (not (consp (cdr fast))) (return nil))
+ (when (and (not firstp) (eq fast slow)) (return nil))))
+
+(defun ert--explain-format-atom (x)
+ "Format the atom X for `ert--explain-equal'."
+ (typecase x
+ (fixnum (list x (format "#x%x" x) (format "?%c" x)))
+ (t x)))
+
+(defun ert--explain-equal-rec (a b)
+ "Returns a programmer-readable explanation of why A and B are not `equal'.
+
+Returns nil if they are."
+ (if (not (equal (type-of a) (type-of b)))
+ `(different-types ,a ,b)
+ (etypecase a
+ (cons
+ (let ((a-proper-p (ert--proper-list-p a))
+ (b-proper-p (ert--proper-list-p b)))
+ (if (not (eql (not a-proper-p) (not b-proper-p)))
+ `(one-list-proper-one-improper ,a ,b)
+ (if a-proper-p
+ (if (not (equal (length a) (length b)))
+ `(proper-lists-of-different-length ,(length a) ,(length b)
+ ,a ,b
+ first-mismatch-at
+ ,(ert--mismatch a b))
+ (loop for i from 0
+ for ai in a
+ for bi in b
+ for xi = (ert--explain-equal-rec ai bi)
+ do (when xi (return `(list-elt ,i ,xi)))
+ finally (assert (equal a b) t)))
+ (let ((car-x (ert--explain-equal-rec (car a) (car b))))
+ (if car-x
+ `(car ,car-x)
+ (let ((cdr-x (ert--explain-equal-rec (cdr a) (cdr b))))
+ (if cdr-x
+ `(cdr ,cdr-x)
+ (assert (equal a b) t)
+ nil))))))))
+ (array (if (not (equal (length a) (length b)))
+ `(arrays-of-different-length ,(length a) ,(length b)
+ ,a ,b
+ ,@(unless (char-table-p a)
+ `(first-mismatch-at
+ ,(ert--mismatch a b))))
+ (loop for i from 0
+ for ai across a
+ for bi across b
+ for xi = (ert--explain-equal-rec ai bi)
+ do (when xi (return `(array-elt ,i ,xi)))
+ finally (assert (equal a b) t))))
+ (atom (if (not (equal a b))
+ (if (and (symbolp a) (symbolp b) (string= a b))
+ `(different-symbols-with-the-same-name ,a ,b)
+ `(different-atoms ,(ert--explain-format-atom a)
+ ,(ert--explain-format-atom b)))
+ nil)))))
+
+(defun ert--explain-equal (a b)
+ "Explainer function for `equal'."
+ ;; Do a quick comparison in C to avoid running our expensive
+ ;; comparison when possible.
+ (if (equal a b)
+ nil
+ (ert--explain-equal-rec a b)))
+(put 'equal 'ert-explainer 'ert--explain-equal)
+
+(defun ert--significant-plist-keys (plist)
+ "Return the keys of PLIST that have non-null values, in order."
+ (assert (zerop (mod (length plist) 2)) t)
+ (loop for (key value . rest) on plist by #'cddr
+ unless (or (null value) (memq key accu)) collect key into accu
+ finally (return accu)))
+
+(defun ert--plist-difference-explanation (a b)
+ "Return a programmer-readable explanation of why A and B are different plists.
+
+Returns nil if they are equivalent, i.e., have the same value for
+each key, where absent values are treated as nil. The order of
+key/value pairs in each list does not matter."
+ (assert (zerop (mod (length a) 2)) t)
+ (assert (zerop (mod (length b) 2)) t)
+ ;; Normalizing the plists would be another way to do this but it
+ ;; requires a total ordering on all lisp objects (since any object
+ ;; is valid as a text property key). Perhaps defining such an
+ ;; ordering is useful in other contexts, too, but it's a lot of
+ ;; work, so let's punt on it for now.
+ (let* ((keys-a (ert--significant-plist-keys a))
+ (keys-b (ert--significant-plist-keys b))
+ (keys-in-a-not-in-b (ert--set-difference-eq keys-a keys-b))
+ (keys-in-b-not-in-a (ert--set-difference-eq keys-b keys-a)))
+ (flet ((explain-with-key (key)
+ (let ((value-a (plist-get a key))
+ (value-b (plist-get b key)))
+ (assert (not (equal value-a value-b)) t)
+ `(different-properties-for-key
+ ,key ,(ert--explain-equal-including-properties value-a
+ value-b)))))
+ (cond (keys-in-a-not-in-b
+ (explain-with-key (first keys-in-a-not-in-b)))
+ (keys-in-b-not-in-a
+ (explain-with-key (first keys-in-b-not-in-a)))
+ (t
+ (loop for key in keys-a
+ when (not (equal (plist-get a key) (plist-get b key)))
+ return (explain-with-key key)))))))
+
+(defun ert--abbreviate-string (s len suffixp)
+ "Shorten string S to at most LEN chars.
+
+If SUFFIXP is non-nil, returns a suffix of S, otherwise a prefix."
+ (let ((n (length s)))
+ (cond ((< n len)
+ s)
+ (suffixp
+ (substring s (- n len)))
+ (t
+ (substring s 0 len)))))
+
+;; TODO(ohler): Once bug 6581 is fixed, rename this to
+;; `ert--explain-equal-including-properties-rec' and add a fast-path
+;; wrapper like `ert--explain-equal'.
+(defun ert--explain-equal-including-properties (a b)
+ "Explainer function for `ert-equal-including-properties'.
+
+Returns a programmer-readable explanation of why A and B are not
+`ert-equal-including-properties', or nil if they are."
+ (if (not (equal a b))
+ (ert--explain-equal a b)
+ (assert (stringp a) t)
+ (assert (stringp b) t)
+ (assert (eql (length a) (length b)) t)
+ (loop for i from 0 to (length a)
+ for props-a = (text-properties-at i a)
+ for props-b = (text-properties-at i b)
+ for difference = (ert--plist-difference-explanation props-a props-b)
+ do (when difference
+ (return `(char ,i ,(substring-no-properties a i (1+ i))
+ ,difference
+ context-before
+ ,(ert--abbreviate-string
+ (substring-no-properties a 0 i)
+ 10 t)
+ context-after
+ ,(ert--abbreviate-string
+ (substring-no-properties a (1+ i))
+ 10 nil))))
+ ;; TODO(ohler): Get `equal-including-properties' fixed in
+ ;; Emacs, delete `ert-equal-including-properties', and
+ ;; re-enable this assertion.
+ ;;finally (assert (equal-including-properties a b) t)
+ )))
+(put 'ert-equal-including-properties
+ 'ert-explainer
+ 'ert--explain-equal-including-properties)
+
+
+;;; Implementation of `ert-info'.
+
+;; TODO(ohler): The name `info' clashes with
+;; `ert--test-execution-info'. One or both should be renamed.
+(defvar ert--infos '()
+ "The stack of `ert-info' infos that currently apply.
+
+Bound dynamically. This is a list of (PREFIX . MESSAGE) pairs.")
+
+(defmacro* ert-info ((message-form &key ((:prefix prefix-form) "Info: "))
+ &body body)
+ "Evaluate MESSAGE-FORM and BODY, and report the message if BODY fails.
+
+To be used within ERT tests. MESSAGE-FORM should evaluate to a
+string that will be displayed together with the test result if
+the test fails. PREFIX-FORM should evaluate to a string as well
+and is displayed in front of the value of MESSAGE-FORM."
+ (declare (debug ((form &rest [sexp form]) body))
+ (indent 1))
+ `(let ((ert--infos (cons (cons ,prefix-form ,message-form) ert--infos)))
+ ,@body))
+
+
+
+;;; Facilities for running a single test.
+
+(defvar ert-debug-on-error nil
+ "Non-nil means enter debugger when a test fails or terminates with an error.")
+
+;; The data structures that represent the result of running a test.
+(defstruct ert-test-result
+ (messages nil)
+ (should-forms nil)
+ )
+(defstruct (ert-test-passed (:include ert-test-result)))
+(defstruct (ert-test-result-with-condition (:include ert-test-result))
+ (condition (assert nil))
+ (backtrace (assert nil))
+ (infos (assert nil)))
+(defstruct (ert-test-quit (:include ert-test-result-with-condition)))
+(defstruct (ert-test-failed (:include ert-test-result-with-condition)))
+(defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result)))
+
+
+(defun ert--record-backtrace ()
+ "Record the current backtrace (as a list) and return it."
+ ;; Since the backtrace is stored in the result object, result
+ ;; objects must only be printed with appropriate limits
+ ;; (`print-level' and `print-length') in place. For interactive
+ ;; use, the cost of ensuring this possibly outweighs the advantage
+ ;; of storing the backtrace for
+ ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we
+ ;; already have `ert-results-rerun-test-debugging-errors-at-point'.
+ ;; For batch use, however, printing the backtrace may be useful.
+ (loop
+ ;; 6 is the number of frames our own debugger adds (when
+ ;; compiled; more when interpreted). FIXME: Need to describe a
+ ;; procedure for determining this constant.
+ for i from 6
+ for frame = (backtrace-frame i)
+ while frame
+ collect frame))
+
+(defun ert--print-backtrace (backtrace)
+ "Format the backtrace BACKTRACE to the current buffer."
+ ;; This is essentially a reimplementation of Fbacktrace
+ ;; (src/eval.c), but for a saved backtrace, not the current one.
+ (let ((print-escape-newlines t)
+ (print-level 8)
+ (print-length 50))
+ (dolist (frame backtrace)
+ (ecase (first frame)
+ ((nil)
+ ;; Special operator.
+ (destructuring-bind (special-operator &rest arg-forms)
+ (cdr frame)
+ (insert
+ (format " %S\n" (list* special-operator arg-forms)))))
+ ((t)
+ ;; Function call.
+ (destructuring-bind (fn &rest args) (cdr frame)
+ (insert (format " %S(" fn))
+ (loop for firstp = t then nil
+ for arg in args do
+ (unless firstp
+ (insert " "))
+ (insert (format "%S" arg)))
+ (insert ")\n")))))))
+
+;; A container for the state of the execution of a single test and
+;; environment data needed during its execution.
+(defstruct ert--test-execution-info
+ (test (assert nil))
+ (result (assert nil))
+ ;; A thunk that may be called when RESULT has been set to its final
+ ;; value and test execution should be terminated. Should not
+ ;; return.
+ (exit-continuation (assert nil))
+ ;; The binding of `debugger' outside of the execution of the test.
+ next-debugger
+ ;; The binding of `ert-debug-on-error' that is in effect for the
+ ;; execution of the current test. We store it to avoid being
+ ;; affected by any new bindings the test itself may establish. (I
+ ;; don't remember whether this feature is important.)
+ ert-debug-on-error)
+
+(defun ert--run-test-debugger (info debugger-args)
+ "During a test run, `debugger' is bound to a closure that calls this function.
+
+This function records failures and errors and either terminates
+the test silently or calls the interactive debugger, as
+appropriate.
+
+INFO is the ert--test-execution-info corresponding to this test
+run. DEBUGGER-ARGS are the arguments to `debugger'."
+ (destructuring-bind (first-debugger-arg &rest more-debugger-args)
+ debugger-args
+ (ecase first-debugger-arg
+ ((lambda debug t exit nil)
+ (apply (ert--test-execution-info-next-debugger info) debugger-args))
+ (error
+ (let* ((condition (first more-debugger-args))
+ (type (case (car condition)
+ ((quit) 'quit)
+ (otherwise 'failed)))
+ (backtrace (ert--record-backtrace))
+ (infos (reverse ert--infos)))
+ (setf (ert--test-execution-info-result info)
+ (ecase type
+ (quit
+ (make-ert-test-quit :condition condition
+ :backtrace backtrace
+ :infos infos))
+ (failed
+ (make-ert-test-failed :condition condition
+ :backtrace backtrace
+ :infos infos))))
+ ;; Work around Emacs' heuristic (in eval.c) for detecting
+ ;; errors in the debugger.
+ (incf num-nonmacro-input-events)
+ ;; FIXME: We should probably implement more fine-grained
+ ;; control a la non-t `debug-on-error' here.
+ (cond
+ ((ert--test-execution-info-ert-debug-on-error info)
+ (apply (ert--test-execution-info-next-debugger info) debugger-args))
+ (t))
+ (funcall (ert--test-execution-info-exit-continuation info)))))))
+
+(defun ert--run-test-internal (ert-test-execution-info)
+ "Low-level function to run a test according to ERT-TEST-EXECUTION-INFO.
+
+This mainly sets up debugger-related bindings."
+ (lexical-let ((info ert-test-execution-info))
+ (setf (ert--test-execution-info-next-debugger info) debugger
+ (ert--test-execution-info-ert-debug-on-error info) ert-debug-on-error)
+ (catch 'ert--pass
+ ;; For now, each test gets its own temp buffer and its own
+ ;; window excursion, just to be safe. If this turns out to be
+ ;; too expensive, we can remove it.
+ (with-temp-buffer
+ (save-window-excursion
+ (let ((debugger (lambda (&rest debugger-args)
+ (ert--run-test-debugger info debugger-args)))
+ (debug-on-error t)
+ (debug-on-quit t)
+ ;; FIXME: Do we need to store the old binding of this
+ ;; and consider it in `ert--run-test-debugger'?
+ (debug-ignored-errors nil)
+ (ert--infos '()))
+ (funcall (ert-test-body (ert--test-execution-info-test info))))))
+ (ert-pass))
+ (setf (ert--test-execution-info-result info) (make-ert-test-passed)))
+ nil)
+
+(defun ert--force-message-log-buffer-truncation ()
+ "Immediately truncate *Messages* buffer according to `message-log-max'.
+
+This can be useful after reducing the value of `message-log-max'."
+ (with-current-buffer (get-buffer-create "*Messages*")
+ ;; This is a reimplementation of this part of message_dolog() in xdisp.c:
+ ;; if (NATNUMP (Vmessage_log_max))
+ ;; {
+ ;; scan_newline (Z, Z_BYTE, BEG, BEG_BYTE,
+ ;; -XFASTINT (Vmessage_log_max) - 1, 0);
+ ;; del_range_both (BEG, BEG_BYTE, PT, PT_BYTE, 0);
+ ;; }
+ (when (and (integerp message-log-max) (>= message-log-max 0))
+ (let ((begin (point-min))
+ (end (save-excursion
+ (goto-char (point-max))
+ (forward-line (- message-log-max))
+ (point))))
+ (delete-region begin end)))))
+
+(defvar ert--running-tests nil
+ "List of tests that are currently in execution.
+
+This list is empty while no test is running, has one element
+while a test is running, two elements while a test run from
+inside a test is running, etc. The list is in order of nesting,
+innermost test first.
+
+The elements are of type `ert-test'.")
+
+(defun ert-run-test (ert-test)
+ "Run ERT-TEST.
+
+Returns the result and stores it in ERT-TEST's `most-recent-result' slot."
+ (setf (ert-test-most-recent-result ert-test) nil)
+ (block error
+ (lexical-let ((begin-marker
+ (with-current-buffer (get-buffer-create "*Messages*")
+ (set-marker (make-marker) (point-max)))))
+ (unwind-protect
+ (lexical-let ((info (make-ert--test-execution-info
+ :test ert-test
+ :result
+ (make-ert-test-aborted-with-non-local-exit)
+ :exit-continuation (lambda ()
+ (return-from error nil))))
+ (should-form-accu (list)))
+ (unwind-protect
+ (let ((ert--should-execution-observer
+ (lambda (form-description)
+ (push form-description should-form-accu)))
+ (message-log-max t)
+ (ert--running-tests (cons ert-test ert--running-tests)))
+ (ert--run-test-internal info))
+ (let ((result (ert--test-execution-info-result info)))
+ (setf (ert-test-result-messages result)
+ (with-current-buffer (get-buffer-create "*Messages*")
+ (buffer-substring begin-marker (point-max))))
+ (ert--force-message-log-buffer-truncation)
+ (setq should-form-accu (nreverse should-form-accu))
+ (setf (ert-test-result-should-forms result)
+ should-form-accu)
+ (setf (ert-test-most-recent-result ert-test) result))))
+ (set-marker begin-marker nil))))
+ (ert-test-most-recent-result ert-test))
+
+(defun ert-running-test ()
+ "Return the top-level test currently executing."
+ (car (last ert--running-tests)))
+
+
+;;; Test selectors.
+
+(defun ert-test-result-type-p (result result-type)
+ "Return non-nil if RESULT matches type RESULT-TYPE.
+
+Valid result types:
+
+nil -- Never matches.
+t -- Always matches.
+:failed, :passed -- Matches corresponding results.
+\(and TYPES...\) -- Matches if all TYPES match.
+\(or TYPES...\) -- Matches if some TYPES match.
+\(not TYPE\) -- Matches if TYPE does not match.
+\(satisfies PREDICATE\) -- Matches if PREDICATE returns true when called with
+ RESULT."
+ ;; It would be easy to add `member' and `eql' types etc., but I
+ ;; haven't bothered yet.
+ (etypecase result-type
+ ((member nil) nil)
+ ((member t) t)
+ ((member :failed) (ert-test-failed-p result))
+ ((member :passed) (ert-test-passed-p result))
+ (cons
+ (destructuring-bind (operator &rest operands) result-type
+ (ecase operator
+ (and
+ (case (length operands)
+ (0 t)
+ (t
+ (and (ert-test-result-type-p result (first operands))
+ (ert-test-result-type-p result `(and ,@(rest operands)))))))
+ (or
+ (case (length operands)
+ (0 nil)
+ (t
+ (or (ert-test-result-type-p result (first operands))
+ (ert-test-result-type-p result `(or ,@(rest operands)))))))
+ (not
+ (assert (eql (length operands) 1))
+ (not (ert-test-result-type-p result (first operands))))
+ (satisfies
+ (assert (eql (length operands) 1))
+ (funcall (first operands) result)))))))
+
+(defun ert-test-result-expected-p (test result)
+ "Return non-nil if TEST's expected result type matches RESULT."
+ (ert-test-result-type-p result (ert-test-expected-result-type test)))
+
+(defun ert-select-tests (selector universe)
+ "Return the tests that match SELECTOR.
+
+UNIVERSE specifies the set of tests to select from; it should be
+a list of tests, or t, which refers to all tests named by symbols
+in `obarray'.
+
+Returns the set of tests as a list.
+
+Valid selectors:
+
+nil -- Selects the empty set.
+t -- Selects UNIVERSE.
+:new -- Selects all tests that have not been run yet.
+:failed, :passed -- Select tests according to their most recent result.
+:expected, :unexpected -- Select tests according to their most recent result.
+a string -- Selects all tests that have a name that matches the string,
+ a regexp.
+a test -- Selects that test.
+a symbol -- Selects the test that the symbol names, errors if none.
+\(member TESTS...\) -- Selects TESTS, a list of tests or symbols naming tests.
+\(eql TEST\) -- Selects TEST, a test or a symbol naming a test.
+\(and SELECTORS...\) -- Selects the tests that match all SELECTORS.
+\(or SELECTORS...\) -- Selects the tests that match any SELECTOR.
+\(not SELECTOR\) -- Selects all tests that do not match SELECTOR.
+\(tag TAG) -- Selects all tests that have TAG on their tags list.
+\(satisfies PREDICATE\) -- Selects all tests that satisfy PREDICATE.
+
+Only selectors that require a superset of tests, such
+as (satisfies ...), strings, :new, etc. make use of UNIVERSE.
+Selectors that do not, such as \(member ...\), just return the
+set implied by them without checking whether it is really
+contained in UNIVERSE."
+ ;; This code needs to match the etypecase in
+ ;; `ert-insert-human-readable-selector'.
+ (etypecase selector
+ ((member nil) nil)
+ ((member t) (etypecase universe
+ (list universe)
+ ((member t) (ert-select-tests "" universe))))
+ ((member :new) (ert-select-tests
+ `(satisfies ,(lambda (test)
+ (null (ert-test-most-recent-result test))))
+ universe))
+ ((member :failed) (ert-select-tests
+ `(satisfies ,(lambda (test)
+ (ert-test-result-type-p
+ (ert-test-most-recent-result test)
+ ':failed)))
+ universe))
+ ((member :passed) (ert-select-tests
+ `(satisfies ,(lambda (test)
+ (ert-test-result-type-p
+ (ert-test-most-recent-result test)
+ ':passed)))
+ universe))
+ ((member :expected) (ert-select-tests
+ `(satisfies
+ ,(lambda (test)
+ (ert-test-result-expected-p
+ test
+ (ert-test-most-recent-result test))))
+ universe))
+ ((member :unexpected) (ert-select-tests `(not :expected) universe))
+ (string
+ (etypecase universe
+ ((member t) (mapcar #'ert-get-test
+ (apropos-internal selector #'ert-test-boundp)))
+ (list (ert--remove-if-not (lambda (test)
+ (and (ert-test-name test)
+ (string-match selector
+ (ert-test-name test))))
+ universe))))
+ (ert-test (list selector))
+ (symbol
+ (assert (ert-test-boundp selector))
+ (list (ert-get-test selector)))
+ (cons
+ (destructuring-bind (operator &rest operands) selector
+ (ecase operator
+ (member
+ (mapcar (lambda (purported-test)
+ (etypecase purported-test
+ (symbol (assert (ert-test-boundp purported-test))
+ (ert-get-test purported-test))
+ (ert-test purported-test)))
+ operands))
+ (eql
+ (assert (eql (length operands) 1))
+ (ert-select-tests `(member ,@operands) universe))
+ (and
+ ;; Do these definitions of AND, NOT and OR satisfy de
+ ;; Morgan's laws? Should they?
+ (case (length operands)
+ (0 (ert-select-tests 't universe))
+ (t (ert-select-tests `(and ,@(rest operands))
+ (ert-select-tests (first operands)
+ universe)))))
+ (not
+ (assert (eql (length operands) 1))
+ (let ((all-tests (ert-select-tests 't universe)))
+ (ert--set-difference all-tests
+ (ert-select-tests (first operands)
+ all-tests))))
+ (or
+ (case (length operands)
+ (0 (ert-select-tests 'nil universe))
+ (t (ert--union (ert-select-tests (first operands) universe)
+ (ert-select-tests `(or ,@(rest operands))
+ universe)))))
+ (tag
+ (assert (eql (length operands) 1))
+ (let ((tag (first operands)))
+ (ert-select-tests `(satisfies
+ ,(lambda (test)
+ (member tag (ert-test-tags test))))
+ universe)))
+ (satisfies
+ (assert (eql (length operands) 1))
+ (ert--remove-if-not (first operands)
+ (ert-select-tests 't universe))))))))
+
+(defun ert--insert-human-readable-selector (selector)
+ "Insert a human-readable presentation of SELECTOR into the current buffer."
+ ;; This is needed to avoid printing the (huge) contents of the
+ ;; `backtrace' slot of the result objects in the
+ ;; `most-recent-result' slots of test case objects in (eql ...) or
+ ;; (member ...) selectors.
+ (labels ((rec (selector)
+ ;; This code needs to match the etypecase in `ert-select-tests'.
+ (etypecase selector
+ ((or (member nil t
+ :new :failed :passed
+ :expected :unexpected)
+ string
+ symbol)
+ selector)
+ (ert-test
+ (if (ert-test-name selector)
+ (make-symbol (format "<%S>" (ert-test-name selector)))
+ (make-symbol "<unnamed test>")))
+ (cons
+ (destructuring-bind (operator &rest operands) selector
+ (ecase operator
+ ((member eql and not or)
+ `(,operator ,@(mapcar #'rec operands)))
+ ((member tag satisfies)
+ selector)))))))
+ (insert (format "%S" (rec selector)))))
+
+
+;;; Facilities for running a whole set of tests.
+
+;; The data structure that contains the set of tests being executed
+;; during one particular test run, their results, the state of the
+;; execution, and some statistics.
+;;
+;; The data about results and expected results of tests may seem
+;; redundant here, since the test objects also carry such information.
+;; However, the information in the test objects may be more recent, it
+;; may correspond to a different test run. We need the information
+;; that corresponds to this run in order to be able to update the
+;; statistics correctly when a test is re-run interactively and has a
+;; different result than before.
+(defstruct ert--stats
+ (selector (assert nil))
+ ;; The tests, in order.
+ (tests (assert nil) :type vector)
+ ;; A map of test names (or the test objects themselves for unnamed
+ ;; tests) to indices into the `tests' vector.
+ (test-map (assert nil) :type hash-table)
+ ;; The results of the tests during this run, in order.
+ (test-results (assert nil) :type vector)
+ ;; The start times of the tests, in order, as reported by
+ ;; `current-time'.
+ (test-start-times (assert nil) :type vector)
+ ;; The end times of the tests, in order, as reported by
+ ;; `current-time'.
+ (test-end-times (assert nil) :type vector)
+ (passed-expected 0)
+ (passed-unexpected 0)
+ (failed-expected 0)
+ (failed-unexpected 0)
+ (start-time nil)
+ (end-time nil)
+ (aborted-p nil)
+ (current-test nil)
+ ;; The time at or after which the next redisplay should occur, as a
+ ;; float.
+ (next-redisplay 0.0))
+
+(defun ert-stats-completed-expected (stats)
+ "Return the number of tests in STATS that had expected results."
+ (+ (ert--stats-passed-expected stats)
+ (ert--stats-failed-expected stats)))
+
+(defun ert-stats-completed-unexpected (stats)
+ "Return the number of tests in STATS that had unexpected results."
+ (+ (ert--stats-passed-unexpected stats)
+ (ert--stats-failed-unexpected stats)))
+
+(defun ert-stats-completed (stats)
+ "Number of tests in STATS that have run so far."
+ (+ (ert-stats-completed-expected stats)
+ (ert-stats-completed-unexpected stats)))
+
+(defun ert-stats-total (stats)
+ "Number of tests in STATS, regardless of whether they have run yet."
+ (length (ert--stats-tests stats)))
+
+;; The stats object of the current run, dynamically bound. This is
+;; used for the mode line progress indicator.
+(defvar ert--current-run-stats nil)
+
+(defun ert--stats-test-key (test)
+ "Return the key used for TEST in the test map of ert--stats objects.
+
+Returns the name of TEST if it has one, or TEST itself otherwise."
+ (or (ert-test-name test) test))
+
+(defun ert--stats-set-test-and-result (stats pos test result)
+ "Change STATS by replacing the test at position POS with TEST and RESULT.
+
+Also changes the counters in STATS to match."
+ (let* ((tests (ert--stats-tests stats))
+ (results (ert--stats-test-results stats))
+ (old-test (aref tests pos))
+ (map (ert--stats-test-map stats)))
+ (flet ((update (d)
+ (if (ert-test-result-expected-p (aref tests pos)
+ (aref results pos))
+ (etypecase (aref results pos)
+ (ert-test-passed (incf (ert--stats-passed-expected stats) d))
+ (ert-test-failed (incf (ert--stats-failed-expected stats) d))
+ (null)
+ (ert-test-aborted-with-non-local-exit)
+ (ert-test-quit))
+ (etypecase (aref results pos)
+ (ert-test-passed (incf (ert--stats-passed-unexpected stats) d))
+ (ert-test-failed (incf (ert--stats-failed-unexpected stats) d))
+ (null)
+ (ert-test-aborted-with-non-local-exit)
+ (ert-test-quit)))))
+ ;; Adjust counters to remove the result that is currently in stats.
+ (update -1)
+ ;; Put new test and result into stats.
+ (setf (aref tests pos) test
+ (aref results pos) result)
+ (remhash (ert--stats-test-key old-test) map)
+ (setf (gethash (ert--stats-test-key test) map) pos)
+ ;; Adjust counters to match new result.
+ (update +1)
+ nil)))
+
+(defun ert--make-stats (tests selector)
+ "Create a new `ert--stats' object for running TESTS.
+
+SELECTOR is the selector that was used to select TESTS."
+ (setq tests (ert--coerce-to-vector tests))
+ (let ((map (make-hash-table :size (length tests))))
+ (loop for i from 0
+ for test across tests
+ for key = (ert--stats-test-key test) do
+ (assert (not (gethash key map)))
+ (setf (gethash key map) i))
+ (make-ert--stats :selector selector
+ :tests tests
+ :test-map map
+ :test-results (make-vector (length tests) nil)
+ :test-start-times (make-vector (length tests) nil)
+ :test-end-times (make-vector (length tests) nil))))
+
+(defun ert-run-or-rerun-test (stats test listener)
+ ;; checkdoc-order: nil
+ "Run the single test TEST and record the result using STATS and LISTENER."
+ (let ((ert--current-run-stats stats)
+ (pos (ert--stats-test-pos stats test)))
+ (ert--stats-set-test-and-result stats pos test nil)
+ ;; Call listener after setting/before resetting
+ ;; (ert--stats-current-test stats); the listener might refresh the
+ ;; mode line display, and if the value is not set yet/any more
+ ;; during this refresh, the mode line will flicker unnecessarily.
+ (setf (ert--stats-current-test stats) test)
+ (funcall listener 'test-started stats test)
+ (setf (ert-test-most-recent-result test) nil)
+ (setf (aref (ert--stats-test-start-times stats) pos) (current-time))
+ (unwind-protect
+ (ert-run-test test)
+ (setf (aref (ert--stats-test-end-times stats) pos) (current-time))
+ (let ((result (ert-test-most-recent-result test)))
+ (ert--stats-set-test-and-result stats pos test result)
+ (funcall listener 'test-ended stats test result))
+ (setf (ert--stats-current-test stats) nil))))
+
+(defun ert-run-tests (selector listener)
+ "Run the tests specified by SELECTOR, sending progress updates to LISTENER."
+ (let* ((tests (ert-select-tests selector t))
+ (stats (ert--make-stats tests selector)))
+ (setf (ert--stats-start-time stats) (current-time))
+ (funcall listener 'run-started stats)
+ (let ((abortedp t))
+ (unwind-protect
+ (let ((ert--current-run-stats stats))
+ (force-mode-line-update)
+ (unwind-protect
+ (progn
+ (loop for test in tests do
+ (ert-run-or-rerun-test stats test listener))
+ (setq abortedp nil))
+ (setf (ert--stats-aborted-p stats) abortedp)
+ (setf (ert--stats-end-time stats) (current-time))
+ (funcall listener 'run-ended stats abortedp)))
+ (force-mode-line-update))
+ stats)))
+
+(defun ert--stats-test-pos (stats test)
+ ;; checkdoc-order: nil
+ "Return the position (index) of TEST in the run represented by STATS."
+ (gethash (ert--stats-test-key test) (ert--stats-test-map stats)))
+
+
+;;; Formatting functions shared across UIs.
+
+(defun ert--format-time-iso8601 (time)
+ "Format TIME in the variant of ISO 8601 used for timestamps in ERT."
+ (format-time-string "%Y-%m-%d %T%z" time))
+
+(defun ert-char-for-test-result (result expectedp)
+ "Return a character that represents the test result RESULT.
+
+EXPECTEDP specifies whether the result was expected."
+ (let ((s (etypecase result
+ (ert-test-passed ".P")
+ (ert-test-failed "fF")
+ (null "--")
+ (ert-test-aborted-with-non-local-exit "aA")
+ (ert-test-quit "qQ"))))
+ (elt s (if expectedp 0 1))))
+
+(defun ert-string-for-test-result (result expectedp)
+ "Return a string that represents the test result RESULT.
+
+EXPECTEDP specifies whether the result was expected."
+ (let ((s (etypecase result
+ (ert-test-passed '("passed" "PASSED"))
+ (ert-test-failed '("failed" "FAILED"))
+ (null '("unknown" "UNKNOWN"))
+ (ert-test-aborted-with-non-local-exit '("aborted" "ABORTED"))
+ (ert-test-quit '("quit" "QUIT")))))
+ (elt s (if expectedp 0 1))))
+
+(defun ert--pp-with-indentation-and-newline (object)
+ "Pretty-print OBJECT, indenting it to the current column of point.
+Ensures a final newline is inserted."
+ (let ((begin (point)))
+ (pp object (current-buffer))
+ (unless (bolp) (insert "\n"))
+ (save-excursion
+ (goto-char begin)
+ (indent-sexp))))
+
+(defun ert--insert-infos (result)
+ "Insert `ert-info' infos from RESULT into current buffer.
+
+RESULT must be an `ert-test-result-with-condition'."
+ (check-type result ert-test-result-with-condition)
+ (dolist (info (ert-test-result-with-condition-infos result))
+ (destructuring-bind (prefix . message) info
+ (let ((begin (point))
+ (indentation (make-string (+ (length prefix) 4) ?\s))
+ (end nil))
+ (unwind-protect
+ (progn
+ (insert message "\n")
+ (setq end (copy-marker (point)))
+ (goto-char begin)
+ (insert " " prefix)
+ (forward-line 1)
+ (while (< (point) end)
+ (insert indentation)
+ (forward-line 1)))
+ (when end (set-marker end nil)))))))
+
+
+;;; Running tests in batch mode.
+
+(defvar ert-batch-backtrace-right-margin 70
+ "*The maximum line length for printing backtraces in `ert-run-tests-batch'.")
+
+;;;###autoload
+(defun ert-run-tests-batch (&optional selector)
+ "Run the tests specified by SELECTOR, printing results to the terminal.
+
+SELECTOR works as described in `ert-select-tests', except if
+SELECTOR is nil, in which case all tests rather than none will be
+run; this makes the command line \"emacs -batch -l my-tests.el -f
+ert-run-tests-batch-and-exit\" useful.
+
+Returns the stats object."
+ (unless selector (setq selector 't))
+ (ert-run-tests
+ selector
+ (lambda (event-type &rest event-args)
+ (ecase event-type
+ (run-started
+ (destructuring-bind (stats) event-args
+ (message "Running %s tests (%s)"
+ (length (ert--stats-tests stats))
+ (ert--format-time-iso8601 (ert--stats-start-time stats)))))
+ (run-ended
+ (destructuring-bind (stats abortedp) event-args
+ (let ((unexpected (ert-stats-completed-unexpected stats))
+ (expected-failures (ert--stats-failed-expected stats)))
+ (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n"
+ (if (not abortedp)
+ ""
+ "Aborted: ")
+ (ert-stats-total stats)
+ (ert-stats-completed-expected stats)
+ (if (zerop unexpected)
+ ""
+ (format ", %s unexpected" unexpected))
+ (ert--format-time-iso8601 (ert--stats-end-time stats))
+ (if (zerop expected-failures)
+ ""
+ (format "\n%s expected failures" expected-failures)))
+ (unless (zerop unexpected)
+ (message "%s unexpected results:" unexpected)
+ (loop for test across (ert--stats-tests stats)
+ for result = (ert-test-most-recent-result test) do
+ (when (not (ert-test-result-expected-p test result))
+ (message "%9s %S"
+ (ert-string-for-test-result result nil)
+ (ert-test-name test))))
+ (message "%s" "")))))
+ (test-started
+ )
+ (test-ended
+ (destructuring-bind (stats test result) event-args
+ (unless (ert-test-result-expected-p test result)
+ (etypecase result
+ (ert-test-passed
+ (message "Test %S passed unexpectedly" (ert-test-name test)))
+ (ert-test-result-with-condition
+ (message "Test %S backtrace:" (ert-test-name test))
+ (with-temp-buffer
+ (ert--print-backtrace (ert-test-result-with-condition-backtrace
+ result))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (let ((start (point))
+ (end (progn (end-of-line) (point))))
+ (setq end (min end
+ (+ start ert-batch-backtrace-right-margin)))
+ (message "%s" (buffer-substring-no-properties
+ start end)))
+ (forward-line 1)))
+ (with-temp-buffer
+ (ert--insert-infos result)
+ (insert " ")
+ (let ((print-escape-newlines t)
+ (print-level 5)
+ (print-length 10))
+ (ert--pp-with-indentation-and-newline
+ (ert-test-result-with-condition-condition result)))
+ (goto-char (1- (point-max)))
+ (assert (looking-at "\n"))
+ (delete-char 1)
+ (message "Test %S condition:" (ert-test-name test))
+ (message "%s" (buffer-string))))
+ (ert-test-aborted-with-non-local-exit
+ (message "Test %S aborted with non-local exit"
+ (ert-test-name test)))
+ (ert-test-quit
+ (message "Quit during %S" (ert-test-name test)))))
+ (let* ((max (prin1-to-string (length (ert--stats-tests stats))))
+ (format-string (concat "%9s %"
+ (prin1-to-string (length max))
+ "s/" max " %S")))
+ (message format-string
+ (ert-string-for-test-result result
+ (ert-test-result-expected-p
+ test result))
+ (1+ (ert--stats-test-pos stats test))
+ (ert-test-name test)))))))))
+
+;;;###autoload
+(defun ert-run-tests-batch-and-exit (&optional selector)
+ "Like `ert-run-tests-batch', but exits Emacs when done.
+
+The exit status will be 0 if all test results were as expected, 1
+on unexpected results, or 2 if the tool detected an error outside
+of the tests (e.g. invalid SELECTOR or bug in the code that runs
+the tests)."
+ (unwind-protect
+ (let ((stats (ert-run-tests-batch selector)))
+ (kill-emacs (if (zerop (ert-stats-completed-unexpected stats)) 0 1)))
+ (unwind-protect
+ (progn
+ (message "Error running tests")
+ (backtrace))
+ (kill-emacs 2))))
+
+
+;;; Utility functions for load/unload actions.
+
+(defun ert--activate-font-lock-keywords ()
+ "Activate font-lock keywords for some of ERT's symbols."
+ (font-lock-add-keywords
+ nil
+ '(("(\\(\\<ert-deftest\\)\\>\\s *\\(\\sw+\\)?"
+ (1 font-lock-keyword-face nil t)
+ (2 font-lock-function-name-face nil t)))))
+
+(defun* ert--remove-from-list (list-var element &key key test)
+ "Remove ELEMENT from the value of LIST-VAR if present.
+
+This can be used as an inverse of `add-to-list'."
+ (unless key (setq key #'identity))
+ (unless test (setq test #'equal))
+ (setf (symbol-value list-var)
+ (ert--remove* element
+ (symbol-value list-var)
+ :key key
+ :test test)))
+
+
+;;; Some basic interactive functions.
+
+(defun ert-read-test-name (prompt &optional default history
+ add-default-to-prompt)
+ "Read the name of a test and return it as a symbol.
+
+Prompt with PROMPT. If DEFAULT is a valid test name, use it as a
+default. HISTORY is the history to use; see `completing-read'.
+If ADD-DEFAULT-TO-PROMPT is non-nil, PROMPT will be modified to
+include the default, if any.
+
+Signals an error if no test name was read."
+ (etypecase default
+ (string (let ((symbol (intern-soft default)))
+ (unless (and symbol (ert-test-boundp symbol))
+ (setq default nil))))
+ (symbol (setq default
+ (if (ert-test-boundp default)
+ (symbol-name default)
+ nil)))
+ (ert-test (setq default (ert-test-name default))))
+ (when add-default-to-prompt
+ (setq prompt (if (null default)
+ (format "%s: " prompt)
+ (format "%s (default %s): " prompt default))))
+ (let ((input (completing-read prompt obarray #'ert-test-boundp
+ t nil history default nil)))
+ ;; completing-read returns an empty string if default was nil and
+ ;; the user just hit enter.
+ (let ((sym (intern-soft input)))
+ (if (ert-test-boundp sym)
+ sym
+ (error "Input does not name a test")))))
+
+(defun ert-read-test-name-at-point (prompt)
+ "Read the name of a test and return it as a symbol.
+As a default, use the symbol at point, or the test at point if in
+the ERT results buffer. Prompt with PROMPT, augmented with the
+default (if any)."
+ (ert-read-test-name prompt (ert-test-at-point) nil t))
+
+(defun ert-find-test-other-window (test-name)
+ "Find, in another window, the definition of TEST-NAME."
+ (interactive (list (ert-read-test-name-at-point "Find test definition: ")))
+ (find-function-do-it test-name 'ert-deftest 'switch-to-buffer-other-window))
+
+(defun ert-delete-test (test-name)
+ "Make the test TEST-NAME unbound.
+
+Nothing more than an interactive interface to `ert-make-test-unbound'."
+ (interactive (list (ert-read-test-name-at-point "Delete test")))
+ (ert-make-test-unbound test-name))
+
+(defun ert-delete-all-tests ()
+ "Make all symbols in `obarray' name no test."
+ (interactive)
+ (when (called-interactively-p 'any)
+ (unless (y-or-n-p "Delete all tests? ")
+ (error "Aborted")))
+ ;; We can't use `ert-select-tests' here since that gives us only
+ ;; test objects, and going from them back to the test name symbols
+ ;; can fail if the `ert-test' defstruct has been redefined.
+ (mapc #'ert-make-test-unbound (apropos-internal "" #'ert-test-boundp))
+ t)
+
+
+;;; Display of test progress and results.
+
+;; An entry in the results buffer ewoc. There is one entry per test.
+(defstruct ert--ewoc-entry
+ (test (assert nil))
+ ;; If the result of this test was expected, its ewoc entry is hidden
+ ;; initially.
+ (hidden-p (assert nil))
+ ;; An ewoc entry may be collapsed to hide details such as the error
+ ;; condition.
+ ;;
+ ;; I'm not sure the ability to expand and collapse entries is still
+ ;; a useful feature.
+ (expanded-p t)
+ ;; By default, the ewoc entry presents the error condition with
+ ;; certain limits on how much to print (`print-level',
+ ;; `print-length'). The user can interactively switch to a set of
+ ;; higher limits.
+ (extended-printer-limits-p nil))
+
+;; Variables local to the results buffer.
+
+;; The ewoc.
+(defvar ert--results-ewoc)
+;; The stats object.
+(defvar ert--results-stats)
+;; A string with one character per test. Each character represents
+;; the result of the corresponding test. The string is displayed near
+;; the top of the buffer and serves as a progress bar.
+(defvar ert--results-progress-bar-string)
+;; The position where the progress bar button begins.
+(defvar ert--results-progress-bar-button-begin)
+;; The test result listener that updates the buffer when tests are run.
+(defvar ert--results-listener)
+
+(defun ert-insert-test-name-button (test-name)
+ "Insert a button that links to TEST-NAME."
+ (insert-text-button (format "%S" test-name)
+ :type 'ert--test-name-button
+ 'ert-test-name test-name))
+
+(defun ert--results-format-expected-unexpected (expected unexpected)
+ "Return a string indicating EXPECTED expected results, UNEXPECTED unexpected."
+ (if (zerop unexpected)
+ (format "%s" expected)
+ (format "%s (%s unexpected)" (+ expected unexpected) unexpected)))
+
+(defun ert--results-update-ewoc-hf (ewoc stats)
+ "Update the header and footer of EWOC to show certain information from STATS.
+
+Also sets `ert--results-progress-bar-button-begin'."
+ (let ((run-count (ert-stats-completed stats))
+ (results-buffer (current-buffer))
+ ;; Need to save buffer-local value.
+ (font-lock font-lock-mode))
+ (ewoc-set-hf
+ ewoc
+ ;; header
+ (with-temp-buffer
+ (insert "Selector: ")
+ (ert--insert-human-readable-selector (ert--stats-selector stats))
+ (insert "\n")
+ (insert
+ (format (concat "Passed: %s\n"
+ "Failed: %s\n"
+ "Total: %s/%s\n\n")
+ (ert--results-format-expected-unexpected
+ (ert--stats-passed-expected stats)
+ (ert--stats-passed-unexpected stats))
+ (ert--results-format-expected-unexpected
+ (ert--stats-failed-expected stats)
+ (ert--stats-failed-unexpected stats))
+ run-count
+ (ert-stats-total stats)))
+ (insert
+ (format "Started at: %s\n"
+ (ert--format-time-iso8601 (ert--stats-start-time stats))))
+ ;; FIXME: This is ugly. Need to properly define invariants of
+ ;; the `stats' data structure.
+ (let ((state (cond ((ert--stats-aborted-p stats) 'aborted)
+ ((ert--stats-current-test stats) 'running)
+ ((ert--stats-end-time stats) 'finished)
+ (t 'preparing))))
+ (ecase state
+ (preparing
+ (insert ""))
+ (aborted
+ (cond ((ert--stats-current-test stats)
+ (insert "Aborted during test: ")
+ (ert-insert-test-name-button
+ (ert-test-name (ert--stats-current-test stats))))
+ (t
+ (insert "Aborted."))))
+ (running
+ (assert (ert--stats-current-test stats))
+ (insert "Running test: ")
+ (ert-insert-test-name-button (ert-test-name
+ (ert--stats-current-test stats))))
+ (finished
+ (assert (not (ert--stats-current-test stats)))
+ (insert "Finished.")))
+ (insert "\n")
+ (if (ert--stats-end-time stats)
+ (insert
+ (format "%s%s\n"
+ (if (ert--stats-aborted-p stats)
+ "Aborted at: "
+ "Finished at: ")
+ (ert--format-time-iso8601 (ert--stats-end-time stats))))
+ (insert "\n"))
+ (insert "\n"))
+ (let ((progress-bar-string (with-current-buffer results-buffer
+ ert--results-progress-bar-string)))
+ (let ((progress-bar-button-begin
+ (insert-text-button progress-bar-string
+ :type 'ert--results-progress-bar-button
+ 'face (or (and font-lock
+ (ert-face-for-stats stats))
+ 'button))))
+ ;; The header gets copied verbatim to the results buffer,
+ ;; and all positions remain the same, so
+ ;; `progress-bar-button-begin' will be the right position
+ ;; even in the results buffer.
+ (with-current-buffer results-buffer
+ (set (make-local-variable 'ert--results-progress-bar-button-begin)
+ progress-bar-button-begin))))
+ (insert "\n\n")
+ (buffer-string))
+ ;; footer
+ ;;
+ ;; We actually want an empty footer, but that would trigger a bug
+ ;; in ewoc, sometimes clearing the entire buffer. (It's possible
+ ;; that this bug has been fixed since this has been tested; we
+ ;; should test it again.)
+ "\n")))
+
+
+(defvar ert-test-run-redisplay-interval-secs .1
+ "How many seconds ERT should wait between redisplays while running tests.
+
+While running tests, ERT shows the current progress, and this variable
+determines how frequently the progress display is updated.")
+
+(defun ert--results-update-stats-display (ewoc stats)
+ "Update EWOC and the mode line to show data from STATS."
+ ;; TODO(ohler): investigate using `make-progress-reporter'.
+ (ert--results-update-ewoc-hf ewoc stats)
+ (force-mode-line-update)
+ (redisplay t)
+ (setf (ert--stats-next-redisplay stats)
+ (+ (float-time) ert-test-run-redisplay-interval-secs)))
+
+(defun ert--results-update-stats-display-maybe (ewoc stats)
+ "Call `ert--results-update-stats-display' if not called recently.
+
+EWOC and STATS are arguments for `ert--results-update-stats-display'."
+ (when (>= (float-time) (ert--stats-next-redisplay stats))
+ (ert--results-update-stats-display ewoc stats)))
+
+(defun ert--tests-running-mode-line-indicator ()
+ "Return a string for the mode line that shows the test run progress."
+ (let* ((stats ert--current-run-stats)
+ (tests-total (ert-stats-total stats))
+ (tests-completed (ert-stats-completed stats)))
+ (if (>= tests-completed tests-total)
+ (format " ERT(%s/%s,finished)" tests-completed tests-total)
+ (format " ERT(%s/%s):%s"
+ (1+ tests-completed)
+ tests-total
+ (if (null (ert--stats-current-test stats))
+ "?"
+ (format "%S"
+ (ert-test-name (ert--stats-current-test stats))))))))
+
+(defun ert--make-xrefs-region (begin end)
+ "Attach cross-references to function names between BEGIN and END.
+
+BEGIN and END specify a region in the current buffer."
+ (save-excursion
+ (save-restriction
+ (narrow-to-region begin end)
+ ;; Inhibit optimization in `debugger-make-xrefs' that would
+ ;; sometimes insert unrelated backtrace info into our buffer.
+ (let ((debugger-previous-backtrace nil))
+ (debugger-make-xrefs)))))
+
+(defun ert--string-first-line (s)
+ "Return the first line of S, or S if it contains no newlines.
+
+The return value does not include the line terminator."
+ (substring s 0 (ert--string-position ?\n s)))
+
+(defun ert-face-for-test-result (expectedp)
+ "Return a face that shows whether a test result was expected or unexpected.
+
+If EXPECTEDP is nil, returns the face for unexpected results; if
+non-nil, returns the face for expected results.."
+ (if expectedp 'ert-test-result-expected 'ert-test-result-unexpected))
+
+(defun ert-face-for-stats (stats)
+ "Return a face that represents STATS."
+ (cond ((ert--stats-aborted-p stats) 'nil)
+ ((plusp (ert-stats-completed-unexpected stats))
+ (ert-face-for-test-result nil))
+ ((eql (ert-stats-completed-expected stats) (ert-stats-total stats))
+ (ert-face-for-test-result t))
+ (t 'nil)))
+
+(defun ert--print-test-for-ewoc (entry)
+ "The ewoc print function for ewoc test entries. ENTRY is the entry to print."
+ (let* ((test (ert--ewoc-entry-test entry))
+ (stats ert--results-stats)
+ (result (let ((pos (ert--stats-test-pos stats test)))
+ (assert pos)
+ (aref (ert--stats-test-results stats) pos)))
+ (hiddenp (ert--ewoc-entry-hidden-p entry))
+ (expandedp (ert--ewoc-entry-expanded-p entry))
+ (extended-printer-limits-p (ert--ewoc-entry-extended-printer-limits-p
+ entry)))
+ (cond (hiddenp)
+ (t
+ (let ((expectedp (ert-test-result-expected-p test result)))
+ (insert-text-button (format "%c" (ert-char-for-test-result
+ result expectedp))
+ :type 'ert--results-expand-collapse-button
+ 'face (or (and font-lock-mode
+ (ert-face-for-test-result
+ expectedp))
+ 'button)))
+ (insert " ")
+ (ert-insert-test-name-button (ert-test-name test))
+ (insert "\n")
+ (when (and expandedp (not (eql result 'nil)))
+ (when (ert-test-documentation test)
+ (insert " "
+ (propertize
+ (ert--string-first-line (ert-test-documentation test))
+ 'font-lock-face 'font-lock-doc-face)
+ "\n"))
+ (etypecase result
+ (ert-test-passed
+ (if (ert-test-result-expected-p test result)
+ (insert " passed\n")
+ (insert " passed unexpectedly\n"))
+ (insert ""))
+ (ert-test-result-with-condition
+ (ert--insert-infos result)
+ (let ((print-escape-newlines t)
+ (print-level (if extended-printer-limits-p 12 6))
+ (print-length (if extended-printer-limits-p 100 10)))
+ (insert " ")
+ (let ((begin (point)))
+ (ert--pp-with-indentation-and-newline
+ (ert-test-result-with-condition-condition result))
+ (ert--make-xrefs-region begin (point)))))
+ (ert-test-aborted-with-non-local-exit
+ (insert " aborted\n"))
+ (ert-test-quit
+ (insert " quit\n")))
+ (insert "\n")))))
+ nil)
+
+(defun ert--results-font-lock-function (enabledp)
+ "Redraw the ERT results buffer after font-lock-mode was switched on or off.
+
+ENABLEDP is true if font-lock-mode is switched on, false
+otherwise."
+ (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats)
+ (ewoc-refresh ert--results-ewoc)
+ (font-lock-default-function enabledp))
+
+(defun ert--setup-results-buffer (stats listener buffer-name)
+ "Set up a test results buffer.
+
+STATS is the stats object; LISTENER is the results listener;
+BUFFER-NAME, if non-nil, is the buffer name to use."
+ (unless buffer-name (setq buffer-name "*ert*"))
+ (let ((buffer (get-buffer-create buffer-name)))
+ (with-current-buffer buffer
+ (let ((inhibit-read-only t))
+ (buffer-disable-undo)
+ (erase-buffer)
+ (ert-results-mode)
+ ;; Erase buffer again in case switching out of the previous
+ ;; mode inserted anything. (This happens e.g. when switching
+ ;; from ert-results-mode to ert-results-mode when
+ ;; font-lock-mode turns itself off in change-major-mode-hook.)
+ (erase-buffer)
+ (set (make-local-variable 'font-lock-function)
+ 'ert--results-font-lock-function)
+ (let ((ewoc (ewoc-create 'ert--print-test-for-ewoc nil nil t)))
+ (set (make-local-variable 'ert--results-ewoc) ewoc)
+ (set (make-local-variable 'ert--results-stats) stats)
+ (set (make-local-variable 'ert--results-progress-bar-string)
+ (make-string (ert-stats-total stats)
+ (ert-char-for-test-result nil t)))
+ (set (make-local-variable 'ert--results-listener) listener)
+ (loop for test across (ert--stats-tests stats) do
+ (ewoc-enter-last ewoc
+ (make-ert--ewoc-entry :test test :hidden-p t)))
+ (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats)
+ (goto-char (1- (point-max)))
+ buffer)))))
+
+
+(defvar ert--selector-history nil
+ "List of recent test selectors read from terminal.")
+
+;; Should OUTPUT-BUFFER-NAME and MESSAGE-FN really be arguments here?
+;; They are needed only for our automated self-tests at the moment.
+;; Or should there be some other mechanism?
+;;;###autoload
+(defun ert-run-tests-interactively (selector
+ &optional output-buffer-name message-fn)
+ "Run the tests specified by SELECTOR and display the results in a buffer.
+
+SELECTOR works as described in `ert-select-tests'.
+OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they
+are used for automated self-tests and specify which buffer to use
+and how to display message."
+ (interactive
+ (list (let ((default (if ert--selector-history
+ ;; Can't use `first' here as this form is
+ ;; not compiled, and `first' is not
+ ;; defined without cl.
+ (car ert--selector-history)
+ "t")))
+ (read-from-minibuffer (if (null default)
+ "Run tests: "
+ (format "Run tests (default %s): " default))
+ nil nil t 'ert--selector-history
+ default nil))
+ nil))
+ (unless message-fn (setq message-fn 'message))
+ (lexical-let ((output-buffer-name output-buffer-name)
+ buffer
+ listener
+ (message-fn message-fn))
+ (setq listener
+ (lambda (event-type &rest event-args)
+ (ecase event-type
+ (run-started
+ (destructuring-bind (stats) event-args
+ (setq buffer (ert--setup-results-buffer stats
+ listener
+ output-buffer-name))
+ (pop-to-buffer buffer)))
+ (run-ended
+ (destructuring-bind (stats abortedp) event-args
+ (funcall message-fn
+ "%sRan %s tests, %s results were as expected%s"
+ (if (not abortedp)
+ ""
+ "Aborted: ")
+ (ert-stats-total stats)
+ (ert-stats-completed-expected stats)
+ (let ((unexpected
+ (ert-stats-completed-unexpected stats)))
+ (if (zerop unexpected)
+ ""
+ (format ", %s unexpected" unexpected))))
+ (ert--results-update-stats-display (with-current-buffer buffer
+ ert--results-ewoc)
+ stats)))
+ (test-started
+ (destructuring-bind (stats test) event-args
+ (with-current-buffer buffer
+ (let* ((ewoc ert--results-ewoc)
+ (pos (ert--stats-test-pos stats test))
+ (node (ewoc-nth ewoc pos)))
+ (assert node)
+ (setf (ert--ewoc-entry-test (ewoc-data node)) test)
+ (aset ert--results-progress-bar-string pos
+ (ert-char-for-test-result nil t))
+ (ert--results-update-stats-display-maybe ewoc stats)
+ (ewoc-invalidate ewoc node)))))
+ (test-ended
+ (destructuring-bind (stats test result) event-args
+ (with-current-buffer buffer
+ (let* ((ewoc ert--results-ewoc)
+ (pos (ert--stats-test-pos stats test))
+ (node (ewoc-nth ewoc pos)))
+ (when (ert--ewoc-entry-hidden-p (ewoc-data node))
+ (setf (ert--ewoc-entry-hidden-p (ewoc-data node))
+ (ert-test-result-expected-p test result)))
+ (aset ert--results-progress-bar-string pos
+ (ert-char-for-test-result result
+ (ert-test-result-expected-p
+ test result)))
+ (ert--results-update-stats-display-maybe ewoc stats)
+ (ewoc-invalidate ewoc node))))))))
+ (ert-run-tests
+ selector
+ listener)))
+;;;###autoload
+(defalias 'ert 'ert-run-tests-interactively)
+
+
+;;; Simple view mode for auxiliary information like stack traces or
+;;; messages. Mainly binds "q" for quit.
+
+(define-derived-mode ert-simple-view-mode special-mode "ERT-View"
+ "Major mode for viewing auxiliary information in ERT.")
+
+;;; Commands and button actions for the results buffer.
+
+(define-derived-mode ert-results-mode special-mode "ERT-Results"
+ "Major mode for viewing results of ERT test runs.")
+
+(loop for (key binding) in
+ '(;; Stuff that's not in the menu.
+ ("\t" forward-button)
+ ([backtab] backward-button)
+ ("j" ert-results-jump-between-summary-and-result)
+ ("L" ert-results-toggle-printer-limits-for-test-at-point)
+ ("n" ert-results-next-test)
+ ("p" ert-results-previous-test)
+ ;; Stuff that is in the menu.
+ ("R" ert-results-rerun-all-tests)
+ ("r" ert-results-rerun-test-at-point)
+ ("d" ert-results-rerun-test-at-point-debugging-errors)
+ ("." ert-results-find-test-at-point-other-window)
+ ("b" ert-results-pop-to-backtrace-for-test-at-point)
+ ("m" ert-results-pop-to-messages-for-test-at-point)
+ ("l" ert-results-pop-to-should-forms-for-test-at-point)
+ ("h" ert-results-describe-test-at-point)
+ ("D" ert-delete-test)
+ ("T" ert-results-pop-to-timings)
+ )
+ do
+ (define-key ert-results-mode-map key binding))
+
+(easy-menu-define ert-results-mode-menu ert-results-mode-map
+ "Menu for `ert-results-mode'."
+ '("ERT Results"
+ ["Re-run all tests" ert-results-rerun-all-tests]
+ "--"
+ ["Re-run test" ert-results-rerun-test-at-point]
+ ["Debug test" ert-results-rerun-test-at-point-debugging-errors]
+ ["Show test definition" ert-results-find-test-at-point-other-window]
+ "--"
+ ["Show backtrace" ert-results-pop-to-backtrace-for-test-at-point]
+ ["Show messages" ert-results-pop-to-messages-for-test-at-point]
+ ["Show `should' forms" ert-results-pop-to-should-forms-for-test-at-point]
+ ["Describe test" ert-results-describe-test-at-point]
+ "--"
+ ["Delete test" ert-delete-test]
+ "--"
+ ["Show execution time of each test" ert-results-pop-to-timings]
+ ))
+
+(define-button-type 'ert--results-progress-bar-button
+ 'action #'ert--results-progress-bar-button-action
+ 'help-echo "mouse-2, RET: Reveal test result")
+
+(define-button-type 'ert--test-name-button
+ 'action #'ert--test-name-button-action
+ 'help-echo "mouse-2, RET: Find test definition")
+
+(define-button-type 'ert--results-expand-collapse-button
+ 'action #'ert--results-expand-collapse-button-action
+ 'help-echo "mouse-2, RET: Expand/collapse test result")
+
+(defun ert--results-test-node-or-null-at-point ()
+ "If point is on a valid ewoc node, return it; return nil otherwise.
+
+To be used in the ERT results buffer."
+ (let* ((ewoc ert--results-ewoc)
+ (node (ewoc-locate ewoc)))
+ ;; `ewoc-locate' will return an arbitrary node when point is on
+ ;; header or footer, or when all nodes are invisible. So we need
+ ;; to validate its return value here.
+ ;;
+ ;; Update: I'm seeing nil being returned in some cases now,
+ ;; perhaps this has been changed?
+ (if (and node
+ (>= (point) (ewoc-location node))
+ (not (ert--ewoc-entry-hidden-p (ewoc-data node))))
+ node
+ nil)))
+
+(defun ert--results-test-node-at-point ()
+ "If point is on a valid ewoc node, return it; signal an error otherwise.
+
+To be used in the ERT results buffer."
+ (or (ert--results-test-node-or-null-at-point)
+ (error "No test at point")))
+
+(defun ert-results-next-test ()
+ "Move point to the next test.
+
+To be used in the ERT results buffer."
+ (interactive)
+ (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-next
+ "No tests below"))
+
+(defun ert-results-previous-test ()
+ "Move point to the previous test.
+
+To be used in the ERT results buffer."
+ (interactive)
+ (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-prev
+ "No tests above"))
+
+(defun ert--results-move (node ewoc-fn error-message)
+ "Move point from NODE to the previous or next node.
+
+EWOC-FN specifies the direction and should be either `ewoc-prev'
+or `ewoc-next'. If there are no more nodes in that direction, an
+error is signalled with the message ERROR-MESSAGE."
+ (loop
+ (setq node (funcall ewoc-fn ert--results-ewoc node))
+ (when (null node)
+ (error "%s" error-message))
+ (unless (ert--ewoc-entry-hidden-p (ewoc-data node))
+ (goto-char (ewoc-location node))
+ (return))))
+
+(defun ert--results-expand-collapse-button-action (button)
+ "Expand or collapse the test node BUTTON belongs to."
+ (let* ((ewoc ert--results-ewoc)
+ (node (save-excursion
+ (goto-char (ert--button-action-position))
+ (ert--results-test-node-at-point)))
+ (entry (ewoc-data node)))
+ (setf (ert--ewoc-entry-expanded-p entry)
+ (not (ert--ewoc-entry-expanded-p entry)))
+ (ewoc-invalidate ewoc node)))
+
+(defun ert-results-find-test-at-point-other-window ()
+ "Find the definition of the test at point in another window.
+
+To be used in the ERT results buffer."
+ (interactive)
+ (let ((name (ert-test-at-point)))
+ (unless name
+ (error "No test at point"))
+ (ert-find-test-other-window name)))
+
+(defun ert--test-name-button-action (button)
+ "Find the definition of the test BUTTON belongs to, in another window."
+ (let ((name (button-get button 'ert-test-name)))
+ (ert-find-test-other-window name)))
+
+(defun ert--ewoc-position (ewoc node)
+ ;; checkdoc-order: nil
+ "Return the position of NODE in EWOC, or nil if NODE is not in EWOC."
+ (loop for i from 0
+ for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here)
+ do (when (eql node node-here)
+ (return i))
+ finally (return nil)))
+
+(defun ert-results-jump-between-summary-and-result ()
+ "Jump back and forth between the test run summary and individual test results.
+
+From an ewoc node, jumps to the character that represents the
+same test in the progress bar, and vice versa.
+
+To be used in the ERT results buffer."
+ ;; Maybe this command isn't actually needed much, but if it is, it
+ ;; seems like an indication that the UI design is not optimal. If
+ ;; jumping back and forth between a summary at the top of the buffer
+ ;; and the error log in the remainder of the buffer is useful, then
+ ;; the summary apparently needs to be easily accessible from the
+ ;; error log, and perhaps it would be better to have it in a
+ ;; separate buffer to keep it visible.
+ (interactive)
+ (let ((ewoc ert--results-ewoc)
+ (progress-bar-begin ert--results-progress-bar-button-begin))
+ (cond ((ert--results-test-node-or-null-at-point)
+ (let* ((node (ert--results-test-node-at-point))
+ (pos (ert--ewoc-position ewoc node)))
+ (goto-char (+ progress-bar-begin pos))))
+ ((and (<= progress-bar-begin (point))
+ (< (point) (button-end (button-at progress-bar-begin))))
+ (let* ((node (ewoc-nth ewoc (- (point) progress-bar-begin)))
+ (entry (ewoc-data node)))
+ (when (ert--ewoc-entry-hidden-p entry)
+ (setf (ert--ewoc-entry-hidden-p entry) nil)
+ (ewoc-invalidate ewoc node))
+ (ewoc-goto-node ewoc node)))
+ (t
+ (goto-char progress-bar-begin)))))
+
+(defun ert-test-at-point ()
+ "Return the name of the test at point as a symbol, or nil if none."
+ (or (and (eql major-mode 'ert-results-mode)
+ (let ((test (ert--results-test-at-point-no-redefinition)))
+ (and test (ert-test-name test))))
+ (let* ((thing (thing-at-point 'symbol))
+ (sym (intern-soft thing)))
+ (and (ert-test-boundp sym)
+ sym))))
+
+(defun ert--results-test-at-point-no-redefinition ()
+ "Return the test at point, or nil.
+
+To be used in the ERT results buffer."
+ (assert (eql major-mode 'ert-results-mode))
+ (if (ert--results-test-node-or-null-at-point)
+ (let* ((node (ert--results-test-node-at-point))
+ (test (ert--ewoc-entry-test (ewoc-data node))))
+ test)
+ (let ((progress-bar-begin ert--results-progress-bar-button-begin))
+ (when (and (<= progress-bar-begin (point))
+ (< (point) (button-end (button-at progress-bar-begin))))
+ (let* ((test-index (- (point) progress-bar-begin))
+ (test (aref (ert--stats-tests ert--results-stats)
+ test-index)))
+ test)))))
+
+(defun ert--results-test-at-point-allow-redefinition ()
+ "Look up the test at point, and check whether it has been redefined.
+
+To be used in the ERT results buffer.
+
+Returns a list of two elements: the test (or nil) and a symbol
+specifying whether the test has been redefined.
+
+If a new test has been defined with the same name as the test at
+point, replaces the test at point with the new test, and returns
+the new test and the symbol `redefined'.
+
+If the test has been deleted, returns the old test and the symbol
+`deleted'.
+
+If the test is still current, returns the test and the symbol nil.
+
+If there is no test at point, returns a list with two nils."
+ (let ((test (ert--results-test-at-point-no-redefinition)))
+ (cond ((null test)
+ `(nil nil))
+ ((null (ert-test-name test))
+ `(,test nil))
+ (t
+ (let* ((name (ert-test-name test))
+ (new-test (and (ert-test-boundp name)
+ (ert-get-test name))))
+ (cond ((eql test new-test)
+ `(,test nil))
+ ((null new-test)
+ `(,test deleted))
+ (t
+ (ert--results-update-after-test-redefinition
+ (ert--stats-test-pos ert--results-stats test)
+ new-test)
+ `(,new-test redefined))))))))
+
+(defun ert--results-update-after-test-redefinition (pos new-test)
+ "Update results buffer after the test at pos POS has been redefined.
+
+Also updates the stats object. NEW-TEST is the new test
+definition."
+ (let* ((stats ert--results-stats)
+ (ewoc ert--results-ewoc)
+ (node (ewoc-nth ewoc pos))
+ (entry (ewoc-data node)))
+ (ert--stats-set-test-and-result stats pos new-test nil)
+ (setf (ert--ewoc-entry-test entry) new-test
+ (aref ert--results-progress-bar-string pos) (ert-char-for-test-result
+ nil t))
+ (ewoc-invalidate ewoc node))
+ nil)
+
+(defun ert--button-action-position ()
+ "The buffer position where the last button action was triggered."
+ (cond ((integerp last-command-event)
+ (point))
+ ((eventp last-command-event)
+ (posn-point (event-start last-command-event)))
+ (t (assert nil))))
+
+(defun ert--results-progress-bar-button-action (button)
+ "Jump to details for the test represented by the character clicked in BUTTON."
+ (goto-char (ert--button-action-position))
+ (ert-results-jump-between-summary-and-result))
+
+(defun ert-results-rerun-all-tests ()
+ "Re-run all tests, using the same selector.
+
+To be used in the ERT results buffer."
+ (interactive)
+ (assert (eql major-mode 'ert-results-mode))
+ (let ((selector (ert--stats-selector ert--results-stats)))
+ (ert-run-tests-interactively selector (buffer-name))))
+
+(defun ert-results-rerun-test-at-point ()
+ "Re-run the test at point.
+
+To be used in the ERT results buffer."
+ (interactive)
+ (destructuring-bind (test redefinition-state)
+ (ert--results-test-at-point-allow-redefinition)
+ (when (null test)
+ (error "No test at point"))
+ (let* ((stats ert--results-stats)
+ (progress-message (format "Running %stest %S"
+ (ecase redefinition-state
+ ((nil) "")
+ (redefined "new definition of ")
+ (deleted "deleted "))
+ (ert-test-name test))))
+ ;; Need to save and restore point manually here: When point is on
+ ;; the first visible ewoc entry while the header is updated, point
+ ;; moves to the top of the buffer. This is undesirable, and a
+ ;; simple `save-excursion' doesn't prevent it.
+ (let ((point (point)))
+ (unwind-protect
+ (unwind-protect
+ (progn
+ (message "%s..." progress-message)
+ (ert-run-or-rerun-test stats test
+ ert--results-listener))
+ (ert--results-update-stats-display ert--results-ewoc stats)
+ (message "%s...%s"
+ progress-message
+ (let ((result (ert-test-most-recent-result test)))
+ (ert-string-for-test-result
+ result (ert-test-result-expected-p test result)))))
+ (goto-char point))))))
+
+(defun ert-results-rerun-test-at-point-debugging-errors ()
+ "Re-run the test at point with `ert-debug-on-error' bound to t.
+
+To be used in the ERT results buffer."
+ (interactive)
+ (let ((ert-debug-on-error t))
+ (ert-results-rerun-test-at-point)))
+
+(defun ert-results-pop-to-backtrace-for-test-at-point ()
+ "Display the backtrace for the test at point.
+
+To be used in the ERT results buffer."
+ (interactive)
+ (let* ((test (ert--results-test-at-point-no-redefinition))
+ (stats ert--results-stats)
+ (pos (ert--stats-test-pos stats test))
+ (result (aref (ert--stats-test-results stats) pos)))
+ (etypecase result
+ (ert-test-passed (error "Test passed, no backtrace available"))
+ (ert-test-result-with-condition
+ (let ((backtrace (ert-test-result-with-condition-backtrace result))
+ (buffer (get-buffer-create "*ERT Backtrace*")))
+ (pop-to-buffer buffer)
+ (let ((inhibit-read-only t))
+ (buffer-disable-undo)
+ (erase-buffer)
+ (ert-simple-view-mode)
+ ;; Use unibyte because `debugger-setup-buffer' also does so.
+ (set-buffer-multibyte nil)
+ (setq truncate-lines t)
+ (ert--print-backtrace backtrace)
+ (debugger-make-xrefs)
+ (goto-char (point-min))
+ (insert "Backtrace for test `")
+ (ert-insert-test-name-button (ert-test-name test))
+ (insert "':\n")))))))
+
+(defun ert-results-pop-to-messages-for-test-at-point ()
+ "Display the part of the *Messages* buffer generated during the test at point.
+
+To be used in the ERT results buffer."
+ (interactive)
+ (let* ((test (ert--results-test-at-point-no-redefinition))
+ (stats ert--results-stats)
+ (pos (ert--stats-test-pos stats test))
+ (result (aref (ert--stats-test-results stats) pos)))
+ (let ((buffer (get-buffer-create "*ERT Messages*")))
+ (pop-to-buffer buffer)
+ (let ((inhibit-read-only t))
+ (buffer-disable-undo)
+ (erase-buffer)
+ (ert-simple-view-mode)
+ (insert (ert-test-result-messages result))
+ (goto-char (point-min))
+ (insert "Messages for test `")
+ (ert-insert-test-name-button (ert-test-name test))
+ (insert "':\n")))))
+
+(defun ert-results-pop-to-should-forms-for-test-at-point ()
+ "Display the list of `should' forms executed during the test at point.
+
+To be used in the ERT results buffer."
+ (interactive)
+ (let* ((test (ert--results-test-at-point-no-redefinition))
+ (stats ert--results-stats)
+ (pos (ert--stats-test-pos stats test))
+ (result (aref (ert--stats-test-results stats) pos)))
+ (let ((buffer (get-buffer-create "*ERT list of should forms*")))
+ (pop-to-buffer buffer)
+ (let ((inhibit-read-only t))
+ (buffer-disable-undo)
+ (erase-buffer)
+ (ert-simple-view-mode)
+ (if (null (ert-test-result-should-forms result))
+ (insert "\n(No should forms during this test.)\n")
+ (loop for form-description in (ert-test-result-should-forms result)
+ for i from 1 do
+ (insert "\n")
+ (insert (format "%s: " i))
+ (let ((begin (point)))
+ (ert--pp-with-indentation-and-newline form-description)
+ (ert--make-xrefs-region begin (point)))))
+ (goto-char (point-min))
+ (insert "`should' forms executed during test `")
+ (ert-insert-test-name-button (ert-test-name test))
+ (insert "':\n")
+ (insert "\n")
+ (insert (concat "(Values are shallow copies and may have "
+ "looked different during the test if they\n"
+ "have been modified destructively.)\n"))
+ (forward-line 1)))))
+
+(defun ert-results-toggle-printer-limits-for-test-at-point ()
+ "Toggle how much of the condition to print for the test at point.
+
+To be used in the ERT results buffer."
+ (interactive)
+ (let* ((ewoc ert--results-ewoc)
+ (node (ert--results-test-node-at-point))
+ (entry (ewoc-data node)))
+ (setf (ert--ewoc-entry-extended-printer-limits-p entry)
+ (not (ert--ewoc-entry-extended-printer-limits-p entry)))
+ (ewoc-invalidate ewoc node)))
+
+(defun ert-results-pop-to-timings ()
+ "Display test timings for the last run.
+
+To be used in the ERT results buffer."
+ (interactive)
+ (let* ((stats ert--results-stats)
+ (start-times (ert--stats-test-start-times stats))
+ (end-times (ert--stats-test-end-times stats))
+ (buffer (get-buffer-create "*ERT timings*"))
+ (data (loop for test across (ert--stats-tests stats)
+ for start-time across (ert--stats-test-start-times stats)
+ for end-time across (ert--stats-test-end-times stats)
+ collect (list test
+ (float-time (subtract-time end-time
+ start-time))))))
+ (setq data (sort data (lambda (a b)
+ (> (second a) (second b)))))
+ (pop-to-buffer buffer)
+ (let ((inhibit-read-only t))
+ (buffer-disable-undo)
+ (erase-buffer)
+ (ert-simple-view-mode)
+ (if (null data)
+ (insert "(No data)\n")
+ (insert (format "%-3s %8s %8s\n" "" "time" "cumul"))
+ (loop for (test time) in data
+ for cumul-time = time then (+ cumul-time time)
+ for i from 1 do
+ (let ((begin (point)))
+ (insert (format "%3s: %8.3f %8.3f " i time cumul-time))
+ (ert-insert-test-name-button (ert-test-name test))
+ (insert "\n"))))
+ (goto-char (point-min))
+ (insert "Tests by run time (seconds):\n\n")
+ (forward-line 1))))
+
+;;;###autoload
+(defun ert-describe-test (test-or-test-name)
+ "Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test)."
+ (interactive (list (ert-read-test-name-at-point "Describe test")))
+ (when (< emacs-major-version 24)
+ (error "Requires Emacs 24"))
+ (let (test-name
+ test-definition)
+ (etypecase test-or-test-name
+ (symbol (setq test-name test-or-test-name
+ test-definition (ert-get-test test-or-test-name)))
+ (ert-test (setq test-name (ert-test-name test-or-test-name)
+ test-definition test-or-test-name)))
+ (help-setup-xref (list #'ert-describe-test test-or-test-name)
+ (called-interactively-p 'interactive))
+ (save-excursion
+ (with-help-window (help-buffer)
+ (with-current-buffer (help-buffer)
+ (insert (if test-name (format "%S" test-name) "<anonymous test>"))
+ (insert " is a test")
+ (let ((file-name (and test-name
+ (symbol-file test-name 'ert-deftest))))
+ (when file-name
+ (insert " defined in `" (file-name-nondirectory file-name) "'")
+ (save-excursion
+ (re-search-backward "`\\([^`']+\\)'" nil t)
+ (help-xref-button 1 'help-function-def test-name file-name)))
+ (insert ".")
+ (fill-region-as-paragraph (point-min) (point))
+ (insert "\n\n")
+ (unless (and (ert-test-boundp test-name)
+ (eql (ert-get-test test-name) test-definition))
+ (let ((begin (point)))
+ (insert "Note: This test has been redefined or deleted, "
+ "this documentation refers to an old definition.")
+ (fill-region-as-paragraph begin (point)))
+ (insert "\n\n"))
+ (insert (or (ert-test-documentation test-definition)
+ "It is not documented.")
+ "\n")))))))
+
+(defun ert-results-describe-test-at-point ()
+ "Display the documentation of the test at point.
+
+To be used in the ERT results buffer."
+ (interactive)
+ (ert-describe-test (ert--results-test-at-point-no-redefinition)))
+
+
+;;; Actions on load/unload.
+
+(add-to-list 'find-function-regexp-alist '(ert-deftest . ert--find-test-regexp))
+(add-to-list 'minor-mode-alist '(ert--current-run-stats
+ (:eval
+ (ert--tests-running-mode-line-indicator))))
+(add-to-list 'emacs-lisp-mode-hook 'ert--activate-font-lock-keywords)
+
+(defun ert--unload-function ()
+ "Unload function to undo the side-effects of loading ert.el."
+ (ert--remove-from-list 'find-function-regexp-alist 'ert-deftest :key #'car)
+ (ert--remove-from-list 'minor-mode-alist 'ert--current-run-stats :key #'car)
+ (ert--remove-from-list 'emacs-lisp-mode-hook
+ 'ert--activate-font-lock-keywords)
+ nil)
+
+(defvar ert-unload-hook '())
+(add-hook 'ert-unload-hook 'ert--unload-function)
+
+
+(provide 'ert)
+
+;;; ert.el ends here
diff --git a/lisp/emacs-lisp/ewoc.el b/lisp/emacs-lisp/ewoc.el
index 9928f8f75c0..a71f3c7244c 100644
--- a/lisp/emacs-lisp/ewoc.el
+++ b/lisp/emacs-lisp/ewoc.el
@@ -1,7 +1,6 @@
;;; ewoc.el --- utility to maintain a view of a list of objects in a buffer
-;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1991-2011 Free Software Foundation, Inc.
;; Author: Per Cederqvist <ceder@lysator.liu.se>
;; Inge Wallin <inge@lysator.liu.se>
@@ -496,6 +495,8 @@ Return the node (or nil if we just passed the last node)."
;; Never step below the first element.
;; (unless (ewoc--filter-hf-nodes ewoc node)
;; (setq node (ewoc--node-nth dll -2)))
+ (unless node
+ (error "No next"))
(ewoc-goto-node ewoc node)))
(defun ewoc-goto-node (ewoc node)
@@ -578,5 +579,4 @@ Return nil if the buffer has been deleted."
;; eval: (put 'ewoc--set-buffer-bind-dll-let* 'lisp-indent-hook 2)
;; End:
-;; arch-tag: d78915b9-9a07-44bf-aac6-04a1fc1bd6d4
;;; ewoc.el ends here
diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el
index 94cb0bfe2d2..9c4a3e9832c 100644
--- a/lisp/emacs-lisp/find-func.el
+++ b/lisp/emacs-lisp/find-func.el
@@ -1,7 +1,6 @@
;;; find-func.el --- find the definition of the Emacs Lisp function near point
-;; Copyright (C) 1997, 1999, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 1999, 2001-2011 Free Software Foundation, Inc.
;; Author: Jens Petersen <petersen@kurims.kyoto-u.ac.jp>
;; Maintainer: petersen@kurims.kyoto-u.ac.jp
@@ -213,6 +212,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 +227,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)))))
@@ -565,5 +562,4 @@ Set mark before moving, if the buffer already existed."
(provide 'find-func)
-;; arch-tag: 43ecd81c-74dc-4d9a-8f63-a61e55670d64
;;; find-func.el ends here
diff --git a/lisp/emacs-lisp/find-gc.el b/lisp/emacs-lisp/find-gc.el
index 7f4d8918a35..1de38625243 100644
--- a/lisp/emacs-lisp/find-gc.el
+++ b/lisp/emacs-lisp/find-gc.el
@@ -1,7 +1,6 @@
;;; find-gc.el --- detect functions that call the garbage collector
-;; Copyright (C) 1992, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
@@ -56,11 +55,11 @@ Each entry has the form (FUNCTION . FUNCTIONS-IT-CALLS).")
"term.c" "cm.c" "emacs.c" "keyboard.c" "macros.c"
"keymap.c" "sysdep.c" "buffer.c" "filelock.c"
"insdel.c" "marker.c" "minibuf.c" "fileio.c"
- "dired.c" "filemode.c" "cmds.c" "casefiddle.c"
+ "dired.c" "cmds.c" "casefiddle.c"
"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"))
@@ -159,5 +158,4 @@ Also store it in `find-gc-unsafe'."
(provide 'find-gc)
-;; arch-tag: 4a26a538-a008-40d9-a1ef-23bb6dbecef4
;;; find-gc.el ends here
diff --git a/lisp/emacs-lisp/float-sup.el b/lisp/emacs-lisp/float-sup.el
index f7e540237be..7e40fdad352 100644
--- a/lisp/emacs-lisp/float-sup.el
+++ b/lisp/emacs-lisp/float-sup.el
@@ -1,10 +1,10 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1987, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -25,36 +25,33 @@
;;; 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.")
+(progn
+ ;; Simulate a defconst that doesn't declare the variable dynamically bound.
+ (setq-default pi float-pi)
+ (put 'pi 'variable-documentation
+ "Obsolete since Emacs-23.3. Use `float-pi' instead.")
+ (put 'pi 'risky-local-variable t)
+ (push 'pi current-load-list))
(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 6b28e931603..770fe01f91c 100644
--- a/lisp/emacs-lisp/generic.el
+++ b/lisp/emacs-lisp/generic.el
@@ -1,11 +1,11 @@
;;; generic.el --- defining simple major modes with comment and font-lock
;;
-;; Copyright (C) 1997, 1999, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 1999, 2001-2011 Free Software Foundation, Inc.
;;
;; 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.
@@ -315,5 +315,4 @@ regular expression that can be used as an element of
(provide 'generic)
-;; arch-tag: 239c1fc4-1303-48d9-9ac0-657d655669ea
;;; generic.el ends here
diff --git a/lisp/emacs-lisp/gulp.el b/lisp/emacs-lisp/gulp.el
index fe8c6e7fae6..eca5470fd69 100644
--- a/lisp/emacs-lisp/gulp.el
+++ b/lisp/emacs-lisp/gulp.el
@@ -1,7 +1,6 @@
;;; gulp.el --- ask for updates for Lisp packages
-;; Copyright (C) 1996, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 2001-2011 Free Software Foundation, Inc.
;; Author: Sam Shteingold <shteingd@math.ucla.edu>
;; Maintainer: FSF
@@ -175,5 +174,4 @@ That is a list of elements, each of the form (MAINTAINER PACKAGES...)."
(provide 'gulp)
-;; arch-tag: 42750a11-460a-4efc-829f-342d075530e5
;;; gulp.el ends here
diff --git a/lisp/emacs-lisp/helper.el b/lisp/emacs-lisp/helper.el
index 5935d544974..113f5849364 100644
--- a/lisp/emacs-lisp/helper.el
+++ b/lisp/emacs-lisp/helper.el
@@ -1,11 +1,11 @@
;;; helper.el --- utility help package supporting help in electric modes
-;; Copyright (C) 1985, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 2001-2011 Free Software Foundation, Inc.
;; Author: K. Shane Hartman
;; Maintainer: FSF
;; Keywords: help
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -155,5 +155,4 @@
(provide 'helper)
-;; arch-tag: a0984577-d3e9-4124-ae0d-c46fe740f6a9
;;; helper.el ends here
diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el
index 9e1e26778b7..4d0cacf4ee1 100644
--- a/lisp/emacs-lisp/lisp-mnt.el
+++ b/lisp/emacs-lisp/lisp-mnt.el
@@ -1,7 +1,6 @@
;;; lisp-mnt.el --- utility functions for Emacs Lisp maintainers
-;; Copyright (C) 1992, 1994, 1997, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 1994, 1997, 2000-2011 Free Software Foundation, Inc.
;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
;; Maintainer: FSF
@@ -298,6 +297,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 +311,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 +455,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)
@@ -616,5 +615,4 @@ Prompts for bug subject TOPIC. Leaves you in a mail buffer."
(provide 'lisp-mnt)
-;; arch-tag: fa3c5ab4-a37b-4e46-b7cf-b6d78b90e69e
;;; lisp-mnt.el ends here
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el
index 8626c34f77c..04299aec099 100644
--- a/lisp/emacs-lisp/lisp-mode.el
+++ b/lisp/emacs-lisp/lisp-mode.el
@@ -1,10 +1,10 @@
;;; lisp-mode.el --- Lisp mode, and its idiosyncratic commands
-;; Copyright (C) 1985, 1986, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1986, 1999-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: lisp, languages
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -85,7 +85,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 +221,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 +406,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 +426,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 +461,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 +473,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)))
@@ -711,7 +699,9 @@ If CHAR is not a character, return nil."
"Evaluate sexp before point; print value in minibuffer.
With argument, print output into current buffer."
(let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t)))
- (eval-last-sexp-print-value (eval (preceding-sexp)))))
+ ;; Setup the lexical environment if lexical-binding is enabled.
+ (eval-last-sexp-print-value
+ (eval (eval-sexp-add-defvars (preceding-sexp)) lexical-binding))))
(defun eval-last-sexp-print-value (value)
@@ -739,6 +729,23 @@ With argument, print output into current buffer."
(defvar eval-last-sexp-fake-value (make-symbol "t"))
+(defun eval-sexp-add-defvars (exp &optional pos)
+ "Prepend EXP with all the `defvar's that precede it in the buffer.
+POS specifies the starting position where EXP was found and defaults to point."
+ (if (not lexical-binding)
+ exp
+ (save-excursion
+ (unless pos (setq pos (point)))
+ (let ((vars ()))
+ (goto-char (point-min))
+ (while (re-search-forward
+ "^(def\\(?:var\\|const\\|custom\\)[ \t\n]+\\([^; '()\n\t]+\\)"
+ pos t)
+ (let ((var (intern (match-string 1))))
+ (unless (special-variable-p var)
+ (push var vars))))
+ `(progn ,@(mapcar (lambda (v) `(defvar ,v)) vars) ,exp)))))
+
(defun eval-last-sexp (eval-last-sexp-arg-internal)
"Evaluate sexp before point; print value in minibuffer.
Interactively, with prefix argument, print output into current buffer.
@@ -775,16 +782,18 @@ Reinitialize the face according to the `defface' specification."
;; `defcustom' is now macroexpanded to
;; `custom-declare-variable' with a quoted value arg.
((and (eq (car form) 'custom-declare-variable)
- (default-boundp (eval (nth 1 form))))
+ (default-boundp (eval (nth 1 form) lexical-binding)))
;; Force variable to be bound.
- (set-default (eval (nth 1 form)) (eval (nth 1 (nth 2 form))))
+ (set-default (eval (nth 1 form) lexical-binding)
+ (eval (nth 1 (nth 2 form)) lexical-binding))
form)
;; `defface' is macroexpanded to `custom-declare-face'.
((eq (car form) 'custom-declare-face)
;; Reset the face.
(setq face-new-frame-defaults
- (assq-delete-all (eval (nth 1 form)) face-new-frame-defaults))
- (put (eval (nth 1 form)) 'face-defface-spec nil)
+ (assq-delete-all (eval (nth 1 form) lexical-binding)
+ face-new-frame-defaults))
+ (put (eval (nth 1 form) lexical-binding) 'face-defface-spec nil)
;; Setting `customized-face' to the new spec after calling
;; the form, but preserving the old saved spec in `saved-face',
;; imitates the situation when the new face spec is set
@@ -795,10 +804,11 @@ Reinitialize the face according to the `defface' specification."
;; `defface' change the spec, regardless of a saved spec.
(prog1 `(prog1 ,form
(put ,(nth 1 form) 'saved-face
- ',(get (eval (nth 1 form)) 'saved-face))
+ ',(get (eval (nth 1 form) lexical-binding)
+ 'saved-face))
(put ,(nth 1 form) 'customized-face
,(nth 2 form)))
- (put (eval (nth 1 form)) 'saved-face nil)))
+ (put (eval (nth 1 form) lexical-binding) 'saved-face nil)))
((eq (car form) 'progn)
(cons 'progn (mapcar 'eval-defun-1 (cdr form))))
(t form)))
@@ -834,7 +844,7 @@ Return the result of evaluation."
(end-of-defun)
(beginning-of-defun)
(setq beg (point))
- (setq form (read (current-buffer)))
+ (setq form (eval-sexp-add-defvars (read (current-buffer))))
(setq end (point)))
;; Alter the form if necessary.
(setq form (eval-defun-1 (macroexpand form)))
@@ -1078,7 +1088,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))))
@@ -1217,32 +1227,17 @@ This function also returns nil meaning don't specify the indentation."
(put 'prog1 'lisp-indent-function 1)
(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 +1449,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 1f1fa16108f..ef0c49b8616 100644
--- a/lisp/emacs-lisp/lisp.el
+++ b/lisp/emacs-lisp/lisp.el
@@ -1,10 +1,10 @@
;;; lisp.el --- Lisp editing commands for Emacs
-;; Copyright (C) 1985, 1986, 1994, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1986, 1994, 2000-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: lisp, languages
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -140,9 +140,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,46 +634,59 @@ considered."
(interactive)
(let* ((data (lisp-completion-at-point predicate))
(plist (nthcdr 3 data)))
+ (if (null data)
+ (minibuffer-message "Nothing to complete")
(let ((completion-annotate-function
(plist-get plist :annotation-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
- :annotation-function
- (unless (eq predicate 'fboundp)
- (lambda (str) (if (fboundp (intern-soft str)) " <f>")))))))
-
-;; arch-tag: aa7fa8a4-2e6f-4e9b-9cd9-fef06340e67e
+ (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
+ :annotation-function
+ (unless (eq predicate 'fboundp)
+ (lambda (str) (if (fboundp (intern-soft str)) " <f>"))))))))
+
;;; lisp.el ends here
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index cdbbe52d0a8..f0a075ace37 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -1,6 +1,6 @@
-;;; macroexp.el --- Additional macro-expansion support
+;;; macroexp.el --- Additional macro-expansion support -*- lexical-binding: t -*-
;;
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;;
;; Author: Miles Bader <miles@gnu.org>
;; Keywords: lisp, compiler, macros
@@ -29,6 +29,8 @@
;;; Code:
+(eval-when-compile (require 'cl))
+
;; Bound by the top-level `macroexpand-all', and modified to include any
;; macros defined by `defmacro'.
(defvar macroexpand-all-environment nil)
@@ -52,6 +54,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 +75,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.
@@ -106,81 +108,101 @@ Assumes the caller has bound `macroexpand-all-environment'."
(macroexpand (macroexpand-all-forms form 1)
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)))
+ (let ((new-form (macroexpand form macroexpand-all-environment)))
+ (when (and (not (eq form new-form)) ;It was a macro call.
+ (car-safe form)
+ (symbolp (car form))
+ (get (car form) 'byte-obsolete-info)
+ (fboundp 'byte-compile-warn-obsolete))
+ (byte-compile-warn-obsolete (car form)))
+ (setq form new-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)
+ (let ((n 3))
+ ;; Don't macroexpand `declare' since it should really be "expanded"
+ ;; away when `defmacro' is expanded, but currently defmacro is not
+ ;; itself a macro. So both `defmacro' and `declare' need to be
+ ;; handled directly in bytecomp.el.
+ ;; FIXME: Maybe a simpler solution is to (defalias 'declare 'quote).
+ (while (or (stringp (nth n form))
+ (eq (car-safe (nth n form)) 'declare))
+ (setq n (1+ n)))
+ (macroexpand-all-forms form n)))
+ (`(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))
+ ',(and f `(lambda . ,_)) . ,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 ',(and f `(lambda . ,_)) . ,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)))))
+ ;; Macro expand compiler macros. This cannot be delayed to
+ ;; byte-optimize-form because the output of the compiler-macro can
+ ;; use macros.
+ ;; FIXME: Don't depend on CL.
+ (`(,(pred (lambda (fun)
+ (and (symbolp fun)
+ (eq (get fun 'byte-compile)
+ 'cl-byte-compile-compiler-macro)
+ (functionp 'compiler-macroexpand))))
+ . ,_)
+ (let ((newform (with-no-warnings (compiler-macroexpand form))))
+ (if (eq form newform)
+ (macroexpand-all-forms form 1)
+ (macroexpand-all-1 newform))))
+ (`(,_ . ,_)
+ ;; 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)
@@ -193,5 +215,4 @@ definitions to shadow the loaded ones for use in file byte-compilation."
(provide 'macroexp)
-;; arch-tag: af9b8c24-c196-43bc-91e1-a3570790fa5a
;;; macroexp.el ends here
diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el
index aefc631c3ba..6ef26fef89c 100644
--- a/lisp/emacs-lisp/map-ynp.el
+++ b/lisp/emacs-lisp/map-ynp.el
@@ -1,7 +1,6 @@
;;; map-ynp.el --- general-purpose boolean question-asker
-;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1991-1995, 2000-2011 Free Software Foundation, Inc.
;; Author: Roland McGrath <roland@gnu.org>
;; Maintainer: FSF
@@ -275,5 +274,4 @@ the current %s and exit."
;; Return the number of actions that were taken.
actions))
-;; arch-tag: 1d0a3201-a151-4c10-b231-4da47c9e6dc3
;;; map-ynp.el ends here
diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el
new file mode 100644
index 00000000000..cd4b5ee231c
--- /dev/null
+++ b/lisp/emacs-lisp/package-x.el
@@ -0,0 +1,309 @@
+;;; package-x.el --- Package extras
+
+;; Copyright (C) 2007-2011 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 that many
+;; won't need, such as package uploading.
+
+;; To upload to an archive, first set `package-archive-upload-base' to
+;; some desired directory. For testing purposes, you can specify any
+;; directory you want, but if you want the archive to be accessible to
+;; others via http, this is typically a directory in the /var/www tree
+;; (possibly one on a remote machine, accessed via Tramp).
+
+;; Then call M-x package-upload-file, which prompts for a file to
+;; upload. Alternatively, M-x package-upload-buffer uploads the
+;; current buffer, if it's visiting a package file.
+
+;; Once a package is uploaded, users can access it via the Package
+;; Menu, by adding the archive to `package-archives'.
+
+;;; Code:
+
+(require 'package)
+(defvar gnus-article-buffer)
+
+(defcustom package-archive-upload-base "/path/to/archive"
+ "The base location of the archive to which packages are uploaded.
+This should be an absolute directory name. If the archive is on
+another machine, you may specify a remote name in the usual way,
+e.g. \"/ssh:foo@example.com:/var/www/packages/\".
+See Info node `(emacs)Remote Files'.
+
+Unlike `package-archives', you can't specify a HTTP URL."
+ :type 'directory
+ :group 'package
+ :version "24.1")
+
+(defvar package-update-news-on-upload nil
+ "Whether uploading a package should also update NEWS and RSS feeds.")
+
+(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 tag text)
+ "Update the package archive file named FILE.
+FILE should be relative to `package-archive-upload-base'.
+TAG is a string that can be found within the file; TEXT is
+inserted after its first occurrence in the file."
+ (setq file (expand-file-name file package-archive-upload-base))
+ (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 tag)
+ (forward-line)
+ (insert text)
+ (let ((file-precious-flag t))
+ (save-buffer))
+ (unless old-buffer
+ (kill-buffer (current-buffer)))))))
+
+(defun package--archive-contents-from-url (archive-url)
+ "Parse archive-contents file at ARCHIVE-URL.
+Return the file contents, as a string, or nil if unsuccessful."
+ (ignore-errors
+ (when archive-url
+ (let* ((buffer (url-retrieve-synchronously
+ (concat archive-url "archive-contents"))))
+ (set-buffer buffer)
+ (package-handle-response)
+ (re-search-forward "^$" nil 'move)
+ (forward-char)
+ (delete-region (point-min) (point))
+ (prog1 (package-read-from-string
+ (buffer-substring-no-properties (point-min) (point-max)))
+ (kill-buffer buffer))))))
+
+(defun package--archive-contents-from-file ()
+ "Parse the archive-contents at `package-archive-upload-base'"
+ (let ((file (expand-file-name "archive-contents"
+ package-archive-upload-base)))
+ (if (not (file-exists-p file))
+ ;; No existing archive-contents means a new archive.
+ (list package-archive-version)
+ (let ((dont-kill (find-buffer-visiting file)))
+ (with-current-buffer (let ((find-file-visit-truename t))
+ (find-file-noselect file))
+ (prog1
+ (package-read-from-string
+ (buffer-substring-no-properties (point-min) (point-max)))
+ (unless dont-kill
+ (kill-buffer (current-buffer)))))))))
+
+(defun package-maint-add-news-item (title description archive-url)
+ "Add a news item to the webpages associated with the package archive.
+TITLE is the title of the news item.
+DESCRIPTION is the text of the news item."
+ (interactive "sTitle: \nsText: ")
+ (package--update-file "elpa.rss"
+ "<description>"
+ (package--make-rss-entry title description archive-url))
+ (package--update-file "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\".
+
+The upload destination is given by `package-archive-upload-base'.
+If its value is invalid, prompt for a directory.
+
+Optional arg ARCHIVE-URL is the URL of the destination archive.
+If it is non-nil, compute the new \"archive-contents\" file
+starting from the existing \"archive-contents\" at that URL. In
+addition, if `package-update-news-on-upload' is non-nil, call
+`package--update-news' to add a news item at that URL.
+
+If ARCHIVE-URL is nil, compute the new \"archive-contents\" file
+from the \"archive-contents\" at `package-archive-upload-base',
+if it exists."
+ (let ((package-archive-upload-base package-archive-upload-base))
+ ;; Check if `package-archive-upload-base' is valid.
+ (when (or (not (stringp package-archive-upload-base))
+ (equal package-archive-upload-base
+ (car-safe
+ (get 'package-archive-upload-base 'standard-value))))
+ (setq package-archive-upload-base
+ (read-directory-name
+ "Base directory for package archive: ")))
+ (unless (file-directory-p package-archive-upload-base)
+ (if (y-or-n-p (format "%s does not exist; create it? "
+ package-archive-upload-base))
+ (make-directory package-archive-upload-base t)
+ (error "Aborted")))
+ (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)))
+
+ ;; Get archive-contents from ARCHIVE-URL if it's non-nil, or
+ ;; from `package-archive-upload-base' otherwise.
+ (let ((contents (or (package--archive-contents-from-url archive-url)
+ (package--archive-contents-from-file)))
+ (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
+ (expand-file-name "archive-contents"
+ package-archive-upload-base)))
+
+ ;; If there is a commentary section, write it.
+ (when commentary
+ (write-region commentary nil
+ (expand-file-name
+ (concat (symbol-name pkg-name) "-readme.txt")
+ package-archive-upload-base)))
+
+ (set-buffer pkg-buffer)
+ (write-region (point-min) (point-max)
+ (expand-file-name
+ (concat file-name "-" pkg-version "." extension)
+ package-archive-upload-base)
+ nil nil nil 'excl)
+
+ ;; Write a news entry.
+ (and package-update-news-on-upload
+ archive-url
+ (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)
+ (expand-file-name
+ (concat file-name "." extension)
+ package-archive-upload-base)
+ nil nil nil 'ask))))))))
+
+(defun package-upload-buffer ()
+ "Upload the current buffer as a single-file Emacs Lisp package.
+If `package-archive-upload-base' does not specify a valid upload
+destination, prompt for one."
+ (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)
+ "Upload the Emacs Lisp package FILE to the package archive.
+Interactively, prompt for FILE. The package is considered a
+single-file package if FILE ends in \".el\", and a multi-file
+package if FILE ends in \".tar\".
+If `package-archive-upload-base' does not specify a valid upload
+destination, prompt for one."
+ (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-x.el ends here
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
new file mode 100644
index 00000000000..e42103a7a01
--- /dev/null
+++ b/lisp/emacs-lisp/package.el
@@ -0,0 +1,1621 @@
+;;; package.el --- Simple package system for Emacs
+
+;; Copyright (C) 2007-2011 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-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:
+
+(require 'tabulated-list)
+
+(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 . LOCATION).
+ ID is an archive name, as a string.
+ LOCATION specifies the base location for the archive.
+ If it starts with \"http:\", it is treated as a HTTP URL;
+ otherwise it should be an absolute directory name.
+ (Other types of URL are currently not supported.)"
+ :type '(alist :key-type (string :tag "Archive name")
+ :value-type (string :tag "URL or directory name"))
+ :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-LIST REQS DOCSTRING].
+ VERSION-LIST is a version list.
+ REQS is a list of packages required by the package, each
+ requirement having the form (NAME VL), where NAME is a string
+ and VL is a version list.
+ 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-LIST REQS DOCSTRING].
+ VERSION-LIST is a version list.
+ REQS is a list of packages required by the package, each
+ requirement having the form (NAME VL) where NAME is a string
+ and VL is a version list.
+ 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)
+
+(defun package-version-join (vlist)
+ "Return the version string corresponding to the list VLIST.
+This is, approximately, the inverse of `version-to-list'.
+\(Actually, it returns only one of the possible inverses, since
+`version-to-list' is a many-to-one operation.)"
+ (if (null vlist)
+ ""
+ (let ((str-list (list "." (int-to-string (car vlist)))))
+ (dolist (num (cdr vlist))
+ (cond
+ ((>= num 0)
+ (push (int-to-string num) str-list)
+ (push "." str-list))
+ ((< num -3)
+ (error "Invalid version list `%s'" vlist))
+ (t
+ ;; pre, or beta, or alpha
+ (cond ((equal "." (car str-list))
+ (pop str-list))
+ ((not (string-match "[0-9]+" (car str-list)))
+ (error "Invalid version list `%s'" vlist)))
+ (push (cond ((= num -1) "pre")
+ ((= num -2) "beta")
+ ((= num -3) "alpha"))
+ str-list))))
+ (if (equal "." (car str-list))
+ (pop str-list))
+ (apply 'concat (nreverse str-list)))))
+
+(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 (concat "\\`" 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-VERSION, where NAME is
+the package name and VERSION 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))
+ (regexp (concat "\\`" package-subdirectory-regexp "\\'"))
+ 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 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 min-version)
+ "Return true if PACKAGE is built-in to Emacs.
+Optional arg MIN-VERSION, if non-nil, should be a version list
+specifying the minimum acceptable version."
+ (require 'finder-inf nil t) ; For `package--builtins'.
+ (let ((elt (assq package package--builtins)))
+ (and elt (version-list-<= min-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 min-version)
+ "Activate package PACKAGE, of version MIN-VERSION or newer.
+MIN-VERSION should be a version list.
+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-<= min-version available-version)))
+ (cond
+ ;; If no such package is found, maybe it's built-in.
+ ((null found)
+ (package-built-in-p package min-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 string.
+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 OTHER-VERSION),
+ where OTHER-VERSION is a string.
+
+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)))
+
+(defvar tar-parse-info)
+(declare-function tar-untar-buffer "tar-mode" ())
+
+(defun package-untar-buffer (dir)
+ "Untar the current buffer.
+This uses `tar-untar-buffer' from Tar mode. All files should
+untar into a directory named DIR; otherwise, signal an error."
+ (require 'tar-mode)
+ (tar-mode)
+ ;; Make sure everything extracts into DIR.
+ (let ((regexp (concat "\\`" (regexp-quote dir) "/")))
+ (dolist (tar-data tar-parse-info)
+ (unless (string-match regexp (aref tar-data 2))
+ (error "Package does not untar cleanly into directory %s/" dir))))
+ (tar-untar-buffer))
+
+(defun package-unpack (name version)
+ (let* ((dirname (concat (symbol-name name) "-" version))
+ (pkg-dir (expand-file-name dirname 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 dirname)
+ (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)
+ (let ((buffer-file-coding-system 'no-conversion))
+ (write-region (point-min) (point-max) file-name)))
+
+(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))
+ (let* ((pkg-dir (expand-file-name (concat file-name "-"
+ (package-version-join
+ (version-to-list 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)
+ (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)))))
+
+(defmacro package--with-work-buffer (location file &rest body)
+ "Run BODY in a buffer containing the contents of FILE at LOCATION.
+LOCATION is the base location of a package archive, and should be
+one of the URLs (or file names) specified in `package-archives'.
+FILE is the name of a file relative to that base location.
+
+This macro retrieves FILE from LOCATION into a temporary buffer,
+and evaluates BODY while that buffer is current. This work
+buffer is killed afterwards. Return the last value in BODY."
+ `(let* ((http (string-match "\\`https?:" ,location))
+ (buffer
+ (if http
+ (url-retrieve-synchronously (concat ,location ,file))
+ (generate-new-buffer "*package work buffer*"))))
+ (prog1
+ (with-current-buffer buffer
+ (if http
+ (progn (package-handle-response)
+ (re-search-forward "^$" nil 'move)
+ (forward-char)
+ (delete-region (point-min) (point)))
+ (unless (file-name-absolute-p ,location)
+ (error "Archive location %s is not an absolute file name"
+ ,location))
+ (insert-file-contents (expand-file-name ,file ,location)))
+ ,@body)
+ (kill-buffer buffer))))
+
+(defun package-handle-response ()
+ "Handle the response from a `url-retrieve-synchronously' call.
+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))
+ (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 ((location (package-archive-base name))
+ (file (concat (symbol-name name) "-" version ".el")))
+ (package--with-work-buffer location file
+ (package-unpack-single (symbol-name name) version desc requires))))
+
+(defun package-download-tar (name version)
+ "Download and install a tar package."
+ (let ((location (package-archive-base name))
+ (file (concat (symbol-name name) "-" version ".tar")))
+ (package--with-work-buffer location file
+ (package-unpack name version))))
+
+(defun package-installed-p (package &optional min-version)
+ "Return true if PACKAGE, of MIN-VERSION or newer, is installed.
+MIN-VERSION should be a version list."
+ (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-LIST),
+where PACKAGE is a package name and VERSION-LIST is the required
+version of that package.
+
+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 (str)
+ "Strip RCS version ID from the version string STR.
+If the result looks like a dotted numeric version, return it.
+Otherwise return nil."
+ (when str
+ (when (string-match "\\`[ \t]*[$]Revision:[ \t]+" str)
+ (setq str (substring str (match-end 0))))
+ (condition-case nil
+ (if (version-to-list str)
+ str)
+ (error nil))))
+
+(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 list of requirements, each requirement having the
+ form (NAME VER); NAME is a string and VER is a version list.
+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'."
+ (let ((default-directory (file-name-directory file))
+ (file (file-name-nondirectory file)))
+ (unless (string-match (concat "\\`" package-subdirectory-regexp "\\.tar\\'")
+ file)
+ (error "Invalid package name `%s'" file))
+ (let* ((pkg-name (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-base (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)
+ "Retrieve an archive file FILE from ARCHIVE, and cache it.
+ARCHIVE should be a cons cell of the form (NAME . LOCATION),
+similar to an entry in `package-alist'. Save the cached copy to
+\"archives/NAME/archive-contents\" in `package-user-dir'."
+ (let* ((dir (expand-file-name "archives" package-user-dir))
+ (dir (expand-file-name (car archive) dir)))
+ (package--with-work-buffer (cdr archive) file
+ ;; 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))))))
+
+(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-no-debug 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))
+ readme-string)
+ ;; For elpa packages, try downloading the commentary. If that
+ ;; fails, try an existing readme file in `package-user-dir'.
+ (cond ((condition-case nil
+ (package--with-work-buffer (package-archive-base package)
+ (concat package-name "-readme.txt")
+ (setq buffer-file-name
+ (expand-file-name readme package-user-dir))
+ (let ((version-control 'never))
+ (save-buffer))
+ (setq readme-string (buffer-string))
+ t)
+ (error nil))
+ (insert readme-string))
+ ((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-sparse-keymap))
+ (menu-map (make-sparse-keymap "Package")))
+ (set-keymap-parent map tabulated-list-mode-map)
+ (define-key map "\C-m" 'package-menu-describe-package)
+ (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 "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 [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.")
+
+(define-derived-mode package-menu-mode tabulated-list-mode "Package Menu"
+ "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}"
+ (setq tabulated-list-format [("Package" 18 package-menu--name-predicate)
+ ("Version" 12 nil)
+ ("Status" 10 package-menu--status-predicate)
+ ("Description" 0 nil)])
+ (setq tabulated-list-padding 2)
+ (setq tabulated-list-sort-key (cons "Status" nil))
+ (tabulated-list-init-header))
+
+(defmacro package--push (package desc status listname)
+ "Convenience macro for `package-menu--generate'.
+If the alist stored in the symbol LISTNAME lacks an entry for a
+package PACKAGE with descriptor DESC, add one. The alist is
+keyed with cons cells (PACKAGE . VERSION-LIST), where PACKAGE is
+a symbol and VERSION-LIST is a version list."
+ `(let* ((version (package-desc-vers ,desc))
+ (key (cons ,package version)))
+ (unless (assoc key ,listname)
+ (push (list key ,status (package-desc-doc ,desc)) ,listname))))
+
+(defun package-menu--generate (remember-pos packages)
+ "Populate the Package Menu.
+If REMEMBER-POS is non-nil, keep point on the same entry.
+PACKAGES should be t, which means to display all known packages,
+or a list of package names (symbols) to display."
+ ;; Construct list of ((PACKAGE . VERSION) STATUS DESCRIPTION).
+ (let (info-list name builtin)
+ ;; Installed packages:
+ (dolist (elt package-alist)
+ (setq name (car elt))
+ (when (or (eq packages t) (memq name packages))
+ (package--push name (cdr elt)
+ (if (stringp (cadr (assq name package-load-list)))
+ "held" "installed")
+ info-list)))
+
+ ;; Built-in packages:
+ (dolist (elt package--builtins)
+ (setq name (car elt))
+ (when (and (not (eq name 'emacs)) ; Hide the `emacs' package.
+ (or (eq packages t) (memq name packages)))
+ (package--push name (cdr elt) "built-in" info-list)))
+
+ ;; Available and disabled packages:
+ (dolist (elt package-archive-contents)
+ (setq name (car elt))
+ (when (or (eq packages t) (memq name packages))
+ (let ((hold (assq name package-load-list)))
+ (package--push name (cdr elt)
+ (if (and hold (null (cadr hold)))
+ "disabled"
+ "available")
+ info-list))))
+
+ ;; Obsolete packages:
+ (dolist (elt package-obsolete-alist)
+ (dolist (inner-elt (cdr elt))
+ (when (or (eq packages t) (memq (car elt) packages))
+ (package--push (car elt) (cdr inner-elt) "obsolete" info-list))))
+
+ ;; Print the result.
+ (setq tabulated-list-entries (mapcar 'package-menu--print-info info-list))
+ (tabulated-list-print remember-pos)))
+
+(defun package-menu--print-info (pkg)
+ "Return a package entry suitable for `tabulated-list-entries'.
+PKG has the form ((PACKAGE . VERSION) STATUS DOC).
+Return (KEY [NAME VERSION STATUS DOC]), where KEY is the
+identifier (NAME . VERSION-LIST)."
+ (let* ((package (caar pkg))
+ (version (cdr (car pkg)))
+ (status (nth 1 pkg))
+ (doc (or (nth 2 pkg) ""))
+ (face (cond
+ ((string= status "built-in") 'font-lock-builtin-face)
+ ((string= status "available") 'default)
+ ((string= status "held") 'font-lock-constant-face)
+ ((string= status "disabled") 'font-lock-warning-face)
+ ((string= status "installed") 'font-lock-comment-face)
+ (t 'font-lock-warning-face)))) ; obsolete.
+ (list (cons package version)
+ (vector (list (symbol-name package)
+ 'face 'link
+ 'follow-link t
+ 'package-symbol package
+ 'action 'package-menu-describe-package)
+ (propertize (package-version-join version)
+ 'font-lock-face face)
+ (propertize status 'font-lock-face face)
+ (propertize doc 'font-lock-face face)))))
+
+(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-menu--generate t t))
+
+(defun package-menu-describe-package (&optional button)
+ "Describe the current package.
+If optional arg BUTTON is non-nil, describe its associated package."
+ (interactive)
+ (let ((package (if button (button-get button 'package-symbol)
+ (car (tabulated-list-get-id)))))
+ (if package
+ (describe-package package))))
+
+;; 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")
+ (tabulated-list-put-tag "D" t)
+ (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")
+ (tabulated-list-put-tag "I" t)
+ (forward-line)))
+
+(defun package-menu-mark-unmark (num)
+ "Clear any marks on a package and move to the next line."
+ (interactive "p")
+ (tabulated-list-put-tag " " t))
+
+(defun package-menu-backup-unmark ()
+ "Back up one line and clear any marks on that package."
+ (interactive)
+ (forward-line -1)
+ (tabulated-list-put-tag " "))
+
+(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 ")
+ (tabulated-list-put-tag "D" t)
+ (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")
+
+(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)
+ (unless (eq major-mode 'package-menu-mode)
+ (error "The current buffer is not in Package Menu mode"))
+ (let (install-list delete-list cmd id)
+ (save-excursion
+ (goto-char (point-min))
+ (while (not (eobp))
+ (setq cmd (char-after))
+ (unless (eq cmd ?\s)
+ ;; This is the key (PACKAGE . VERSION-LIST).
+ (setq id (tabulated-list-get-id))
+ (cond ((eq cmd ?D)
+ (push (cons (symbol-name (car id))
+ (package-version-join (cdr id)))
+ delete-list))
+ ((eq cmd ?I)
+ (push (car id) 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-no-debug 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 'symbol-name install-list ", "))))
+ (mapc 'package-install install-list)))
+ ;; 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--generate t t)
+ (message "No operations specified."))))
+
+(defun package-menu--version-predicate (A B)
+ (let ((vA (or (aref (cadr A) 1) '(0)))
+ (vB (or (aref (cadr B) 1) '(0))))
+ (if (version-list-= vA vB)
+ (package-menu--name-predicate A B)
+ (version-list-< vA vB))))
+
+(defun package-menu--status-predicate (A B)
+ (let ((sA (aref (cadr A) 2))
+ (sB (aref (cadr B) 2)))
+ (cond ((string= sA sB)
+ (package-menu--name-predicate A B))
+ ((string= sA "available") t)
+ ((string= sB "available") nil)
+ ((string= sA "installed") t)
+ ((string= sB "installed") nil)
+ ((string= sA "held") t)
+ ((string= sB "held") nil)
+ ((string= sA "built-in") t)
+ ((string= sB "built-in") nil)
+ ((string= sA "obsolete") t)
+ ((string= sB "obsolete") nil)
+ (t (string< sA sB)))))
+
+(defun package-menu--description-predicate (A B)
+ (let ((dA (aref (cadr A) 3))
+ (dB (aref (cadr B) 3)))
+ (if (string= dA dB)
+ (package-menu--name-predicate A B)
+ (string< dA dB))))
+
+(defun package-menu--name-predicate (A B)
+ (string< (symbol-name (caar A))
+ (symbol-name (caar B))))
+
+;;;###autoload
+(defun list-packages (&optional no-fetch)
+ "Display a list of packages.
+This first fetches the updated list of packages before
+displaying, unless a prefix argument NO-FETCH is specified.
+The list is displayed in a buffer named `*Packages*'."
+ (interactive "P")
+ (require 'finder-inf nil t)
+ ;; Initialize the package system if necessary.
+ (unless package--initialized
+ (package-initialize t))
+ (unless no-fetch
+ (package-refresh-contents))
+ (let ((buf (get-buffer-create "*Packages*")))
+ (with-current-buffer buf
+ (package-menu-mode)
+ (package-menu--generate nil t))
+ ;; The package menu buffer has keybindings. If the user types
+ ;; `M-x list-packages', that suggests it should become current.
+ (switch-to-buffer buf)))
+
+;;;###autoload
+(defalias 'package-list-packages 'list-packages)
+
+;; Used in finder.el
+(defun package-show-package-list (packages)
+ "Display PACKAGES in a *Packages* buffer.
+This is similar to `list-packages', but it does not fetch the
+updated list of packages, and it only displays packages with
+names in PACKAGES (which should be a list of symbols)."
+ (require 'finder-inf nil t)
+ (let ((buf (get-buffer-create "*Packages*")))
+ (with-current-buffer buf
+ (package-menu-mode)
+ (package-menu--generate nil packages))
+ (switch-to-buffer buf)))
+
+(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)
+ (list-packages t))
+
+(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..e6c4ccbbc50
--- /dev/null
+++ b/lisp/emacs-lisp/pcase.el
@@ -0,0 +1,692 @@
+;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t -*-
+
+;; Copyright (C) 2010-2011 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:
+
+;; - (pcase e (`(,x . ,x) foo)) signals an "x unused" warning if `foo' doesn't
+;; use x, because x is bound separately for the equality constraint
+;; (as well as any pred/guard) and for the body, so uses at one place don't
+;; count for the other.
+;; - 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.
+;; - along these lines, provide patterns to match CL structs.
+;; - provide something like (setq VAR) so a var can be set rather than
+;; let-bound.
+;; - provide a way to fallthrough to subsequent cases.
+;; - try and be more clever to reduce the size of the decision tree, and
+;; to reduce the number of leaves that need to be turned into function:
+;; - first, do the tests shared by all remaining branches (it will have
+;; to be performed anyway, so better so it first so it's shared).
+;; - then choose the test that discriminates more (?).
+;; - 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:
+
+;; 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 'key :test 'eq))
+
+(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.
+ (let UPAT EXP) matches if EXP matches UPAT.
+If a SYMBOL is used twice in the same pattern (i.e. the pattern is
+\"non-linear\"), then the second occurrence is turned into an `eq'uality test.
+
+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.
+ ;; We want to use a weak hash table as a cache, but the key will unavoidably
+ ;; be based on `exp' and `cases', yet `cases' is a fresh new list each time
+ ;; we're called so it'll be immediately GC'd. So we use (car cases) as key
+ ;; which does come straight from the source code and should hence not be GC'd
+ ;; so easily.
+ (let ((data (gethash (car cases) pcase--memoize)))
+ ;; data = (EXP CASES . EXPANSION)
+ (if (and (equal exp (car data)) (equal cases (cadr data)))
+ ;; We have the right expansion.
+ (cddr data)
+ (when data
+ (message "pcase-memoize: equal first branch, yet different"))
+ (let ((expansion (pcase--expand exp cases)))
+ (puthash (car cases) (cons exp (cons cases expansion)) pcase--memoize)
+ expansion))))
+
+;;;###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)
+ ;; (message "pid=%S (pcase--expand %S ...hash=%S)"
+ ;; (emacs-pid) exp (sxhash 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.
+ (let* ((code (car prev)) (cdrprev (cdr prev))
+ (prevvars (car cdrprev)) (cddrprev (cdr cdrprev))
+ (res (car cddrprev)))
+ (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 then :pcase--dontcare) (debug) else) ;Can/should this ever happen?
+ ((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))))
+ ;; Invert the test if that lets us reduce the depth of the tree.
+ ((memq (car-safe then) '(if cond)) (pcase--if `(not ,test) else then))
+ (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))
+ (let* ((carbranch (car branches))
+ (match (car carbranch)) (cdarbranch (cdr carbranch))
+ (code (car cdarbranch))
+ (vars (cdr cdarbranch)))
+ (pcase--u1 (list match) code vars (cdr branches)))))
+
+(defun pcase--and (match matches)
+ (if matches `(and ,match ,@matches) match))
+
+(defconst pcase-mutually-exclusive-predicates
+ '((symbolp . integerp)
+ (symbolp . numberp)
+ (symbolp . consp)
+ (symbolp . arrayp)
+ (symbolp . stringp)
+ (symbolp . byte-code-function-p)
+ (integerp . consp)
+ (integerp . arrayp)
+ (integerp . stringp)
+ (integerp . byte-code-function-p)
+ (numberp . consp)
+ (numberp . arrayp)
+ (numberp . stringp)
+ (numberp . byte-code-function-p)
+ (consp . arrayp)
+ (consp . stringp)
+ (consp . byte-code-function-p)
+ (arrayp . stringp)
+ (arrayp . byte-code-function-p)
+ (stringp . byte-code-function-p)))
+
+(defun pcase--split-match (sym splitter match)
+ (cond
+ ((eq (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))))))))
+ ((memq (car 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 to the `else' side.
+ ((eq (car-safe pat) '\`) (cons :pcase--fail nil))
+ ((and (eq (car-safe pat) 'pred)
+ (or (member (cons 'consp (cadr pat))
+ pcase-mutually-exclusive-predicates)
+ (member (cons (cadr pat) 'consp)
+ pcase-mutually-exclusive-predicates)))
+ (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))
+ ((and (eq (car-safe pat) 'pred)
+ (symbolp (cadr pat))
+ (get (cadr pat) 'side-effect-free)
+ (funcall (cadr pat) elem))
+ (cons :pcase--succeed 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))
+ ((and (eq (car-safe pat) 'pred)
+ (symbolp (cadr pat))
+ (get (cadr pat) 'side-effect-free)
+ (let ((p (cadr pat)) (all t))
+ (dolist (elem elems)
+ (unless (funcall p elem) (setq all nil)))
+ all))
+ (cons :pcase--succeed nil))))
+
+(defun pcase--split-pred (upat pat)
+ ;; FIXME: For predicates like (pred (> a)), two such predicates may
+ ;; actually refer to different variables `a'.
+ (cond
+ ((equal upat pat) (cons :pcase--succeed :pcase--fail))
+ ((and (eq 'pred (car upat))
+ (eq 'pred (car-safe pat))
+ (or (member (cons (cadr upat) (cadr pat))
+ pcase-mutually-exclusive-predicates)
+ (member (cons (cadr pat) (cadr upat))
+ pcase-mutually-exclusive-predicates)))
+ (cons :pcase--fail nil))
+ ;; ((and (eq 'pred (car upat))
+ ;; (eq '\` (car-safe pat))
+ ;; (symbolp (cadr upat))
+ ;; (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat)))
+ ;; (get (cadr upat) 'side-effect-free)
+ ;; (progn (message "Trying predicate %S" (cadr upat))
+ ;; (ignore-errors
+ ;; (funcall (cadr upat) (cadr pat)))))
+ ;; (message "Simplify pred %S against %S" upat pat)
+ ;; (cons nil :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.
+Otherwise, it 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 (cons
+ (pcase--and (if (cdr others)
+ (cons 'or (nreverse others))
+ (car others))
+ (cdr matches))
+ (cons code vars))
+ rest))))
+ (t
+ (pcase--u1 (cons (pop alts) (cdr matches)) code vars
+ (if (null alts) (progn (error "Please avoid it") rest)
+ (cons (cons
+ (pcase--and (if (cdr alts)
+ (cons 'or alts) (car alts))
+ (cdr matches))
+ (cons code vars))
+ rest)))))))
+ ((eq 'match (caar matches))
+ (let* ((popmatches (pop matches))
+ (_op (car popmatches)) (cdrpopmatches (cdr popmatches))
+ (sym (car cdrpopmatches))
+ (upat (cdr cdrpopmatches)))
+ (cond
+ ((memq upat '(t _)) (pcase--u1 matches code vars rest))
+ ((eq upat 'dontcare) :pcase--dontcare)
+ ((memq (car-safe upat) '(guard pred))
+ (if (eq (car upat) 'pred) (put sym 'pcase-used t))
+ (let* ((splitrest
+ (pcase--split-rest
+ sym (apply-partially #'pcase--split-pred upat) rest))
+ (then-rest (car splitrest))
+ (else-rest (cdr splitrest)))
+ (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))
+ (env (mapcar (lambda (var)
+ (list var (cdr (assq var vars))))
+ vs))
+ (call (if (eq 'guard (car upat))
+ exp
+ (when (memq sym vs)
+ ;; `sym' is shadowed by `env'.
+ (let ((newsym (make-symbol "x")))
+ (push (list newsym sym) env)
+ (setq sym newsym)))
+ (if (functionp exp) `(,exp ,sym)
+ `(,@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* ,env ,call))))
+ (pcase--u1 matches code vars then-rest)
+ (pcase--u else-rest))))
+ ((symbolp upat)
+ (put sym 'pcase-used t)
+ (if (not (assq upat vars))
+ (pcase--u1 matches code (cons (cons upat sym) vars) rest)
+ ;; Non-linear pattern. Turn it into an `eq' test.
+ (pcase--u1 (cons `(match ,sym . (pred (eq ,(cdr (assq upat vars)))))
+ matches)
+ code vars rest)))
+ ((eq (car-safe upat) 'let)
+ ;; A upat of the form (let VAR EXP).
+ ;; (pcase--u1 matches code
+ ;; (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest)
+ (let* ((exp
+ (let* ((exp (nth 2 upat))
+ (found (assq exp vars)))
+ (if found (cdr found)
+ (let* ((vs (pcase--fgrep (mapcar #'car vars) exp))
+ (env (mapcar (lambda (v) (list v (cdr (assq v vars))))
+ vs)))
+ (if env `(let* ,env ,exp) exp)))))
+ (sym (if (symbolp exp) exp (make-symbol "x")))
+ (body
+ (pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches)
+ code vars rest)))
+ (if (eq sym exp)
+ body
+ `(let* ((,sym ,exp)) ,body))))
+ ((eq (car-safe upat) '\`)
+ (put sym 'pcase-used t)
+ (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)))
+ (splitrest
+ (pcase--split-rest
+ sym (apply-partially #'pcase--split-member elems) rest))
+ (then-rest (car splitrest))
+ (else-rest (cdr splitrest)))
+ (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)))
+ ;; 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.
+Otherwise, it 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"))
+ (splitrest (pcase--split-rest
+ sym
+ (apply-partially #'pcase--split-consp syma symd)
+ rest))
+ (then-rest (car splitrest))
+ (else-rest (cdr splitrest))
+ (then-body (pcase--u1 `((match ,syma . ,(pcase--upat (car qpat)))
+ (match ,symd . ,(pcase--upat (cdr qpat)))
+ ,@matches)
+ code vars then-rest)))
+ (pcase--if
+ `(consp ,sym)
+ ;; We want to be careful to only add bindings that are used.
+ ;; The byte-compiler could do that for us, but it would have to pay
+ ;; attention to the `consp' test in order to figure out that car/cdr
+ ;; can't signal errors and our byte-compiler is not that clever.
+ `(let (,@(if (get syma 'pcase-used) `((,syma (car ,sym))))
+ ,@(if (get symd 'pcase-used) `((,symd (cdr ,sym)))))
+ ,then-body)
+ (pcase--u else-rest))))
+ ((or (integerp qpat) (symbolp qpat) (stringp qpat))
+ (let* ((splitrest (pcase--split-rest
+ sym (apply-partially 'pcase--split-equal qpat) rest))
+ (then-rest (car splitrest))
+ (else-rest (cdr splitrest)))
+ (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/pp.el b/lisp/emacs-lisp/pp.el
index 34ac4f95d59..2d1b8860a3c 100644
--- a/lisp/emacs-lisp/pp.el
+++ b/lisp/emacs-lisp/pp.el
@@ -1,7 +1,6 @@
;;; pp.el --- pretty printer for Emacs Lisp
-;; Copyright (C) 1989, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1989, 1993, 2001-2011 Free Software Foundation, Inc.
;; Author: Randal Schwartz <merlyn@stonehenge.com>
;; Keywords: lisp
@@ -202,5 +201,4 @@ Ignores leading comment characters."
(provide 'pp) ; so (require 'pp) works
-;; arch-tag: b0f7c65b-02c7-42bb-9ee3-508a59b8fbb9
;;; pp.el ends here
diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el
index fd47c576404..50a65eb6bbb 100644
--- a/lisp/emacs-lisp/re-builder.el
+++ b/lisp/emacs-lisp/re-builder.el
@@ -1,7 +1,6 @@
-;;; re-builder.el --- building Regexps with visual feedback
+;;; re-builder.el --- building Regexps with visual feedback -*- lexical-binding: t -*-
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Detlev Zundel <dzu@gnu.org>
;; Keywords: matching, lisp, tools
@@ -60,15 +59,13 @@
;; even the auto updates go all the way. Forcing an update overrides
;; 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
+;; Currently `re-builder' understands three different forms of input,
+;; namely `read', `string', and `rx' 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
@@ -77,7 +74,7 @@
;; When editing a symbolic regular expression, only the first
;; expression in the RE Builder buffer is considered, which helps
;; limiting the extent of the expression like the `"'s do for the text
-;; modes. For the `sregex' syntax the function `sregex' is applied to
+;; modes. For the `rx' syntax the function `rx-to-string' is applied to
;; the evaluated expression read. So you can use quoted arguments
;; with something like '("findme") or you can construct arguments to
;; your hearts delight with a valid ELisp expression. (The compiled
@@ -128,12 +125,10 @@
(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', 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
@@ -280,22 +275,21 @@ Except for Lisp syntax this is the same as `reb-regexp'.")
(set (make-local-variable 'blink-matching-paren) nil)
(reb-mode-common))
+(defvar reb-lisp-mode-map
+ (let ((map (make-sparse-keymap)))
+ ;; Use the same "\C-c" keymap as `reb-mode' and use font-locking from
+ ;; `emacs-lisp-mode'
+ (define-key map "\C-c" (lookup-key reb-mode-map "\C-c"))
+ map))
+
(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
- (require 'sregex)) ; right now..
- ((eq reb-re-syntax 'rx) ; rx-to-string is autoloaded
- (require 'rx))) ; require rx anyway
+ ;; Pull in packages as needed
+ (cond ((memq reb-re-syntax '(sregex rx)) ; rx-to-string is autoloaded
+ (require 'rx))) ; require rx anyway
(reb-mode-common))
-;; Use the same "\C-c" keymap as `reb-mode' and use font-locking from
-;; `emacs-lisp-mode'
-(define-key reb-lisp-mode-map "\C-c"
- (lookup-key reb-mode-map "\C-c"))
-
(defvar reb-subexp-mode-map
(let ((m (make-keymap)))
(suppress-keymap m)
@@ -331,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."
@@ -491,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
@@ -512,7 +506,7 @@ If SUBEXP is non-nil mark only the corresponding sub-expressions."
(reb-update-regexp)
(reb-update-overlays subexp))
-(defun reb-auto-update (beg end lenold &optional force)
+(defun reb-auto-update (_beg _end _lenold &optional force)
"Called from `after-update-functions' to update the display.
BEG, END and LENOLD are passed in from the hook.
An actual update is only done if the regexp has changed or if the
@@ -618,12 +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)
- (apply 'sregex (eval (car (read-from-string re)))))
- ((eq reb-re-syntax 'rx)
+ (cond ((memq reb-re-syntax '(sregex rx))
(rx-to-string (eval (car (read-from-string re)))))
(t re)))
@@ -727,5 +716,4 @@ If SUBEXP is non-nil mark only the corresponding sub-expressions."
(provide 're-builder)
-;; arch-tag: 5c5515ac-4085-4524-a421-033f44f032e7
;;; re-builder.el ends here
diff --git a/lisp/emacs-lisp/regexp-opt.el b/lisp/emacs-lisp/regexp-opt.el
index 512f86b24d0..b538a7a2943 100644
--- a/lisp/emacs-lisp/regexp-opt.el
+++ b/lisp/emacs-lisp/regexp-opt.el
@@ -1,7 +1,6 @@
;;; regexp-opt.el --- generate efficient regexps to match strings
-;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-2011 Free Software Foundation, Inc.
;; Author: Simon Marshall <simon@gnu.org>
;; Maintainer: FSF
@@ -96,19 +95,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 +124,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))
@@ -288,5 +292,4 @@ Merges keywords to avoid backtracking in Emacs' regexp matcher."
(provide 'regexp-opt)
-;; arch-tag: 6c5a66f4-29af-4fd6-8c3b-4b554d5b4370
;;; regexp-opt.el ends here
diff --git a/lisp/emacs-lisp/regi.el b/lisp/emacs-lisp/regi.el
index 53cf21b2f99..8000dcd53dd 100644
--- a/lisp/emacs-lisp/regi.el
+++ b/lisp/emacs-lisp/regi.el
@@ -1,7 +1,6 @@
;;; regi.el --- REGular expression Interpreting engine
-;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2001-2011 Free Software Foundation, Inc.
;; Author: 1993 Barry A. Warsaw, Century Computing, Inc. <bwarsaw@cen.com>
;; Maintainer: bwarsaw@cen.com
@@ -254,5 +253,4 @@ useful information:
(provide 'regi)
-;; arch-tag: 804b4e45-4109-4f76-9a88-21887b881747
;;; regi.el ends here
diff --git a/lisp/emacs-lisp/ring.el b/lisp/emacs-lisp/ring.el
index 91ea5a93aab..affaa9ce32e 100644
--- a/lisp/emacs-lisp/ring.el
+++ b/lisp/emacs-lisp/ring.el
@@ -1,7 +1,6 @@
;;; ring.el --- handle rings of items
-;; Copyright (C) 1992, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: extensions
@@ -236,5 +235,4 @@ If SEQ is already a ring, return it."
(provide 'ring)
-;; arch-tag: e707682b-ed69-47c9-b20f-cf2c68cc92d2
;;; ring.el ends here
diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el
index ef69fed7952..7122de4789c 100644
--- a/lisp/emacs-lisp/rx.el
+++ b/lisp/emacs-lisp/rx.el
@@ -1,7 +1,6 @@
;;; rx.el --- sexp notation for regular expressions
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;; Author: Gerd Moellmann <gerd@gnu.org>
;; Maintainer: FSF
@@ -120,19 +119,17 @@
(nonl . not-newline) ; SRE
(anything . (rx-anything 0 nil))
(any . (rx-any 1 nil rx-check-any)) ; inconsistent with SRE
+ (any . ".") ; sregex
(in . any)
(char . any) ; sregex
(not-char . (rx-not-char 1 nil rx-check-any)) ; sregex
(not . (rx-not 1 1 rx-check-not))
- ;; Partially consistent with sregex, whose `repeat' is like our
- ;; `**'. (`repeat' with optional max arg and multiple sexp forms
- ;; is ambiguous.)
- (repeat . (rx-repeat 2 3))
+ (repeat . (rx-repeat 2 nil))
(= . (rx-= 2 nil)) ; SRE
(>= . (rx->= 2 nil)) ; SRE
(** . (rx-** 2 nil)) ; SRE
(submatch . (rx-submatch 1 nil)) ; SRE
- (group . submatch)
+ (group . submatch) ; sregex
(zero-or-more . (rx-kleene 1 nil))
(one-or-more . (rx-kleene 1 nil))
(zero-or-one . (rx-kleene 1 nil))
@@ -175,6 +172,7 @@
(category . (rx-category 1 1 rx-check-category))
(eval . (rx-eval 1 1))
(regexp . (rx-regexp 1 1 stringp))
+ (regex . regexp) ; sregex
(digit . "[[:digit:]]")
(numeric . digit) ; SRE
(num . digit) ; SRE
@@ -295,15 +293,27 @@ regular expression strings.")
`zero-or-more', and `one-or-more'. Dynamically bound.")
-(defun rx-info (op)
+(defun rx-info (op head)
"Return parsing/code generation info for OP.
If OP is the space character ASCII 32, return info for the symbol `?'.
If OP is the character `?', return info for the symbol `??'.
-See also `rx-constituents'."
+See also `rx-constituents'.
+If HEAD is non-nil, then OP is the head of a sexp, otherwise it's
+a standalone symbol."
(cond ((eq op ? ) (setq op '\?))
((eq op ??) (setq op '\??)))
- (while (and (not (null op)) (symbolp op))
- (setq op (cdr (assq op rx-constituents))))
+ (let (old-op)
+ (while (and (not (null op)) (symbolp op))
+ (setq old-op op)
+ (setq op (cdr (assq op rx-constituents)))
+ (when (if head (stringp op) (consp op))
+ ;; We found something but of the wrong kind. Let's look for an
+ ;; alternate definition for the other case.
+ (let ((new-op
+ (cdr (assq old-op (cdr (memq (assq old-op rx-constituents)
+ rx-constituents))))))
+ (if (and new-op (not (if head (stringp new-op) (consp new-op))))
+ (setq op new-op))))))
op)
@@ -311,7 +321,7 @@ See also `rx-constituents'."
"Check FORM according to its car's parsing info."
(unless (listp form)
(error "rx `%s' needs argument(s)" form))
- (let* ((rx (rx-info (car form)))
+ (let* ((rx (rx-info (car form) 'head))
(nargs (1- (length form)))
(min-args (nth 1 rx))
(max-args (nth 2 rx))
@@ -401,7 +411,7 @@ Only both edges of each range is checked."
(setcdr m (1- char)))))
ranges))
-
+
(defun rx-any-condense-range (args)
"Condense by side effect ARGS as range for Rx `any'."
(let (str
@@ -564,7 +574,7 @@ ARG is optional."
(condition-case nil
(rx-form arg)
(error ""))))
- (eq arg 'word-boundary)
+ (eq arg 'word-boundary)
(and (consp arg)
(memq (car arg) '(not any in syntax category))))
(error "rx `not' syntax error: %s" arg))
@@ -643,14 +653,17 @@ If SKIP is non-nil, allow that number of items after the head, i.e.
(defun rx-** (form)
"Parse and produce code from FORM `(** N M ...)'."
(rx-check form)
- (setq form (cons 'repeat (cdr (rx-trans-forms form 2))))
- (rx-form form '*))
+ (rx-form (cons 'repeat (cdr (rx-trans-forms form 2))) '*))
(defun rx-repeat (form)
"Parse and produce code from FORM.
-FORM is either `(repeat N FORM1)' or `(repeat N M FORM1)'."
+FORM is either `(repeat N FORM1)' or `(repeat N M FORMS...)'."
(rx-check form)
+ (if (> (length form) 4)
+ (setq form (rx-trans-forms form 2)))
+ (if (null (nth 2 form))
+ (setq form (cons (nth 0 form) (cons (nth 1 form) (nthcdr 3 form)))))
(cond ((= (length form) 3)
(unless (and (integerp (nth 1 form))
(> (nth 1 form) 0))
@@ -749,15 +762,18 @@ of all atomic regexps."
"Parse and produce code from FORM, which is `(syntax SYMBOL)'."
(rx-check form)
(let* ((sym (cadr form))
- (syntax (assq sym rx-syntax)))
+ (syntax (cdr (assq sym rx-syntax))))
(unless syntax
;; Try sregex compatibility.
- (let ((name (symbol-name sym)))
- (if (= 1 (length name))
- (setq syntax (rassq (aref name 0) rx-syntax))))
+ (cond
+ ((characterp sym) (setq syntax sym))
+ ((symbolp sym)
+ (let ((name (symbol-name sym)))
+ (if (= 1 (length name))
+ (setq syntax (aref name 0))))))
(unless syntax
- (error "Unknown rx syntax `%s'" (cadr form))))
- (format "\\s%c" (cdr syntax))))
+ (error "Unknown rx syntax `%s'" sym)))
+ (format "\\s%c" syntax)))
(defun rx-check-category (form)
@@ -811,7 +827,7 @@ shy groups around the result and some more in other functions."
(cond ((integerp form)
(regexp-quote (char-to-string form)))
((symbolp form)
- (let ((info (rx-info form)))
+ (let ((info (rx-info form nil)))
(cond ((stringp info)
info)
((null info)
@@ -819,7 +835,7 @@ shy groups around the result and some more in other functions."
(t
(funcall (nth 0 info) form)))))
((consp form)
- (let ((info (rx-info (car form))))
+ (let ((info (rx-info (car form) 'head)))
(unless (consp info)
(error "Unknown rx form `%s'" (car form)))
(funcall (nth 0 info) form)))
@@ -1144,5 +1160,4 @@ enclosed in `(and ...)'.
(provide 'rx)
-;; arch-tag: 12d01a63-0008-42bb-ab8c-1c7d63be370b
;;; rx.el ends here
diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el
index 61daa21fcfa..d5bba20b1cd 100644
--- a/lisp/emacs-lisp/shadow.el
+++ b/lisp/emacs-lisp/shadow.el
@@ -1,7 +1,6 @@
;;; shadow.el --- locate Emacs Lisp file shadowings
-;; Copyright (C) 1995, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 2001-2011 Free Software Foundation, Inc.
;; Author: Terry Jones <terry@santafe.edu>
;; Keywords: lisp
@@ -157,6 +156,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 +267,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 +299,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/smie.el b/lisp/emacs-lisp/smie.el
index 79a2543e1f8..2701d6b940b 100644
--- a/lisp/emacs-lisp/smie.el
+++ b/lisp/emacs-lisp/smie.el
@@ -1,6 +1,6 @@
-;;; smie.el --- Simple Minded Indentation Engine
+;;; smie.el --- Simple Minded Indentation Engine -*- lexical-binding: t -*-
-;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: languages, lisp, internal, parsing, indentation
@@ -178,7 +178,7 @@ one of those elements share the same precedence level and associativity."
;; Maybe also add (or <elem1> <elem2>...) for things like
;; (exp (exp (or "+" "*" "=" ..) exp)).
;; Basically, make it EBNF (except for the specification of a separator in
- ;; the repetition).
+ ;; the repetition, maybe).
(let ((nts (mapcar 'car bnf)) ;Non-terminals
(first-ops-table ())
(last-ops-table ())
@@ -915,7 +915,7 @@ This uses SMIE's tables and is expected to be placed on `post-self-insert-hook'.
;; anything else than this trigger char, lest we'd blink
;; both when inserting the trigger char and when
;; inserting a subsequent trigger char like SPC.
- (or (eq (point) pos)
+ (or (eq (char-before) last-command-event)
(not (memq (char-before)
smie-blink-matching-triggers)))
(or smie-blink-matching-inners
@@ -998,7 +998,10 @@ the beginning of a line."
(unless (numberp (cadr (assoc tok smie-grammar)))
(goto-char pos))
(setq smie--parent
- (smie-backward-sexp 'halfsexp))))))
+ (or (smie-backward-sexp 'halfsexp)
+ (let (res)
+ (while (null (setq res (smie-backward-sexp))))
+ (list nil (point) (nth 2 res)))))))))
(defun smie-rule-parent-p (&rest parents)
"Return non-nil if the current token's parent is among PARENTS.
@@ -1403,6 +1406,10 @@ should not be computed on the basis of the following token."
(and (nth 4 (syntax-ppss))
'noindent))
+(defun smie-indent-inside-string ()
+ (and (nth 3 (syntax-ppss))
+ 'noindent))
+
(defun smie-indent-after-keyword ()
;; Indentation right after a special keyword.
(save-excursion
@@ -1476,8 +1483,9 @@ should not be computed on the basis of the following token."
(defvar smie-indent-functions
'(smie-indent-fixindent smie-indent-bob smie-indent-close
- smie-indent-comment smie-indent-comment-continue smie-indent-comment-close
- smie-indent-comment-inside smie-indent-keyword smie-indent-after-keyword
+ smie-indent-comment smie-indent-comment-continue smie-indent-comment-close
+ smie-indent-comment-inside smie-indent-inside-string
+ smie-indent-keyword smie-indent-after-keyword
smie-indent-exps)
"Functions to compute the indentation.
Each function is called with no argument, shouldn't move point, and should
diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el
index b1a4664f1df..c012e48b590 100644
--- a/lisp/emacs-lisp/syntax.el
+++ b/lisp/emacs-lisp/syntax.el
@@ -1,7 +1,6 @@
;;; syntax.el --- helper functions to find syntactic context
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
@@ -34,7 +33,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 +45,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 +365,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 +403,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 +485,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))))
@@ -300,5 +577,4 @@ Point is at POS when this function returns."
(provide 'syntax)
-;; arch-tag: 302f1eeb-e77c-4680-a8c5-c543e01161a5
;;; syntax.el ends here
diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el
new file mode 100644
index 00000000000..2fdfa9525b1
--- /dev/null
+++ b/lisp/emacs-lisp/tabulated-list.el
@@ -0,0 +1,366 @@
+;;; tabulated-list.el --- generic major mode for tabulated lists.
+
+;; Copyright (C) 2011 Free Software Foundation, Inc.
+
+;; Author: Chong Yidong <cyd@stupidchicken.com>
+;; Keywords: extensions, lisp
+
+;; 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file defines `tabulated-list-mode', a generic major mode for displaying
+;; lists of tabulated data, intended for other major modes to inherit from. It
+;; provides several utility routines, e.g. for pretty-printing lines of
+;; tabulated data to fit into the appropriate columns.
+
+;; For usage information, see the documentation of `tabulated-list-mode'.
+
+;; This package originated from Tom Tromey's Package Menu mode, extended and
+;; generalized to be used by other modes.
+
+;;; Code:
+
+(defvar tabulated-list-format nil
+ "The format of the current Tabulated List mode buffer.
+This should be a vector of elements (NAME WIDTH SORT), where:
+ - NAME is a string describing the column.
+ - WIDTH is the width to reserve for the column.
+ For the final element, its numerical value is ignored.
+ - SORT specifies how to sort entries by this column.
+ If nil, this column cannot be used for sorting.
+ If t, sort by comparing the string value printed in the column.
+ Otherwise, it should be a predicate function suitable for
+ `sort', accepting arguments with the same form as the elements
+ of `tabulated-list-entries'.")
+(make-variable-buffer-local 'tabulated-list-format)
+
+(defvar tabulated-list-entries nil
+ "Entries displayed in the current Tabulated List buffer.
+This should be either a function, or a list.
+If a list, each element has the form (ID [DESC1 ... DESCN]),
+where:
+ - ID is nil, or a Lisp object uniquely identifying this entry,
+ which is used to keep the cursor on the \"same\" entry when
+ rearranging the list. Comparison is done with `equal'.
+
+ - Each DESC is a column descriptor, one for each column
+ specified in `tabulated-list-format'. A descriptor is either
+ a string, which is printed as-is, or a list (LABEL . PROPS),
+ which means to use `insert-text-button' to insert a text
+ button with label LABEL and button properties PROPS.
+ The string, or button label, must not contain any newline.
+
+If `tabulated-list-entries' is a function, it is called with no
+arguments and must return a list of the above form.")
+(make-variable-buffer-local 'tabulated-list-entries)
+
+(defvar tabulated-list-padding 0
+ "Number of characters preceding each Tabulated List mode entry.
+By default, lines are padded with spaces, but you can use the
+function `tabulated-list-put-tag' to change this.")
+(make-variable-buffer-local 'tabulated-list-padding)
+
+(defvar tabulated-list-revert-hook nil
+ "Hook run before reverting a Tabulated List buffer.
+This is commonly used to recompute `tabulated-list-entries'.")
+
+(defvar tabulated-list-printer 'tabulated-list-print-entry
+ "Function for inserting a Tabulated List entry at point.
+It is called with two arguments, ID and COLS. ID is a Lisp
+object identifying the entry, and COLS is a vector of column
+descriptors, as documented in `tabulated-list-entries'.")
+(make-variable-buffer-local 'tabulated-list-printer)
+
+(defvar tabulated-list-sort-key nil
+ "Sort key for the current Tabulated List mode buffer.
+If nil, no additional sorting is performed.
+Otherwise, this should be a cons cell (NAME . FLIP).
+NAME is a string matching one of the column names in
+`tabulated-list-format' (the corresponding SORT entry in
+`tabulated-list-format' then specifies how to sort). FLIP, if
+non-nil, means to invert the resulting sort.")
+(make-variable-buffer-local 'tabulated-list-sort-key)
+
+(defun tabulated-list-get-id (&optional pos)
+ "Obtain the entry ID of the Tabulated List mode entry at POS.
+This is an ID object from `tabulated-list-entries', or nil.
+POS, if omitted or nil, defaults to point."
+ (get-text-property (or pos (point)) 'tabulated-list-id))
+
+(defun tabulated-list-put-tag (tag &optional advance)
+ "Put TAG in the padding area of the current line.
+TAG should be a string, with length <= `tabulated-list-padding'.
+If ADVANCE is non-nil, move forward by one line afterwards."
+ (unless (stringp tag)
+ (error "Invalid argument to `tabulated-list-put-tag'"))
+ (unless (> tabulated-list-padding 0)
+ (error "Unable to tag the current line"))
+ (save-excursion
+ (beginning-of-line)
+ (when (get-text-property (point) 'tabulated-list-id)
+ (let ((beg (point))
+ (inhibit-read-only t))
+ (forward-char tabulated-list-padding)
+ (insert-and-inherit
+ (if (<= (length tag) tabulated-list-padding)
+ (concat tag
+ (make-string (- tabulated-list-padding (length tag))
+ ?\s))
+ (substring tag 0 tabulated-list-padding)))
+ (delete-region beg (+ beg tabulated-list-padding)))))
+ (if advance
+ (forward-line)))
+
+(defvar tabulated-list-mode-map
+ (let ((map (copy-keymap special-mode-map)))
+ (set-keymap-parent map button-buffer-map)
+ (define-key map "n" 'next-line)
+ (define-key map "p" 'previous-line)
+ (define-key map [follow-link] 'mouse-face)
+ (define-key map [mouse-2] 'mouse-select-window)
+ map)
+ "Local keymap for `tabulated-list-mode' buffers.")
+
+(defvar tabulated-list-sort-button-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [header-line mouse-1] 'tabulated-list-col-sort)
+ (define-key map [header-line mouse-2] 'tabulated-list-col-sort)
+ (define-key map [follow-link] 'mouse-face)
+ map)
+ "Local keymap for `tabulated-list-mode' sort buttons.")
+
+(defvar tabulated-list-glyphless-char-display
+ (let ((table (make-char-table 'glyphless-char-display nil)))
+ (set-char-table-parent table glyphless-char-display)
+ ;; Some text terminals can't display the unicode arrows; be safe.
+ (aset table 9650 (cons nil "^"))
+ (aset table 9660 (cons nil "v"))
+ table)
+ "The `glyphless-char-display' table in Tabulated List buffers.")
+
+(defun tabulated-list-init-header ()
+ "Set up header line for the Tabulated List buffer."
+ (let ((x tabulated-list-padding)
+ (button-props `(help-echo "Click to sort by column"
+ mouse-face highlight
+ keymap ,tabulated-list-sort-button-map))
+ (cols nil))
+ (if (> tabulated-list-padding 0)
+ (push (propertize " " 'display `(space :align-to ,x)) cols))
+ (dotimes (n (length tabulated-list-format))
+ (let* ((col (aref tabulated-list-format n))
+ (width (nth 1 col))
+ (label (car col)))
+ (setq x (+ x 1 width))
+ (and (<= tabulated-list-padding 0)
+ (= n 0)
+ (setq label (concat " " label)))
+ (push
+ (cond
+ ;; An unsortable column
+ ((not (nth 2 col)) label)
+ ;; The selected sort column
+ ((equal (car col) (car tabulated-list-sort-key))
+ (apply 'propertize
+ (concat label
+ (cond
+ ((> (+ 2 (length label)) width)
+ "")
+ ((cdr tabulated-list-sort-key)
+ " ▲")
+ (t " ▼")))
+ 'face 'bold
+ 'tabulated-list-column-name (car col)
+ button-props))
+ ;; Unselected sortable column.
+ (t (apply 'propertize label
+ 'tabulated-list-column-name (car col)
+ button-props)))
+ cols))
+ (push (propertize " "
+ 'display (list 'space :align-to x)
+ 'face 'fixed-pitch)
+ cols))
+ (setq header-line-format (mapconcat 'identity (nreverse cols) ""))))
+
+(defun tabulated-list-revert (&rest ignored)
+ "The `revert-buffer-function' for `tabulated-list-mode'.
+It runs `tabulated-list-revert-hook', then calls `tabulated-list-print'."
+ (interactive)
+ (unless (derived-mode-p 'tabulated-list-mode)
+ (error "The current buffer is not in Tabulated List mode"))
+ (run-hooks 'tabulated-list-revert-hook)
+ (tabulated-list-print t))
+
+(defun tabulated-list-print (&optional remember-pos)
+ "Populate the current Tabulated List mode buffer.
+This sorts the `tabulated-list-entries' list if sorting is
+specified by `tabulated-list-sort-key'. It then erases the
+buffer and inserts the entries with `tabulated-list-printer'.
+
+Optional argument REMEMBER-POS, if non-nil, means to move point
+to the entry with the same ID element as the current line."
+ (let ((inhibit-read-only t)
+ (entries (if (functionp 'tabulated-list-entries)
+ (funcall tabulated-list-entries)
+ tabulated-list-entries))
+ entry-id saved-pt saved-col)
+ (and remember-pos
+ (setq entry-id (tabulated-list-get-id))
+ (setq saved-col (current-column)))
+ (erase-buffer)
+ ;; Sort the buffers, if necessary.
+ (when tabulated-list-sort-key
+ (let ((sort-column (car tabulated-list-sort-key))
+ (len (length tabulated-list-format))
+ (n 0)
+ sorter)
+ ;; Which column is to be sorted?
+ (while (and (< n len)
+ (not (equal (car (aref tabulated-list-format n))
+ sort-column)))
+ (setq n (1+ n)))
+ (when (< n len)
+ (setq sorter (nth 2 (aref tabulated-list-format n)))
+ (when (eq sorter t)
+ (setq sorter ; Default sorter checks column N:
+ (lambda (A B)
+ (setq A (aref (cadr A) n))
+ (setq B (aref (cadr B) n))
+ (string< (if (stringp A) A (car A))
+ (if (stringp B) B (car B))))))
+ (setq entries (sort entries sorter))
+ (if (cdr tabulated-list-sort-key)
+ (setq entries (nreverse entries)))
+ (unless (functionp 'tabulated-list-entries)
+ (setq tabulated-list-entries entries)))))
+ ;; Print the resulting list.
+ (dolist (elt entries)
+ (and entry-id
+ (equal entry-id (car elt))
+ (setq saved-pt (point)))
+ (apply tabulated-list-printer elt))
+ (set-buffer-modified-p nil)
+ ;; If REMEMBER-POS was specified, move to the "old" location.
+ (if saved-pt
+ (progn (goto-char saved-pt)
+ (move-to-column saved-col))
+ (goto-char (point-min)))))
+
+(defun tabulated-list-print-entry (id cols)
+ "Insert a Tabulated List entry at point.
+This is the default `tabulated-list-printer' function. ID is a
+Lisp object identifying the entry to print, and COLS is a vector
+of column descriptors."
+ (let ((beg (point))
+ (x (max tabulated-list-padding 0))
+ (len (length tabulated-list-format)))
+ (if (> tabulated-list-padding 0)
+ (insert (make-string x ?\s)))
+ (dotimes (n len)
+ (let* ((format (aref tabulated-list-format n))
+ (desc (aref cols n))
+ (width (nth 1 format))
+ (label (if (stringp desc) desc (car desc)))
+ (help-echo (concat (car format) ": " label)))
+ ;; Truncate labels if necessary.
+ (and (> width 6)
+ (> (length label) width)
+ (setq label (concat (substring label 0 (- width 3))
+ "...")))
+ (if (stringp desc)
+ (insert (propertize label 'help-echo help-echo))
+ (apply 'insert-text-button label (cdr desc)))
+ (setq x (+ x 1 width)))
+ ;; No need to append any spaces if this is the last column.
+ (if (< (1+ n) len)
+ (indent-to x 1)))
+ (insert ?\n)
+ (put-text-property beg (point) 'tabulated-list-id id)))
+
+(defun tabulated-list-col-sort (&optional e)
+ "Sort Tabulated List entries by the column of the mouse click E."
+ (interactive "e")
+ (let* ((pos (event-start e))
+ (obj (posn-object pos))
+ (name (get-text-property (if obj (cdr obj) (posn-point pos))
+ 'tabulated-list-column-name
+ (car obj))))
+ (with-current-buffer (window-buffer (posn-window pos))
+ (when (derived-mode-p 'tabulated-list-mode)
+ ;; Flip the sort order on a second click.
+ (if (equal name (car tabulated-list-sort-key))
+ (setcdr tabulated-list-sort-key
+ (not (cdr tabulated-list-sort-key)))
+ (setq tabulated-list-sort-key (cons name nil)))
+ (tabulated-list-init-header)
+ (tabulated-list-print t)))))
+
+;;; The mode definition:
+
+;;;###autoload
+(define-derived-mode tabulated-list-mode special-mode "Tabulated"
+ "Generic major mode for browsing a list of items.
+This mode is usually not used directly; instead, other major
+modes are derived from it, using `define-derived-mode'.
+
+In this major mode, the buffer is divided into multiple columns,
+which are labelled using the header line. Each non-empty line
+belongs to one \"entry\", and the entries can be sorted according
+to their column values.
+
+An inheriting mode should usually do the following in their body:
+
+ - Set `tabulated-list-format', specifying the column format.
+ - Set `tabulated-list-revert-hook', if the buffer contents need
+ to be specially recomputed prior to `revert-buffer'.
+ - Maybe set a `tabulated-list-entries' function (see below).
+ - Maybe set `tabulated-list-printer' (see below).
+ - Maybe set `tabulated-list-padding'.
+ - Call `tabulated-list-init-header' to initialize `header-line-format'
+ according to `tabulated-list-format'.
+
+An inheriting mode is usually accompanied by a \"list-FOO\"
+command (e.g. `list-packages', `list-processes'). This command
+creates or switches to a buffer and enables the major mode in
+that buffer. If `tabulated-list-entries' is not a function, the
+command should initialize it to a list of entries for displaying.
+Finally, it should call `tabulated-list-print'.
+
+`tabulated-list-print' calls the printer function specified by
+`tabulated-list-printer', once for each entry. The default
+printer is `tabulated-list-print-entry', but a mode that keeps
+data in an ewoc may instead specify a printer function (e.g., one
+that calls `ewoc-enter-last'), with `tabulated-list-print-entry'
+as the ewoc pretty-printer."
+ (setq truncate-lines t)
+ (setq buffer-read-only t)
+ (set (make-local-variable 'revert-buffer-function)
+ 'tabulated-list-revert)
+ (set (make-local-variable 'glyphless-char-display)
+ tabulated-list-glyphless-char-display))
+
+(put 'tabulated-list-mode 'mode-class 'special)
+
+(provide 'tabulated-list)
+
+;; Local Variables:
+;; coding: utf-8
+;; lexical-binding: t
+;; End:
+
+;;; tabulated-list.el ends here
diff --git a/lisp/emacs-lisp/tcover-ses.el b/lisp/emacs-lisp/tcover-ses.el
index f410d153b6e..b91b96b83e5 100644
--- a/lisp/emacs-lisp/tcover-ses.el
+++ b/lisp/emacs-lisp/tcover-ses.el
@@ -1,11 +1,11 @@
;;;; testcover-ses.el -- Example use of `testcover' to test "SES"
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; 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
@@ -721,5 +721,4 @@ spreadsheet files with invalid formatting."
;;Could do this here: (testcover-end "ses.el")
(message "Done"))
-;; arch-tag: 87052ba4-5cf8-46cf-9375-fe245f3360b8
;; testcover-ses.el ends here.
diff --git a/lisp/emacs-lisp/tcover-unsafep.el b/lisp/emacs-lisp/tcover-unsafep.el
index 374a280d9e0..2be026b98eb 100644
--- a/lisp/emacs-lisp/tcover-unsafep.el
+++ b/lisp/emacs-lisp/tcover-unsafep.el
@@ -1,10 +1,11 @@
;;;; testcover-unsafep.el -- Use testcover to test unsafep's code coverage
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; 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.
@@ -137,5 +138,4 @@
(testcover-end "unsafep.el")
(message "Done"))
-;; arch-tag: a7616c27-1998-47ae-9304-76d1439dbf29
;; testcover-unsafep.el ends here.
diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el
index aeefa1bccac..08f757819f2 100644
--- a/lisp/emacs-lisp/testcover.el
+++ b/lisp/emacs-lisp/testcover.el
@@ -1,6 +1,6 @@
;;;; testcover.el -- Visual code-coverage tool
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Jonathan Yavner <jyavner@member.fsf.org>
;; Maintainer: Jonathan Yavner <jyavner@member.fsf.org>
@@ -534,5 +534,4 @@ coverage tests. This function creates many overlays."
(goto-char (next-overlay-change (point)))
(end-of-line))
-;; arch-tag: 72324a4a-4a2e-4142-9249-cc56d6757588
;; testcover.el ends here.
diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el
index 16d1af331fa..5f069226aa9 100644
--- a/lisp/emacs-lisp/timer.el
+++ b/lisp/emacs-lisp/timer.el
@@ -1,9 +1,9 @@
;;; timer.el --- run a function with args at some time in future
-;; Copyright (C) 1996, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -92,31 +92,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 +310,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 +431,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 +442,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 +531,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/tq.el b/lisp/emacs-lisp/tq.el
index f310609ec11..3d3b371ad5c 100644
--- a/lisp/emacs-lisp/tq.el
+++ b/lisp/emacs-lisp/tq.el
@@ -1,7 +1,6 @@
;;; tq.el --- utility to maintain a transaction queue
-;; Copyright (C) 1985, 1986, 1987, 1992, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1987, 1992, 2001-2011 Free Software Foundation, Inc.
;; Author: Scott Draves <spot@cs.cmu.edu>
;; Maintainer: FSF
@@ -167,5 +166,4 @@ This produces more reliable results with some processes."
(provide 'tq)
-;; arch-tag: 65dea08c-4edd-4cde-83a5-e8a15b993b79
;;; tq.el ends here
diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el
index 77b8e1e118d..22c1f0e7ea7 100644
--- a/lisp/emacs-lisp/trace.el
+++ b/lisp/emacs-lisp/trace.el
@@ -1,7 +1,6 @@
;;; trace.el --- tracing facility for Emacs Lisp functions
-;; Copyright (C) 1993, 1998, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1998, 2000-2011 Free Software Foundation, Inc.
;; Author: Hans Chalupsky <hans@cs.buffalo.edu>
;; Maintainer: FSF
@@ -299,5 +298,4 @@ was not traced this is a noop."
(provide 'trace)
-;; arch-tag: cfd170a7-4932-4331-8c8b-b7151942e5a1
;;; trace.el ends here
diff --git a/lisp/emacs-lisp/unsafep.el b/lisp/emacs-lisp/unsafep.el
index 69c9569d685..0f08d77d4c3 100644
--- a/lisp/emacs-lisp/unsafep.el
+++ b/lisp/emacs-lisp/unsafep.el
@@ -1,6 +1,6 @@
;;;; unsafep.el -- Determine whether a Lisp form is safe to evaluate
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Jonathan Yavner <jyavner@member.fsf.org>
;; Maintainer: Jonathan Yavner <jyavner@member.fsf.org>
@@ -202,6 +202,9 @@ UNSAFEP-VARS is a list of symbols with local bindings."
(dolist (x (nthcdr 3 form))
(setq reason (unsafep-progn (cdr x)))
(if reason (throw 'unsafep reason))))))
+ ((eq fun '\`)
+ ;; Backquoted form - safe if its expansion is.
+ (unsafep (cdr (backquote-process (cadr form)))))
(t
;;First unsafep-function call above wasn't nil, no special case applies
reason)))))
@@ -258,5 +261,4 @@ If TO-BIND is t, check whether SYM is safe to bind."
(local-variable-p sym)))
`(global-variable ,sym))))
-;; arch-tag: 6216f98b-eb8f-467a-9c33-7a7644f50658
;;; unsafep.el ends here
diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el
index 180296fb925..7f3657bbbe6 100644
--- a/lisp/emacs-lisp/warnings.el
+++ b/lisp/emacs-lisp/warnings.el
@@ -1,6 +1,6 @@
;;; warnings.el --- log and display warnings
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
@@ -64,8 +64,8 @@ Level :debug is ignored by default (see `warning-minimum-level').")
(critical . :emergency)
(alarm . :emergency))
"Alist of aliases for severity levels for `display-warning'.
-Each element looks like (ALIAS . LEVEL) and defines
-ALIAS as equivalent to LEVEL. LEVEL must be defined in `warning-levels';
+Each element looks like (ALIAS . LEVEL) and defines ALIAS as
+equivalent to LEVEL. LEVEL must be defined in `warning-levels';
it may not itself be an alias.")
(defcustom warning-minimum-level :warning
@@ -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,30 +132,30 @@ 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.
A marker indicates a position in the warnings buffer
which is the start of the current series; it means that
additional warnings in the same buffer should not move point.
-t means the next warning begins a series (and stores a marker here).
+If t, the next warning begins a series (and stores a marker here).
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.
@@ -235,12 +235,14 @@ See also `warning-series', `warning-prefix-function' and
(warning-suppress-p type warning-suppress-log-types)
(let* ((typename (if (consp type) (car type) type))
(old (get-buffer buffer-name))
- (buffer (get-buffer-create buffer-name))
+ (buffer (or old (get-buffer-create buffer-name)))
(level-info (assq level warning-levels))
start end)
(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,60 +250,61 @@ See also `warning-series', `warning-prefix-function' and
(prog1 (point-marker)
(unless (eq warning-series t)
(funcall warning-series)))))
- (unless (bolp)
- (newline))
- (setq start (point))
- (if warning-prefix-function
- (setq level-info (funcall warning-prefix-function
- level level-info)))
- (insert (format (nth 1 level-info)
- (format warning-type-format typename))
- message)
- (newline)
- (when (and warning-fill-prefix (not (string-match "\n" message)))
- (let ((fill-prefix warning-fill-prefix)
- (fill-column 78))
- (fill-region start (point))))
- (setq end (point))
+ (let ((inhibit-read-only t))
+ (unless (bolp)
+ (newline))
+ (setq start (point))
+ (if warning-prefix-function
+ (setq level-info (funcall warning-prefix-function
+ level level-info)))
+ (insert (format (nth 1 level-info)
+ (format warning-type-format typename))
+ message)
+ (newline)
+ (when (and warning-fill-prefix (not (string-match "\n" message)))
+ (let ((fill-prefix warning-fill-prefix)
+ (fill-column 78))
+ (fill-region start (point))))
+ (setq end (point)))
(when (and (markerp warning-series)
(eq (marker-buffer warning-series) buffer))
(goto-char warning-series)))
(if (nth 2 level-info)
(funcall (nth 2 level-info)))
- (cond (noninteractive
- ;; Noninteractively, take the text we inserted
- ;; in the warnings buffer and print it.
- ;; Do this unconditionally, since there is no way
- ;; to view logged messages unless we output them.
- (with-current-buffer buffer
- (save-excursion
- ;; Don't include the final newline in the arg
- ;; to `message', because it adds a newline.
- (goto-char end)
- (if (bolp)
- (forward-char -1))
- (message "%s" (buffer-substring start (point))))))
- ((and (daemonp) (null after-init-time))
- ;; Warnings assigned during daemon initialization go into
- ;; the messages buffer.
- (message "%s"
- (with-current-buffer buffer
- (save-excursion
- (goto-char end)
- (if (bolp)
- (forward-char -1))
- (buffer-substring start (point))))))
- (t
- ;; Interactively, decide whether the warning merits
- ;; immediate display.
- (or (< (warning-numeric-level level)
- (warning-numeric-level warning-minimum-level))
- (warning-suppress-p type warning-suppress-types)
- (let ((window (display-buffer buffer)))
- (when (and (markerp warning-series)
- (eq (marker-buffer warning-series) buffer))
- (set-window-start window warning-series))
- (sit-for 0))))))))
+ (cond (noninteractive
+ ;; Noninteractively, take the text we inserted
+ ;; in the warnings buffer and print it.
+ ;; Do this unconditionally, since there is no way
+ ;; to view logged messages unless we output them.
+ (with-current-buffer buffer
+ (save-excursion
+ ;; Don't include the final newline in the arg
+ ;; to `message', because it adds a newline.
+ (goto-char end)
+ (if (bolp)
+ (forward-char -1))
+ (message "%s" (buffer-substring start (point))))))
+ ((and (daemonp) (null after-init-time))
+ ;; Warnings assigned during daemon initialization go into
+ ;; the messages buffer.
+ (message "%s"
+ (with-current-buffer buffer
+ (save-excursion
+ (goto-char end)
+ (if (bolp)
+ (forward-char -1))
+ (buffer-substring start (point))))))
+ (t
+ ;; Interactively, decide whether the warning merits
+ ;; immediate display.
+ (or (< (warning-numeric-level level)
+ (warning-numeric-level warning-minimum-level))
+ (warning-suppress-p type warning-suppress-types)
+ (let ((window (display-buffer buffer)))
+ (when (and (markerp warning-series)
+ (eq (marker-buffer warning-series) buffer))
+ (set-window-start window warning-series))
+ (sit-for 0))))))))
;;;###autoload
(defun lwarn (type level message &rest args)
@@ -334,5 +337,4 @@ this is equivalent to `display-warning', using
(provide 'warnings)
-;; arch-tag: faaad1c8-7b2a-4161-af38-5ab4afde0496
;;; warnings.el ends here
diff --git a/lisp/emacs-lock.el b/lisp/emacs-lock.el
index bf6b4446bf6..1553aeae0d5 100644
--- a/lisp/emacs-lock.el
+++ b/lisp/emacs-lock.el
@@ -1,7 +1,6 @@
;;; emacs-lock.el --- prevents you from exiting Emacs if a buffer is locked
-;; Copyright (C) 1994, 1997, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc
+;; Copyright (C) 1994, 1997, 2001-2011 Free Software Foundation, Inc
;; Author: Tom Wurgler <twurgler@goodyear.com>
;; Created: 12/8/94
@@ -77,7 +76,7 @@ If the buffer is locked, signal error and display its name."
(set-process-sentinel
(get-buffer-process (buffer-name)) (function emacs-lock-clear-sentinel)))
-(defun emacs-lock-clear-sentinel (proc str)
+(defun emacs-lock-clear-sentinel (_proc _str)
(if emacs-lock-from-exiting
(progn
(setq emacs-lock-from-exiting nil)
@@ -89,7 +88,8 @@ If the buffer is locked, signal error and display its name."
(if emacs-lock-buffer-locked
(setq emacs-lock-from-exiting t)))
-(add-hook 'kill-emacs-hook 'check-emacs-lock)
+(unless noninteractive
+ (add-hook 'kill-emacs-hook 'check-emacs-lock))
(add-hook 'kill-buffer-hook 'emacs-lock-check-buffer-lock)
(add-hook 'shell-mode-hook 'emacs-lock-was-buffer-locked)
(add-hook 'shell-mode-hook 'emacs-lock-shell-sentinel)
@@ -98,5 +98,4 @@ If the buffer is locked, signal error and display its name."
(provide 'emacs-lock)
-;; arch-tag: 58e6cb43-7cf0-401a-bcb6-4902a0b8bdc1
;;; emacs-lock.el ends here
diff --git a/lisp/emulation/crisp.el b/lisp/emulation/crisp.el
index 09e48b0a4c1..b2806e8f8eb 100644
--- a/lisp/emulation/crisp.el
+++ b/lisp/emulation/crisp.el
@@ -1,7 +1,6 @@
;;; crisp.el --- CRiSP/Brief Emacs emulator
-;; Copyright (C) 1997, 1998, 1999, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-1999, 2001-2011 Free Software Foundation, Inc.
;; Author: Gary D. Foster <Gary.Foster@Corp.Sun.COM>
;; Keywords: emulations brief crisp
@@ -175,7 +174,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 +194,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."
@@ -381,5 +380,4 @@ With ARG, turn CRiSP mode on if ARG is positive, off otherwise."
(run-hooks 'crisp-load-hook)
(provide 'crisp)
-;; arch-tag: e5369375-fafb-4240-b7ae-4cb460ef05ee
;;; crisp.el ends here
diff --git a/lisp/emulation/cua-base.el b/lisp/emulation/cua-base.el
index 60ebefdd155..b643d521ad6 100644
--- a/lisp/emulation/cua-base.el
+++ b/lisp/emulation/cua-base.el
@@ -1,7 +1,6 @@
;;; cua-base.el --- emulate CUA key bindings
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2011 Free Software Foundation, Inc.
;; Author: Kim F. Storm <storm@cua.dk>
;; Keywords: keyboard emulations convenience cua
@@ -270,7 +269,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 +280,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 +299,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 +313,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 +324,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 +338,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 +352,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 +386,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 +394,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 +426,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 +436,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 +464,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 +477,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 +515,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 +539,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 +563,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 +778,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 +1041,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
""))
@@ -1436,10 +1437,13 @@ If ARG is the atom `-', scroll upward by nearly full screen."
(define-key cua-global-keymap [remap yank-pop] 'cua-paste-pop)
;; set mark
(define-key cua-global-keymap [remap set-mark-command] 'cua-set-mark)
+ (define-key cua-global-keymap [remap exchange-point-and-mark] 'cua-exchange-point-and-mark)
;; 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)
@@ -1448,7 +1452,6 @@ If ARG is the atom `-', scroll upward by nearly full screen."
(when cua-remap-control-v
(define-key cua--cua-keys-keymap [(control v)] 'yank)
(define-key cua--cua-keys-keymap [(meta v)] 'cua-repeat-replace-region))
- (define-key cua--cua-keys-keymap [remap exchange-point-and-mark] 'cua-exchange-point-and-mark)
(define-key cua--prefix-override-keymap [(control x)] 'cua--prefix-override-handler)
(define-key cua--prefix-override-keymap [(control c)] 'cua--prefix-override-handler)
@@ -1492,6 +1495,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 +1504,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
@@ -1512,6 +1518,9 @@ If ARG is the atom `-', scroll upward by nearly full screen."
c-beginning-of-statement c-end-of-statement))
(put cmd 'CUA 'move))
+;; Only called if pc-selection-mode is t, which means pc-select is loaded.
+(declare-function pc-selection-mode "pc-select" (&optional arg))
+
;; State prior to enabling cua-mode
;; Value is a list with the following elements:
;; transient-mark-mode
@@ -1618,7 +1627,11 @@ shifted movement key, set `cua-highlight-region-shift-only'."
"Enable CUA selection mode without the C-z/C-x/C-c/C-v bindings."
(interactive "P")
(setq-default cua-enable-cua-keys nil)
- (cua-mode arg))
+ (if (not (called-interactively-p 'any))
+ (cua-mode arg)
+ ;; Use call-interactive to turn a nil prefix arg into `toggle'.
+ (call-interactively 'cua-mode)
+ (customize-mark-as-set 'cua-enable-cua-keys)))
(defun cua-debug ()
@@ -1629,5 +1642,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 a7fe1e27a5d..690555e81dc 100644
--- a/lisp/emulation/cua-gmrk.el
+++ b/lisp/emulation/cua-gmrk.el
@@ -1,10 +1,10 @@
;;; cua-gmrk.el --- CUA unified global mark support
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2011 Free Software Foundation, Inc.
;; 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 +137,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 +161,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))
@@ -380,5 +380,4 @@ With prefix argument, don't jump to global mark when cancelling it."
(provide 'cua-gmrk)
-;; arch-tag: 553d8076-a91d-48ae-825d-6cb962a5f67f
;;; cua-gmrk.el ends here
diff --git a/lisp/emulation/cua-rect.el b/lisp/emulation/cua-rect.el
index 7f6067f573e..62ae3ffa7d5 100644
--- a/lisp/emulation/cua-rect.el
+++ b/lisp/emulation/cua-rect.el
@@ -1,10 +1,10 @@
;;; cua-rect.el --- CUA unified rectangle support
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2011 Free Software Foundation, Inc.
;; Author: Kim F. Storm <storm@cua.dk>
;; Keywords: keyboard emulations convenience CUA
+;; Package: cua-base
;; This file is part of GNU Emacs.
@@ -625,7 +625,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 +643,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 +1124,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 +1344,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 +1432,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)
@@ -1489,5 +1491,4 @@ With prefix arg, indent to that column."
(provide 'cua-rect)
-;; arch-tag: b730df53-17b9-4a89-bd63-4a71ec196731
;;; cua-rect.el ends here
diff --git a/lisp/emulation/edt-lk201.el b/lisp/emulation/edt-lk201.el
index eb9a75bcac9..6132b455faf 100644
--- a/lisp/emulation/edt-lk201.el
+++ b/lisp/emulation/edt-lk201.el
@@ -1,11 +1,12 @@
;;; edt-lk201.el --- enhanced EDT keypad mode emulation for LK-201 keyboards
-;; Copyright (C) 1986, 1992, 1993, 1995, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1986, 1992-1993, 1995, 2001-2011
+;; Free Software Foundation, Inc.
;; 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.
@@ -56,5 +57,4 @@
("HELP" . [help]) ("DO" . [menu]) ("F17" . [f17]) ("F18" . [f18])
("F19" . [f19]) ("F20" . [f20])))
-;; arch-tag: 36f498cf-c3f6-41b0-911b-83b1348855ec
;;; edt-lk201.el ends here
diff --git a/lisp/emulation/edt-mapper.el b/lisp/emulation/edt-mapper.el
index 64120686f24..99d204692fa 100644
--- a/lisp/emulation/edt-mapper.el
+++ b/lisp/emulation/edt-mapper.el
@@ -1,11 +1,11 @@
;;; edt-mapper.el --- create an EDT LK-201 map file for X-Windows Emacs
-;; Copyright (C) 1994, 1995, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1995, 2000-2011 Free Software Foundation, Inc.
;; 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.
@@ -546,5 +546,4 @@
(sit-for 600)
(kill-emacs t)
-;; arch-tag: 9eea59c8-b8b7-4d66-b858-c8920624c518
;;; edt-mapper.el ends here
diff --git a/lisp/emulation/edt-pc.el b/lisp/emulation/edt-pc.el
index b775ec438b5..a51ecd34045 100644
--- a/lisp/emulation/edt-pc.el
+++ b/lisp/emulation/edt-pc.el
@@ -1,11 +1,11 @@
;;; edt-pc.el --- enhanced EDT keypad mode emulation for PC 101 keyboards
-;; Copyright (C) 1986, 1994, 1995, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1986, 1994-1995, 2001-2011 Free Software Foundation, Inc.
;; 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.
@@ -86,5 +86,4 @@
("HELP" . "" ) ("DO" . "" ) ("F17" . "" ) ("F18" . "" )
("F19" . "" ) ("F20" . "" )))
-;; arch-tag: 4593d053-183a-4062-97de-57b8877595ce
;;; edt-pc.el ends here
diff --git a/lisp/emulation/edt-vt100.el b/lisp/emulation/edt-vt100.el
index 59ff1e6e5de..1dca1f19dfc 100644
--- a/lisp/emulation/edt-vt100.el
+++ b/lisp/emulation/edt-vt100.el
@@ -1,11 +1,12 @@
;;; edt-vt100.el --- enhanced EDT keypad mode emulation for VT series terminals
-;; Copyright (C) 1986, 1992, 1993, 1995, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1986, 1992-1993, 1995, 2002-2011
+;; Free Software Foundation, Inc.
;; 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.
@@ -47,5 +48,4 @@
"Set terminal width to 132 columns."
(vt100-wide-mode 1))
-;; arch-tag: c9f10c95-915f-44b5-93ff-4654abca4dd4
;;; edt-vt100.el ends here
diff --git a/lisp/emulation/edt.el b/lisp/emulation/edt.el
index 3e746cb0346..68550cc30e2 100644
--- a/lisp/emulation/edt.el
+++ b/lisp/emulation/edt.el
@@ -1,7 +1,6 @@
-;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1986, 1992-1995, 2000-2011 Free Software Foundation, Inc.
;; Author: Kevin Gallagher <Kevin.Gallagher@boeing.com>
;; Maintainer: Kevin Gallagher <Kevin.Gallagher@boeing.com>
@@ -27,7 +26,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 +87,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 +192,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 +202,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 +211,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 +236,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 +665,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 +692,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 +733,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 +819,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 +1278,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 +1296,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 +1320,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 +1339,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 +1960,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 +2466,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 +2580,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 +2604,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/keypad.el b/lisp/emulation/keypad.el
index b634cc21c27..0156e54f90f 100644
--- a/lisp/emulation/keypad.el
+++ b/lisp/emulation/keypad.el
@@ -1,7 +1,6 @@
;;; keypad.el --- simplified keypad bindings
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Kim F. Storm <storm@cua.dk>
;; Keywords: keyboard convenience
@@ -270,5 +269,4 @@ the decimal key on the keypad is mapped to DECIMAL instead of `.'"
(setq i (1+ i)))))
-;; arch-tag: 0899d2bd-9e12-4b4e-9aef-d0014d3b6414
;;; keypad.el ends here
diff --git a/lisp/emulation/pc-select.el b/lisp/emulation/pc-select.el
deleted file mode 100644
index 09b999b2298..00000000000
--- a/lisp/emulation/pc-select.el
+++ /dev/null
@@ -1,985 +0,0 @@
-;;; pc-select.el --- emulate mark, cut, copy and paste from Motif
-;;; (or MAC GUI or MS-windoze (bah)) look-and-feel
-;;; including key bindings.
-
-;; Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
-
-;; Author: Michael Staats <michael@thp.Uni-Duisburg.DE>
-;; Keywords: convenience emulations
-;; Created: 26 Sep 1995
-
-;; 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 emulates the mark, copy, cut and paste look-and-feel of motif
-;; programs (which is the same as the MAC gui and (sorry for that) MS-Windows).
-;; It modifies the keybindings of the cursor keys and the next, prior,
-;; home and end keys. They will modify mark-active.
-;; You can still get the old behavior of cursor moving with the
-;; control sequences C-f, C-b, etc.
-;; This package uses transient-mark-mode and
-;; delete-selection-mode.
-;;
-;; In addition to that all key-bindings from the pc-mode are
-;; done here too (as suggested by RMS).
-;;
-;; As I found out after I finished the first version, s-region.el tries
-;; to do the same.... But my code is a little more complete and using
-;; delete-selection-mode is very important for the look-and-feel.
-;; Pete Forman <pete.forman@airgun.wg.waii.com> provided some motif
-;; compliant keybindings which I added. I had to modify them a little
-;; to add the -mark and -nomark functionality of cursor moving.
-;;
-;; Credits:
-;; Many thanks to all who made comments.
-;; Thanks to RMS and Ralf Muschall <prm@rz.uni-jena.de> for criticism.
-;; Kevin Cutts <cutts@ukraine.corp.mot.com> added the beginning-of-buffer
-;; and end-of-buffer functions which I modified a little.
-;; David Biesack <sasdjb@unx.sas.com> suggested some more cleanup.
-;; Thanks to Pete Forman <pete.forman@airgun.wg.waii.com>
-;; for additional motif keybindings.
-;; Thanks to jvromans@squirrel.nl (Johan Vromans) for a bug report
-;; concerning setting of this-command.
-;; Dan Nicolaescu <done@ece.arizona.ro> suggested suppressing the
-;; scroll-up/scroll-down error.
-;; Eli Barzilay (eli@cs.bgu.ac.il) suggested the sexps functions and
-;; keybindings.
-;;
-;; Ok, some details about the idea of PC Selection mode:
-;;
-;; o The standard keys for moving around (right, left, up, down, home, end,
-;; prior, next, called "move-keys" from now on) will always de-activate
-;; the mark.
-;; o If you press "Shift" together with the "move-keys", the region
-;; you pass along is activated
-;; o You have the copy, cut and paste functions (as in many other programs)
-;; which will operate on the active region
-;; It was not possible to bind them to C-v, C-x and C-c for obvious
-;; emacs reasons.
-;; They will be bound according to the "old" behavior to S-delete (cut),
-;; S-insert (paste) and C-insert (copy). These keys do the same in many
-;; other programs.
-;;
-
-;;; Code:
-
-;; Customization:
-(defgroup pc-select nil
- "Emulate pc bindings."
- :prefix "pc-select"
- :group 'editing-basics
- :group 'convenience)
-
-(defcustom pc-select-override-scroll-error t
- "*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
-text with these commands. If you set this variable to non-nil, these
-errors are suppressed."
- :type 'boolean
- :group 'pc-select)
-
-(defcustom pc-select-selection-keys-only nil
- "*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."
- :type 'boolean
- :group 'pc-select)
-
-(defcustom pc-selection-mode-hook nil
- "The hook to run when PC Selection mode is toggled."
- :type 'hook
- :group 'pc-select)
-
-(defvar pc-select-saved-settings-alist nil
- "The values of the variables before PC Selection mode was toggled on.
-When PC Selection mode is toggled on, it sets quite a few variables
-for its own purposes. This alist holds the original values of the
-variables PC Selection mode had set, so that these variables can be
-restored to their original values when PC Selection mode is toggled off.")
-
-(defvar pc-select-map nil
- "The keymap used as the global map when PC Selection mode is on." )
-
-(defvar pc-select-saved-global-map nil
- "The global map that was in effect when PC Selection mode was toggled on.")
-
-(defvar pc-select-key-bindings-alist nil
- "This alist holds all the key bindings PC Selection mode sets.")
-
-(defvar pc-select-default-key-bindings nil
- "These key bindings always get set by PC Selection mode.")
-
-(unless pc-select-default-key-bindings
- (let ((lst
- ;; This is to avoid confusion with the delete-selection-mode.
- ;; On simple displays you can't see that a region is active and
- ;; will be deleted on the next keypress IMHO especially for
- ;; copy-region-as-kill this is confusing.
- ;; The same goes for exchange-point-and-mark
- '(("\M-w" . copy-region-as-kill-nomark)
- ("\C-x\C-x" . exchange-point-and-mark-nomark)
- ([S-right] . forward-char-mark)
- ([right] . forward-char-nomark)
- ([C-S-right] . forward-word-mark)
- ([C-right] . forward-word-nomark)
- ([S-left] . backward-char-mark)
- ([left] . backward-char-nomark)
- ([C-S-left] . backward-word-mark)
- ([C-left] . backward-word-nomark)
- ([S-down] . next-line-mark)
- ([down] . next-line-nomark)
-
- ([S-end] . end-of-line-mark)
- ([end] . end-of-line-nomark)
- ([S-C-end] . end-of-buffer-mark)
- ([C-end] . end-of-buffer-nomark)
- ([S-M-end] . end-of-buffer-mark)
- ([M-end] . end-of-buffer-nomark)
-
- ([S-next] . scroll-up-mark)
- ([next] . scroll-up-nomark)
-
- ([S-up] . previous-line-mark)
- ([up] . previous-line-nomark)
-
- ([S-home] . beginning-of-line-mark)
- ([home] . beginning-of-line-nomark)
- ([S-C-home] . beginning-of-buffer-mark)
- ([C-home] . beginning-of-buffer-nomark)
- ([S-M-home] . beginning-of-buffer-mark)
- ([M-home] . beginning-of-buffer-nomark)
-
- ([M-S-down] . forward-line-mark)
- ([M-down] . forward-line-nomark)
- ([M-S-up] . backward-line-mark)
- ([M-up] . backward-line-nomark)
-
- ([S-prior] . scroll-down-mark)
- ([prior] . scroll-down-nomark)
-
- ;; Next four lines are from Pete Forman.
- ([C-down] . forward-paragraph-nomark) ; KNextPara cDn
- ([C-up] . backward-paragraph-nomark) ; KPrevPara cUp
- ([S-C-down] . forward-paragraph-mark)
- ([S-C-up] . backward-paragraph-mark))))
-
- (setq pc-select-default-key-bindings lst)))
-
-(defvar pc-select-extra-key-bindings nil
- "Key bindings to set only if `pc-select-selection-keys-only' is nil.")
-
-;; The following keybindings are for standard ISO keyboards
-;; as they are used with IBM compatible PCs, IBM RS/6000,
-;; MACs, many X-Stations and probably more
-(unless pc-select-extra-key-bindings
- (let ((lst
- '(([S-insert] . yank)
- ([C-insert] . copy-region-as-kill)
- ([S-delete] . kill-region)
-
- ;; The following bindings are useful on Sun Type 3 keyboards
- ;; They implement the Get-Delete-Put (copy-cut-paste)
- ;; functions from sunview on the L6, L8 and L10 keys
- ;; Sam Steingold <sds@gnu.org> says that f16 is copy and f18 is paste.
- ([f16] . copy-region-as-kill)
- ([f18] . yank)
- ([f20] . kill-region)
-
- ;; The following bindings are from Pete Forman.
- ([f6] . other-window) ; KNextPane F6
- ([C-delete] . kill-line) ; KEraseEndLine cDel
- ("\M-\d" . undo) ; KUndo aBS
-
- ;; The following binding is taken from pc-mode.el
- ;; as suggested by RMS.
- ;; I only used the one that is not covered above.
- ([C-M-delete] . kill-sexp)
- ;; Next line proposed by Eli Barzilay
- ([C-escape] . electric-buffer-list))))
-
- (setq pc-select-extra-key-bindings lst)))
-
-(defvar pc-select-meta-moves-sexps-key-bindings
- '((([M-S-right] . forward-sexp-mark)
- ([M-right] . forward-sexp-nomark)
- ([M-S-left] . backward-sexp-mark)
- ([M-left] . backward-sexp-nomark))
- (([M-S-right] . forward-word-mark)
- ([M-right] . forward-word-nomark)
- ([M-S-left] . backward-word-mark)
- ([M-left] . backward-word-nomark)))
- "The list of key bindings controlled by `pc-select-meta-moves-sexp'.
-The bindings in the car of this list get installed if
-`pc-select-meta-moves-sexp' is t, the bindings in the cadr of this
-list get installed otherwise.")
-
-;; This is for tty. We don't turn on normal-erase-is-backspace,
-;; but bind keys as pc-selection-mode did before
-;; normal-erase-is-backspace was invented, to keep us back
-;; compatible.
-(defvar pc-select-tty-key-bindings
- '(([delete] . delete-char) ; KDelete Del
- ([C-backspace] . backward-kill-word))
- "The list of key bindings controlled by `pc-select-selection-keys-only'.
-These key bindings get installed when running in a tty, but only if
-`pc-select-selection-keys-only' is nil.")
-
-(defvar pc-select-old-M-delete-binding nil
- "Holds the old mapping of [M-delete] in the `function-key-map'.
-This variable holds the value associated with [M-delete] in the
-`function-key-map' before PC Selection mode had changed that
-association.")
-
-;;;;
-;; misc
-;;;;
-
-(provide 'pc-select)
-
-(defun copy-region-as-kill-nomark (beg end)
- "Save the region as if killed, but don't kill it; deactivate mark.
-If `interprogram-cut-function' is non-nil, also save the text for a window
-system cut and paste.
-
-Deactivating mark is to avoid confusion with `delete-selection-mode'
-and `transient-mark-mode'."
- (interactive "r")
- (copy-region-as-kill beg end)
- (setq mark-active nil)
- (message "Region saved"))
-
-(defun exchange-point-and-mark-nomark ()
- "Like `exchange-point-and-mark' but without activating the mark."
- (interactive)
- (exchange-point-and-mark)
- (setq mark-active nil))
-
-;;;;
-;; non-interactive
-;;;;
-(defun pc-select-ensure-mark ()
- ;; make sure mark is active
- ;; test if it is active, if it isn't, set it and activate it
- (or mark-active (set-mark-command nil))
- ;; Remember who activated the mark.
- (setq mark-active 'pc-select))
-
-(defun pc-select-maybe-deactivate-mark ()
- ;; maybe switch off mark (only if *we* switched it on)
- (when (eq mark-active 'pc-select)
- (deactivate-mark)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;; forward and mark
-;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun forward-char-mark (&optional arg)
- "Ensure mark is active; move point right ARG characters (left if ARG negative).
-On reaching end of buffer, stop and signal error."
- (interactive "p")
- (pc-select-ensure-mark)
- (forward-char arg))
-
-(defun forward-word-mark (&optional arg)
- "Ensure mark is active; move point right ARG words (backward if ARG is negative).
-Normally returns t.
-If an edge of the buffer is reached, point is left there
-and nil is returned."
- (interactive "p")
- (pc-select-ensure-mark)
- (forward-word arg))
-
-(defun forward-line-mark (&optional arg)
- "Ensure mark is active; move cursor vertically down ARG lines."
- (interactive "p")
- (pc-select-ensure-mark)
- (forward-line arg)
- (setq this-command 'forward-line)
-)
-
-(defun forward-sexp-mark (&optional arg)
- "Ensure mark is active; move forward across one balanced expression (sexp).
-With argument, do it that many times. Negative arg -N means
-move backward across N balanced expressions."
- (interactive "p")
- (pc-select-ensure-mark)
- (forward-sexp arg))
-
-(defun forward-paragraph-mark (&optional arg)
- "Ensure mark is active; move forward to end of paragraph.
-With arg N, do it N times; negative arg -N means move backward N paragraphs.
-
-A line which `paragraph-start' matches either separates paragraphs
-\(if `paragraph-separate' matches it also) or is the first line of a paragraph.
-A paragraph end is the beginning of a line which is not part of the paragraph
-to which the end of the previous line belongs, or the end of the buffer."
- (interactive "p")
- (pc-select-ensure-mark)
- (forward-paragraph arg))
-
-(defun next-line-mark (&optional arg)
- "Ensure mark is active; move cursor vertically down ARG lines.
-If there is no character in the target line exactly under the current column,
-the cursor is positioned after the character in that line which spans this
-column, or at the end of the line if it is not long enough.
-If there is no line in the buffer after this one, behavior depends on the
-value of `next-line-add-newlines'. If non-nil, it inserts a newline character
-to create a line, and moves the cursor to that line. Otherwise it moves the
-cursor to the end of the buffer \(if already at the end of the buffer, an error
-is signaled).
-
-The command \\[set-goal-column] can be used to create
-a semipermanent goal column to which this command always moves.
-Then it does not try to move vertically. This goal column is stored
-in `goal-column', which is nil when there is none."
- (interactive "p")
- (pc-select-ensure-mark)
- (with-no-warnings (next-line arg))
- (setq this-command 'next-line))
-
-(defun end-of-line-mark (&optional arg)
- "Ensure mark is active; move point to end of current line.
-With argument ARG not nil or 1, move forward ARG - 1 lines first.
-If scan reaches end of buffer, stop there without error."
- (interactive "p")
- (pc-select-ensure-mark)
- (end-of-line arg)
- (setq this-command 'end-of-line))
-
-(defun backward-line-mark (&optional arg)
- "Ensure mark is active; move cursor vertically up ARG lines."
- (interactive "p")
- (pc-select-ensure-mark)
- (if (null arg)
- (setq arg 1))
- (forward-line (- arg))
- (setq this-command 'forward-line)
-)
-
-(defun scroll-down-mark (&optional arg)
- "Ensure mark is active; scroll down ARG lines; or near full screen if no ARG.
-A near full screen is `next-screen-context-lines' less than a full screen.
-Negative ARG means scroll upward.
-When calling from a program, supply a number as argument or nil.
-Attempting to scroll past the edge of buffer does not raise an
-error, unless `pc-select-override-scroll-error' is nil."
- (interactive "P")
- (pc-select-ensure-mark)
- (cond (pc-select-override-scroll-error
- (condition-case nil (scroll-down arg)
- (beginning-of-buffer (goto-char (point-min)))))
- (t (scroll-down arg))))
-
-(defun end-of-buffer-mark (&optional arg)
- "Ensure mark is active; move point to the end of the buffer.
-With arg N, put point N/10 of the way from the end.
-
-If the buffer is narrowed, this command uses the beginning and size
-of the accessible part of the buffer.
-
-Don't use this command in Lisp programs!
-\(goto-char \(point-max)) is faster and avoids clobbering the mark."
- (interactive "P")
- (pc-select-ensure-mark)
- (let ((size (- (point-max) (point-min))))
- (goto-char (if arg
- (- (point-max)
- (if (> size 10000)
- ;; Avoid overflow for large buffer sizes!
- (* (prefix-numeric-value arg)
- (/ size 10))
- (/ (* size (prefix-numeric-value arg)) 10)))
- (point-max))))
- ;; If we went to a place in the middle of the buffer,
- ;; adjust it to the beginning of a line.
- (if arg (forward-line 1)
- ;; If the end of the buffer is not already on the screen,
- ;; then scroll specially to put it near, but not at, the bottom.
- (if (let ((old-point (point)))
- (save-excursion
- (goto-char (window-start))
- (vertical-motion (window-height))
- (< (point) old-point)))
- (progn
- (overlay-recenter (point))
- (recenter -3)))))
-
-;;;;;;;;;
-;;;;; no mark
-;;;;;;;;;
-
-(defun forward-char-nomark (&optional arg)
- "Deactivate mark; move point right ARG characters \(left if ARG negative).
-On reaching end of buffer, stop and signal error."
- (interactive "p")
- (pc-select-maybe-deactivate-mark)
- (forward-char arg))
-
-(defun forward-word-nomark (&optional arg)
- "Deactivate mark; move point right ARG words \(backward if ARG is negative).
-Normally returns t.
-If an edge of the buffer is reached, point is left there
-and nil is returned."
- (interactive "p")
- (pc-select-maybe-deactivate-mark)
- (forward-word arg))
-
-(defun forward-line-nomark (&optional arg)
- "Deactivate mark; move cursor vertically down ARG lines."
- (interactive "p")
- (pc-select-maybe-deactivate-mark)
- (forward-line arg)
- (setq this-command 'forward-line)
-)
-
-(defun forward-sexp-nomark (&optional arg)
- "Deactivate mark; move forward across one balanced expression (sexp).
-With argument, do it that many times. Negative arg -N means
-move backward across N balanced expressions."
- (interactive "p")
- (pc-select-maybe-deactivate-mark)
- (forward-sexp arg))
-
-(defun forward-paragraph-nomark (&optional arg)
- "Deactivate mark; move forward to end of paragraph.
-With arg N, do it N times; negative arg -N means move backward N paragraphs.
-
-A line which `paragraph-start' matches either separates paragraphs
-\(if `paragraph-separate' matches it also) or is the first line of a paragraph.
-A paragraph end is the beginning of a line which is not part of the paragraph
-to which the end of the previous line belongs, or the end of the buffer."
- (interactive "p")
- (pc-select-maybe-deactivate-mark)
- (forward-paragraph arg))
-
-(defun next-line-nomark (&optional arg)
- "Deactivate mark; move cursor vertically down ARG lines.
-If there is no character in the target line exactly under the current column,
-the cursor is positioned after the character in that line which spans this
-column, or at the end of the line if it is not long enough.
-If there is no line in the buffer after this one, behavior depends on the
-value of `next-line-add-newlines'. If non-nil, it inserts a newline character
-to create a line, and moves the cursor to that line. Otherwise it moves the
-cursor to the end of the buffer (if already at the end of the buffer, an error
-is signaled).
-
-The command \\[set-goal-column] can be used to create
-a semipermanent goal column to which this command always moves.
-Then it does not try to move vertically. This goal column is stored
-in `goal-column', which is nil when there is none."
- (interactive "p")
- (pc-select-maybe-deactivate-mark)
- (with-no-warnings (next-line arg))
- (setq this-command 'next-line))
-
-(defun end-of-line-nomark (&optional arg)
- "Deactivate mark; move point to end of current line.
-With argument ARG not nil or 1, move forward ARG - 1 lines first.
-If scan reaches end of buffer, stop there without error."
- (interactive "p")
- (pc-select-maybe-deactivate-mark)
- (end-of-line arg)
- (setq this-command 'end-of-line))
-
-(defun backward-line-nomark (&optional arg)
- "Deactivate mark; move cursor vertically up ARG lines."
- (interactive "p")
- (pc-select-maybe-deactivate-mark)
- (if (null arg)
- (setq arg 1))
- (forward-line (- arg))
- (setq this-command 'forward-line)
-)
-
-(defun scroll-down-nomark (&optional arg)
- "Deactivate mark; scroll down ARG lines; or near full screen if no ARG.
-A near full screen is `next-screen-context-lines' less than a full screen.
-Negative ARG means scroll upward.
-When calling from a program, supply a number as argument or nil.
-Attempting to scroll past the edge of buffer does not raise an
-error, unless `pc-select-override-scroll-error' is nil."
- (interactive "P")
- (pc-select-maybe-deactivate-mark)
- (cond (pc-select-override-scroll-error
- (condition-case nil (scroll-down arg)
- (beginning-of-buffer (goto-char (point-min)))))
- (t (scroll-down arg))))
-
-(defun end-of-buffer-nomark (&optional arg)
- "Deactivate mark; move point to the end of the buffer.
-With arg N, put point N/10 of the way from the end.
-
-If the buffer is narrowed, this command uses the beginning and size
-of the accessible part of the buffer.
-
-Don't use this command in Lisp programs!
-\(goto-char (point-max)) is faster and avoids clobbering the mark."
- (interactive "P")
- (pc-select-maybe-deactivate-mark)
- (let ((size (- (point-max) (point-min))))
- (goto-char (if arg
- (- (point-max)
- (if (> size 10000)
- ;; Avoid overflow for large buffer sizes!
- (* (prefix-numeric-value arg)
- (/ size 10))
- (/ (* size (prefix-numeric-value arg)) 10)))
- (point-max))))
- ;; If we went to a place in the middle of the buffer,
- ;; adjust it to the beginning of a line.
- (if arg (forward-line 1)
- ;; If the end of the buffer is not already on the screen,
- ;; then scroll specially to put it near, but not at, the bottom.
- (if (let ((old-point (point)))
- (save-excursion
- (goto-char (window-start))
- (vertical-motion (window-height))
- (< (point) old-point)))
- (progn
- (overlay-recenter (point))
- (recenter -3)))))
-
-
-;;;;;;;;;;;;;;;;;;;;
-;;;;;; backwards and mark
-;;;;;;;;;;;;;;;;;;;;
-
-(defun backward-char-mark (&optional arg)
- "Ensure mark is active; move point left ARG characters (right if ARG negative).
-On attempt to pass beginning or end of buffer, stop and signal error."
- (interactive "p")
- (pc-select-ensure-mark)
- (backward-char arg))
-
-(defun backward-word-mark (&optional arg)
- "Ensure mark is active; move backward until encountering the end of a word.
-With argument, do this that many times."
- (interactive "p")
- (pc-select-ensure-mark)
- (backward-word arg))
-
-(defun backward-sexp-mark (&optional arg)
- "Ensure mark is active; move backward across one balanced expression (sexp).
-With argument, do it that many times. Negative arg -N means
-move forward across N balanced expressions."
- (interactive "p")
- (pc-select-ensure-mark)
- (backward-sexp arg))
-
-(defun backward-paragraph-mark (&optional arg)
- "Ensure mark is active; move backward to start of paragraph.
-With arg N, do it N times; negative arg -N means move forward N paragraphs.
-
-A paragraph start is the beginning of a line which is a
-`first-line-of-paragraph' or which is ordinary text and follows a
-paragraph-separating line; except: if the first real line of a
-paragraph is preceded by a blank line, the paragraph starts at that
-blank line.
-
-See `forward-paragraph' for more information."
- (interactive "p")
- (pc-select-ensure-mark)
- (backward-paragraph arg))
-
-(defun previous-line-mark (&optional arg)
- "Ensure mark is active; move cursor vertically up ARG lines.
-If there is no character in the target line exactly over the current column,
-the cursor is positioned after the character in that line which spans this
-column, or at the end of the line if it is not long enough.
-
-The command \\[set-goal-column] can be used to create
-a semipermanent goal column to which this command always moves.
-Then it does not try to move vertically.
-
-If you are thinking of using this in a Lisp program, consider using
-`forward-line' with a negative argument instead. It is usually easier
-to use and more reliable (no dependence on goal column, etc.)."
- (interactive "p")
- (pc-select-ensure-mark)
- (with-no-warnings (previous-line arg))
- (setq this-command 'previous-line))
-
-(defun beginning-of-line-mark (&optional arg)
- "Ensure mark is active; move point to beginning of current line.
-With argument ARG not nil or 1, move forward ARG - 1 lines first.
-If scan reaches end of buffer, stop there without error."
- (interactive "p")
- (pc-select-ensure-mark)
- (beginning-of-line arg))
-
-
-(defun scroll-up-mark (&optional arg)
- "Ensure mark is active; scroll upward ARG lines; or near full screen if no ARG.
-A near full screen is `next-screen-context-lines' less than a full screen.
-Negative ARG means scroll downward.
-When calling from a program, supply a number as argument or nil.
-Attempting to scroll past the edge of buffer does not raise an
-error, unless `pc-select-override-scroll-error' is nil."
- (interactive "P")
- (pc-select-ensure-mark)
- (cond (pc-select-override-scroll-error
- (condition-case nil (scroll-up arg)
- (end-of-buffer (goto-char (point-max)))))
- (t (scroll-up arg))))
-
-(defun beginning-of-buffer-mark (&optional arg)
- "Ensure mark is active; move point to the beginning of the buffer.
-With arg N, put point N/10 of the way from the beginning.
-
-If the buffer is narrowed, this command uses the beginning and size
-of the accessible part of the buffer.
-
-Don't use this command in Lisp programs!
-\(goto-char (point-min)) is faster and avoids clobbering the mark."
- (interactive "P")
- (pc-select-ensure-mark)
- (let ((size (- (point-max) (point-min))))
- (goto-char (if arg
- (+ (point-min)
- (if (> size 10000)
- ;; Avoid overflow for large buffer sizes!
- (* (prefix-numeric-value arg)
- (/ size 10))
- (/ (+ 10 (* size (prefix-numeric-value arg))) 10)))
- (point-min))))
- (if arg (forward-line 1)))
-
-;;;;;;;;
-;;; no mark
-;;;;;;;;
-
-(defun backward-char-nomark (&optional arg)
- "Deactivate mark; move point left ARG characters (right if ARG negative).
-On attempt to pass beginning or end of buffer, stop and signal error."
- (interactive "p")
- (pc-select-maybe-deactivate-mark)
- (backward-char arg))
-
-(defun backward-word-nomark (&optional arg)
- "Deactivate mark; move backward until encountering the end of a word.
-With argument, do this that many times."
- (interactive "p")
- (pc-select-maybe-deactivate-mark)
- (backward-word arg))
-
-(defun backward-sexp-nomark (&optional arg)
- "Deactivate mark; move backward across one balanced expression (sexp).
-With argument, do it that many times. Negative arg -N means
-move forward across N balanced expressions."
- (interactive "p")
- (pc-select-maybe-deactivate-mark)
- (backward-sexp arg))
-
-(defun backward-paragraph-nomark (&optional arg)
- "Deactivate mark; move backward to start of paragraph.
-With arg N, do it N times; negative arg -N means move forward N paragraphs.
-
-A paragraph start is the beginning of a line which is a
-`first-line-of-paragraph' or which is ordinary text and follows a
-paragraph-separating line; except: if the first real line of a
-paragraph is preceded by a blank line, the paragraph starts at that
-blank line.
-
-See `forward-paragraph' for more information."
- (interactive "p")
- (pc-select-maybe-deactivate-mark)
- (backward-paragraph arg))
-
-(defun previous-line-nomark (&optional arg)
- "Deactivate mark; move cursor vertically up ARG lines.
-If there is no character in the target line exactly over the current column,
-the cursor is positioned after the character in that line which spans this
-column, or at the end of the line if it is not long enough.
-
-The command \\[set-goal-column] can be used to create
-a semipermanent goal column to which this command always moves.
-Then it does not try to move vertically."
- (interactive "p")
- (pc-select-maybe-deactivate-mark)
- (with-no-warnings (previous-line arg))
- (setq this-command 'previous-line))
-
-(defun beginning-of-line-nomark (&optional arg)
- "Deactivate mark; move point to beginning of current line.
-With argument ARG not nil or 1, move forward ARG - 1 lines first.
-If scan reaches end of buffer, stop there without error."
- (interactive "p")
- (pc-select-maybe-deactivate-mark)
- (beginning-of-line arg))
-
-(defun scroll-up-nomark (&optional arg)
- "Deactivate mark; scroll upward ARG lines; or near full screen if no ARG.
-A near full screen is `next-screen-context-lines' less than a full screen.
-Negative ARG means scroll downward.
-When calling from a program, supply a number as argument or nil.
-Attempting to scroll past the edge of buffer does not raise an
-error, unless `pc-select-override-scroll-error' is nil."
- (interactive "P")
- (pc-select-maybe-deactivate-mark)
- (cond (pc-select-override-scroll-error
- (condition-case nil (scroll-up arg)
- (end-of-buffer (goto-char (point-max)))))
- (t (scroll-up arg))))
-
-(defun beginning-of-buffer-nomark (&optional arg)
- "Deactivate mark; move point to the beginning of the buffer.
-With arg N, put point N/10 of the way from the beginning.
-
-If the buffer is narrowed, this command uses the beginning and size
-of the accessible part of the buffer.
-
-Don't use this command in Lisp programs!
-\(goto-char (point-min)) is faster and avoids clobbering the mark."
- (interactive "P")
- (pc-select-maybe-deactivate-mark)
- (let ((size (- (point-max) (point-min))))
- (goto-char (if arg
- (+ (point-min)
- (if (> size 10000)
- ;; Avoid overflow for large buffer sizes!
- (* (prefix-numeric-value arg)
- (/ size 10))
- (/ (+ 10 (* size (prefix-numeric-value arg))) 10)))
- (point-min))))
- (if arg (forward-line 1)))
-
-
-(defun pc-select-define-keys (alist keymap)
- "Make KEYMAP have the key bindings specified in ALIST."
- (let ((lst alist))
- (while lst
- (define-key keymap (caar lst) (cdar lst))
- (setq lst (cdr lst)))))
-
-(defun pc-select-restore-keys (alist keymap saved-map)
- "Use ALIST to restore key bindings from SAVED-MAP into KEYMAP.
-Go through all the key bindings in ALIST, and, for each key
-binding, if KEYMAP and ALIST still agree on the key binding,
-restore the previous value of that key binding from SAVED-MAP."
- (let ((lst alist))
- (while lst
- (when (equal (lookup-key keymap (caar lst)) (cdar lst))
- (define-key keymap (caar lst) (lookup-key saved-map (caar lst))))
- (setq lst (cdr lst)))))
-
-(defmacro pc-select-add-to-alist (alist var val)
- "Ensure that ALIST contains the cons cell (VAR . VAL).
-If a cons cell whose car is VAR is already on the ALIST, update the
-cdr of that cell with VAL. Otherwise, make a new cons cell
-\(VAR . VAL), and prepend it onto ALIST."
- (let ((elt (make-symbol "elt")))
- `(let ((,elt (assq ',var ,alist)))
- (if ,elt
- (setcdr ,elt ,val)
- (setq ,alist (cons (cons ',var ,val) ,alist))))))
-
-(defmacro pc-select-save-and-set-var (var newval)
- "Set VAR to NEWVAL; save the old value.
-The old value is saved on the `pc-select-saved-settings-alist'."
- `(when (boundp ',var)
- (pc-select-add-to-alist pc-select-saved-settings-alist ,var ,var)
- (setq ,var ,newval)))
-
-(defmacro pc-select-save-and-set-mode (mode &optional arg mode-var)
- "Call the function MODE; save the old value of the variable MODE.
-MODE is presumed to be a function which turns on a minor mode. First,
-save the value of the variable MODE on `pc-select-saved-settings-alist'.
-Then, if ARG is specified, call MODE with ARG, otherwise call it with
-nil as an argument. If MODE-VAR is specified, save the value of the
-variable MODE-VAR (instead of the value of the variable MODE) on
-`pc-select-saved-settings-alist'."
- (unless mode-var (setq mode-var mode))
- `(when (fboundp ',mode)
- (pc-select-add-to-alist pc-select-saved-settings-alist
- ,mode-var ,mode-var)
- (,mode ,arg)))
-
-(defmacro pc-select-restore-var (var)
- "Restore the previous value of the variable VAR.
-Look up VAR's previous value in `pc-select-saved-settings-alist', and,
-if the value is found, set VAR to that value."
- (let ((elt (make-symbol "elt")))
- `(let ((,elt (assq ',var pc-select-saved-settings-alist)))
- (unless (null ,elt)
- (setq ,var (cdr ,elt))))))
-
-(defmacro pc-select-restore-mode (mode)
- "Restore the previous state (either on or off) of the minor mode MODE.
-Look up the value of the variable MODE on `pc-select-saved-settings-alist'.
-If the value is non-nil, call the function MODE with an argument of
-1, otherwise call it with an argument of -1."
- (let ((elt (make-symbol "elt")))
- `(when (fboundp ',mode)
- (let ((,elt (assq ',mode pc-select-saved-settings-alist)))
- (unless (null ,elt)
- (,mode (if (cdr ,elt) 1 -1)))))))
-
-
-;;;###autoload
-(define-minor-mode pc-selection-mode
- "Change mark behavior to emulate Motif, Mac or MS-Windows cut and paste style.
-
-This mode enables Delete Selection mode and Transient Mark mode.
-
-The arrow keys (and others) are bound to new functions
-which modify the status of the mark.
-
-The ordinary arrow keys disable the mark.
-The shift-arrow keys move, leaving the mark behind.
-
-C-LEFT and C-RIGHT move back or forward one word, disabling the mark.
-S-C-LEFT and S-C-RIGHT move back or forward one word, leaving the mark behind.
-
-M-LEFT and M-RIGHT move back or forward one word or sexp, disabling the mark.
-S-M-LEFT and S-M-RIGHT move back or forward one word or sexp, leaving the mark
-behind. To control whether these keys move word-wise or sexp-wise set the
-variable `pc-select-meta-moves-sexps' after loading pc-select.el but before
-turning PC Selection mode on.
-
-C-DOWN and C-UP move back or forward a paragraph, disabling the mark.
-S-C-DOWN and S-C-UP move back or forward a paragraph, leaving the mark behind.
-
-HOME moves to beginning of line, disabling the mark.
-S-HOME moves to beginning of line, leaving the mark behind.
-With Ctrl or Meta, these keys move to beginning of buffer instead.
-
-END moves to end of line, disabling the mark.
-S-END moves to end of line, leaving the mark behind.
-With Ctrl or Meta, these keys move to end of buffer instead.
-
-PRIOR or PAGE-UP scrolls and disables the mark.
-S-PRIOR or S-PAGE-UP scrolls and leaves the mark behind.
-
-S-DELETE kills the region (`kill-region').
-S-INSERT yanks text from the kill ring (`yank').
-C-INSERT copies the region into the kill ring (`copy-region-as-kill').
-
-In addition, certain other PC bindings are imitated (to avoid this, set
-the variable `pc-select-selection-keys-only' to t after loading pc-select.el
-but before calling PC Selection mode):
-
- F6 other-window
- DELETE delete-char
- C-DELETE kill-line
- M-DELETE kill-word
- C-M-DELETE kill-sexp
- C-BACKSPACE backward-kill-word
- M-BACKSPACE undo"
- ;; FIXME: bring pc-bindings-mode here ?
- nil nil nil
-
- :group 'pc-select
- :global t
-
- (if pc-selection-mode
- (if (null pc-select-key-bindings-alist)
- (progn
- (setq pc-select-saved-global-map (copy-keymap (current-global-map)))
- (setq pc-select-key-bindings-alist
- (append pc-select-default-key-bindings
- (if pc-select-selection-keys-only
- nil
- pc-select-extra-key-bindings)
- (if pc-select-meta-moves-sexps
- (car pc-select-meta-moves-sexps-key-bindings)
- (cadr pc-select-meta-moves-sexps-key-bindings))
- (if (or pc-select-selection-keys-only
- (eq window-system 'x)
- (memq system-name '(ms-dos windows-nt)))
- nil
- pc-select-tty-key-bindings)))
-
- (pc-select-define-keys pc-select-key-bindings-alist
- (current-global-map))
-
- (unless (or pc-select-selection-keys-only
- (eq window-system 'x)
- (memq system-name '(ms-dos windows-nt)))
- ;; it is not clear that we need the following line
- ;; I hope it doesn't do too much harm to leave it in, though...
- (setq pc-select-old-M-delete-binding
- (lookup-key function-key-map [M-delete]))
- (define-key function-key-map [M-delete] [?\M-d]))
-
- (when (and (not pc-select-selection-keys-only)
- (or (eq window-system 'x)
- (memq system-name '(ms-dos windows-nt)))
- (fboundp 'normal-erase-is-backspace-mode))
- (pc-select-save-and-set-mode normal-erase-is-backspace-mode 1
- normal-erase-is-backspace))
- ;; the original author also had this above:
- ;; (setq-default normal-erase-is-backspace t)
- ;; However, the documentation for the variable says that
- ;; "setting it with setq has no effect", so I'm removing it.
-
- (pc-select-save-and-set-var highlight-nonselected-windows nil)
- (pc-select-save-and-set-var transient-mark-mode t)
- (pc-select-save-and-set-var mark-even-if-inactive t)
- (pc-select-save-and-set-mode delete-selection-mode 1))
- ;;else
- ;; If the user turned on pc-selection-mode a second time
- ;; do not clobber the values of the variables that were
- ;; saved from before pc-selection mode was activated --
- ;; just make sure the values are the way we like them.
- (pc-select-define-keys pc-select-key-bindings-alist
- (current-global-map))
- (unless (or pc-select-selection-keys-only
- (eq window-system 'x)
- (memq system-name '(ms-dos windows-nt)))
- ;; it is not clear that we need the following line
- ;; I hope it doesn't do too much harm to leave it in, though...
- (define-key function-key-map [M-delete] [?\M-d]))
- (when (and (not pc-select-selection-keys-only)
- (or (eq window-system 'x)
- (memq system-name '(ms-dos windows-nt)))
- (fboundp 'normal-erase-is-backspace-mode))
- (normal-erase-is-backspace-mode 1))
- (setq highlight-nonselected-windows nil)
- (setq transient-mark-mode t)
- (setq mark-even-if-inactive t)
- (delete-selection-mode 1))
- ;;else
- (when pc-select-key-bindings-alist
- (when (and (not pc-select-selection-keys-only)
- (or (eq window-system 'x)
- (memq system-name '(ms-dos windows-nt))))
- (pc-select-restore-mode normal-erase-is-backspace-mode))
-
- (pc-select-restore-keys
- pc-select-key-bindings-alist (current-global-map)
- pc-select-saved-global-map)
-
- (pc-select-restore-var highlight-nonselected-windows)
- (pc-select-restore-var transient-mark-mode)
- (pc-select-restore-var mark-even-if-inactive)
- (pc-select-restore-mode delete-selection-mode)
- (and pc-select-old-M-delete-binding
- (define-key function-key-map [M-delete]
- pc-select-old-M-delete-binding))
- (setq pc-select-key-bindings-alist nil
- pc-select-saved-settings-alist nil))))
-
-;; arch-tag: 10697b70-ae07-4f3e-ad23-7814a3f418c2
-;;; pc-select.el ends here
diff --git a/lisp/emulation/tpu-edt.el b/lisp/emulation/tpu-edt.el
index f3a0c43eb96..f86d3be0fc0 100644
--- a/lisp/emulation/tpu-edt.el
+++ b/lisp/emulation/tpu-edt.el
@@ -1,7 +1,6 @@
;;; tpu-edt.el --- Emacs emulating TPU emulating EDT
-;; Copyright (C) 1993, 1994, 1995, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1995, 2000-2011 Free Software Foundation, Inc.
;; Author: Rob Riepel <riepel@networking.stanford.edu>
;; Maintainer: Rob Riepel <riepel@networking.stanford.edu>
@@ -2438,7 +2437,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" "a564a0c82b232d8c113549f6fd0ce8e5")
+;;;;;; tpu-cursor-free-mode) "tpu-extras" "tpu-extras.el" "0d2f0cd1c728d2eb9028a6e01b1a5df1")
;;; Generated autoloads from tpu-extras.el
(autoload 'tpu-cursor-free-mode "tpu-extras" "\
@@ -2465,5 +2464,4 @@ Constrain the cursor to the flow of the text.
(provide 'tpu-edt)
-;; arch-tag: f3dfe61c-2cbd-4f73-b9cc-eb215020b857
;;; tpu-edt.el ends here
diff --git a/lisp/emulation/tpu-extras.el b/lisp/emulation/tpu-extras.el
index b4d6afdff6b..235b16e92b1 100644
--- a/lisp/emulation/tpu-extras.el
+++ b/lisp/emulation/tpu-extras.el
@@ -1,11 +1,11 @@
;;; tpu-extras.el --- scroll margins and free cursor mode for TPU-edt
-;; Copyright (C) 1993, 1994, 1995, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1995, 2000-2011 Free Software Foundation, Inc.
;; 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 +275,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 +317,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 +356,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 +437,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 0b246c012ed..15417a137f8 100644
--- a/lisp/emulation/tpu-mapper.el
+++ b/lisp/emulation/tpu-mapper.el
@@ -1,11 +1,11 @@
;;; tpu-mapper.el --- create a TPU-edt X-windows keymap file
-;; Copyright (C) 1993, 1994, 1995, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1995, 2001-2011 Free Software Foundation, Inc.
;; 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.
@@ -349,5 +349,4 @@ your local X guru can try to figure out why the key is being ignored."
")
(goto-char (point-min)))
-;; arch-tag: bab5872f-cd3a-4c1c-aedb-047b67646f6c
;;; tpu-mapper.el ends here
diff --git a/lisp/emulation/vi.el b/lisp/emulation/vi.el
index a65dd44e39e..5bab9741649 100644
--- a/lisp/emulation/vi.el
+++ b/lisp/emulation/vi.el
@@ -1488,5 +1488,4 @@ With ARG, inserts that many newlines."
(provide 'vi)
-;; arch-tag: ac9bdac3-8acb-4ddd-bdae-c6dd873153b3
;;; vi.el ends here
diff --git a/lisp/emulation/vip.el b/lisp/emulation/vip.el
index 3349d096b95..6f4f0ce80ec 100644
--- a/lisp/emulation/vip.el
+++ b/lisp/emulation/vip.el
@@ -1,7 +1,7 @@
;;; vip.el --- a VI Package for GNU Emacs
-;; Copyright (C) 1986, 1987, 1988, 1992, 1993, 1998, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1986-1988, 1992-1993, 1998, 2001-2011
+;; Free Software Foundation, Inc.
;; Author: Masahiko Sato <ms@sail.stanford.edu>
;; Keywords: emulations
@@ -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)
@@ -164,132 +164,133 @@ If nil then it is bound to `delete-backward-char'."
;; key bindings
-(defvar vip-mode-map (make-keymap))
-
-(define-key vip-mode-map "\C-a" 'beginning-of-line)
-(define-key vip-mode-map "\C-b" 'vip-scroll-back)
-(define-key vip-mode-map "\C-c" 'vip-ctl-c)
-(define-key vip-mode-map "\C-d" 'vip-scroll-up)
-(define-key vip-mode-map "\C-e" 'vip-scroll-up-one)
-(define-key vip-mode-map "\C-f" 'vip-scroll)
-(define-key vip-mode-map "\C-g" 'vip-keyboard-quit)
-(define-key vip-mode-map "\C-h" 'help-command)
-(define-key vip-mode-map "\C-m" 'vip-scroll-back)
-(define-key vip-mode-map "\C-n" 'vip-other-window)
-(define-key vip-mode-map "\C-o" 'vip-open-line-at-point)
-(define-key vip-mode-map "\C-u" 'vip-scroll-down)
-(define-key vip-mode-map "\C-x" 'vip-ctl-x)
-(define-key vip-mode-map "\C-y" 'vip-scroll-down-one)
-(define-key vip-mode-map "\C-z" 'vip-change-mode-to-emacs)
-(define-key vip-mode-map "\e" 'vip-ESC)
-
-(define-key vip-mode-map " " 'vip-scroll)
-(define-key vip-mode-map "!" 'vip-command-argument)
-(define-key vip-mode-map "\"" 'vip-command-argument)
-(define-key vip-mode-map "#" 'vip-command-argument)
-(define-key vip-mode-map "$" 'vip-goto-eol)
-(define-key vip-mode-map "%" 'vip-paren-match)
-(define-key vip-mode-map "&" 'vip-nil)
-(define-key vip-mode-map "'" 'vip-goto-mark-and-skip-white)
-(define-key vip-mode-map "(" 'vip-backward-sentence)
-(define-key vip-mode-map ")" 'vip-forward-sentence)
-(define-key vip-mode-map "*" 'call-last-kbd-macro)
-(define-key vip-mode-map "+" 'vip-next-line-at-bol)
-(define-key vip-mode-map "," 'vip-repeat-find-opposite)
-(define-key vip-mode-map "-" 'vip-previous-line-at-bol)
-(define-key vip-mode-map "." 'vip-repeat)
-(define-key vip-mode-map "/" 'vip-search-forward)
-
-(define-key vip-mode-map "0" 'vip-beginning-of-line)
-(define-key vip-mode-map "1" 'vip-digit-argument)
-(define-key vip-mode-map "2" 'vip-digit-argument)
-(define-key vip-mode-map "3" 'vip-digit-argument)
-(define-key vip-mode-map "4" 'vip-digit-argument)
-(define-key vip-mode-map "5" 'vip-digit-argument)
-(define-key vip-mode-map "6" 'vip-digit-argument)
-(define-key vip-mode-map "7" 'vip-digit-argument)
-(define-key vip-mode-map "8" 'vip-digit-argument)
-(define-key vip-mode-map "9" 'vip-digit-argument)
-
-(define-key vip-mode-map ":" 'vip-ex)
-(define-key vip-mode-map ";" 'vip-repeat-find)
-(define-key vip-mode-map "<" 'vip-command-argument)
-(define-key vip-mode-map "=" 'vip-command-argument)
-(define-key vip-mode-map ">" 'vip-command-argument)
-(define-key vip-mode-map "?" 'vip-search-backward)
-(define-key vip-mode-map "@" 'vip-nil)
-
-(define-key vip-mode-map "A" 'vip-Append)
-(define-key vip-mode-map "B" 'vip-backward-Word)
-(define-key vip-mode-map "C" 'vip-ctl-c-equivalent)
-(define-key vip-mode-map "D" 'vip-kill-line)
-(define-key vip-mode-map "E" 'vip-end-of-Word)
-(define-key vip-mode-map "F" 'vip-find-char-backward)
-(define-key vip-mode-map "G" 'vip-goto-line)
-(define-key vip-mode-map "H" 'vip-window-top)
-(define-key vip-mode-map "I" 'vip-Insert)
-(define-key vip-mode-map "J" 'vip-join-lines)
-(define-key vip-mode-map "K" 'vip-kill-buffer)
-(define-key vip-mode-map "L" 'vip-window-bottom)
-(define-key vip-mode-map "M" 'vip-window-middle)
-(define-key vip-mode-map "N" 'vip-search-Next)
-(define-key vip-mode-map "O" 'vip-Open-line)
-(define-key vip-mode-map "P" 'vip-Put-back)
-(define-key vip-mode-map "Q" 'vip-query-replace)
-(define-key vip-mode-map "R" 'vip-replace-string)
-(define-key vip-mode-map "S" 'vip-switch-to-buffer-other-window)
-(define-key vip-mode-map "T" 'vip-goto-char-backward)
-(define-key vip-mode-map "U" 'vip-nil)
-(define-key vip-mode-map "V" 'vip-find-file-other-window)
-(define-key vip-mode-map "W" 'vip-forward-Word)
-(define-key vip-mode-map "X" 'vip-ctl-x-equivalent)
-(define-key vip-mode-map "Y" 'vip-yank-line)
-(define-key vip-mode-map "ZZ" 'save-buffers-kill-emacs)
-
-(define-key vip-mode-map "[" 'vip-nil)
-(define-key vip-mode-map "\\" 'vip-escape-to-emacs)
-(define-key vip-mode-map "]" 'vip-nil)
-(define-key vip-mode-map "^" 'vip-bol-and-skip-white)
-(define-key vip-mode-map "_" 'vip-nil)
-(define-key vip-mode-map "`" 'vip-goto-mark)
-
-(define-key vip-mode-map "a" 'vip-append)
-(define-key vip-mode-map "b" 'vip-backward-word)
-(define-key vip-mode-map "c" 'vip-command-argument)
-(define-key vip-mode-map "d" 'vip-command-argument)
-(define-key vip-mode-map "e" 'vip-end-of-word)
-(define-key vip-mode-map "f" 'vip-find-char-forward)
-(define-key vip-mode-map "g" 'vip-info-on-file)
-(define-key vip-mode-map "h" 'vip-backward-char)
-(define-key vip-mode-map "i" 'vip-insert)
-(define-key vip-mode-map "j" 'vip-next-line)
-(define-key vip-mode-map "k" 'vip-previous-line)
-(define-key vip-mode-map "l" 'vip-forward-char)
-(define-key vip-mode-map "m" 'vip-mark-point)
-(define-key vip-mode-map "n" 'vip-search-next)
-(define-key vip-mode-map "o" 'vip-open-line)
-(define-key vip-mode-map "p" 'vip-put-back)
-(define-key vip-mode-map "q" 'vip-nil)
-(define-key vip-mode-map "r" 'vip-replace-char)
-(define-key vip-mode-map "s" 'vip-switch-to-buffer)
-(define-key vip-mode-map "t" 'vip-goto-char-forward)
-(define-key vip-mode-map "u" 'vip-undo)
-(define-key vip-mode-map "v" 'vip-find-file)
-(define-key vip-mode-map "w" 'vip-forward-word)
-(define-key vip-mode-map "x" 'vip-delete-char)
-(define-key vip-mode-map "y" 'vip-command-argument)
-(define-key vip-mode-map "zH" 'vip-line-to-top)
-(define-key vip-mode-map "zM" 'vip-line-to-middle)
-(define-key vip-mode-map "zL" 'vip-line-to-bottom)
-(define-key vip-mode-map "z\C-m" 'vip-line-to-top)
-(define-key vip-mode-map "z." 'vip-line-to-middle)
-(define-key vip-mode-map "z-" 'vip-line-to-bottom)
-
-(define-key vip-mode-map "{" 'vip-backward-paragraph)
-(define-key vip-mode-map "|" 'vip-goto-col)
-(define-key vip-mode-map "}" 'vip-forward-paragraph)
-(define-key vip-mode-map "~" 'vip-nil)
-(define-key vip-mode-map "\177" 'vip-delete-backward-char)
+(defvar vip-mode-map
+ (let ((map (make-keymap)))
+ (define-key map "\C-a" 'beginning-of-line)
+ (define-key map "\C-b" 'vip-scroll-back)
+ (define-key map "\C-c" 'vip-ctl-c)
+ (define-key map "\C-d" 'vip-scroll-up)
+ (define-key map "\C-e" 'vip-scroll-up-one)
+ (define-key map "\C-f" 'vip-scroll)
+ (define-key map "\C-g" 'vip-keyboard-quit)
+ (define-key map "\C-h" 'help-command)
+ (define-key map "\C-m" 'vip-scroll-back)
+ (define-key map "\C-n" 'vip-other-window)
+ (define-key map "\C-o" 'vip-open-line-at-point)
+ (define-key map "\C-u" 'vip-scroll-down)
+ (define-key map "\C-x" 'vip-ctl-x)
+ (define-key map "\C-y" 'vip-scroll-down-one)
+ (define-key map "\C-z" 'vip-change-mode-to-emacs)
+ (define-key map "\e" 'vip-ESC)
+
+ (define-key map " " 'vip-scroll)
+ (define-key map "!" 'vip-command-argument)
+ (define-key map "\"" 'vip-command-argument)
+ (define-key map "#" 'vip-command-argument)
+ (define-key map "$" 'vip-goto-eol)
+ (define-key map "%" 'vip-paren-match)
+ (define-key map "&" 'vip-nil)
+ (define-key map "'" 'vip-goto-mark-and-skip-white)
+ (define-key map "(" 'vip-backward-sentence)
+ (define-key map ")" 'vip-forward-sentence)
+ (define-key map "*" 'call-last-kbd-macro)
+ (define-key map "+" 'vip-next-line-at-bol)
+ (define-key map "," 'vip-repeat-find-opposite)
+ (define-key map "-" 'vip-previous-line-at-bol)
+ (define-key map "." 'vip-repeat)
+ (define-key map "/" 'vip-search-forward)
+
+ (define-key map "0" 'vip-beginning-of-line)
+ (define-key map "1" 'vip-digit-argument)
+ (define-key map "2" 'vip-digit-argument)
+ (define-key map "3" 'vip-digit-argument)
+ (define-key map "4" 'vip-digit-argument)
+ (define-key map "5" 'vip-digit-argument)
+ (define-key map "6" 'vip-digit-argument)
+ (define-key map "7" 'vip-digit-argument)
+ (define-key map "8" 'vip-digit-argument)
+ (define-key map "9" 'vip-digit-argument)
+
+ (define-key map ":" 'vip-ex)
+ (define-key map ";" 'vip-repeat-find)
+ (define-key map "<" 'vip-command-argument)
+ (define-key map "=" 'vip-command-argument)
+ (define-key map ">" 'vip-command-argument)
+ (define-key map "?" 'vip-search-backward)
+ (define-key map "@" 'vip-nil)
+
+ (define-key map "A" 'vip-Append)
+ (define-key map "B" 'vip-backward-Word)
+ (define-key map "C" 'vip-ctl-c-equivalent)
+ (define-key map "D" 'vip-kill-line)
+ (define-key map "E" 'vip-end-of-Word)
+ (define-key map "F" 'vip-find-char-backward)
+ (define-key map "G" 'vip-goto-line)
+ (define-key map "H" 'vip-window-top)
+ (define-key map "I" 'vip-Insert)
+ (define-key map "J" 'vip-join-lines)
+ (define-key map "K" 'vip-kill-buffer)
+ (define-key map "L" 'vip-window-bottom)
+ (define-key map "M" 'vip-window-middle)
+ (define-key map "N" 'vip-search-Next)
+ (define-key map "O" 'vip-Open-line)
+ (define-key map "P" 'vip-Put-back)
+ (define-key map "Q" 'vip-query-replace)
+ (define-key map "R" 'vip-replace-string)
+ (define-key map "S" 'vip-switch-to-buffer-other-window)
+ (define-key map "T" 'vip-goto-char-backward)
+ (define-key map "U" 'vip-nil)
+ (define-key map "V" 'vip-find-file-other-window)
+ (define-key map "W" 'vip-forward-Word)
+ (define-key map "X" 'vip-ctl-x-equivalent)
+ (define-key map "Y" 'vip-yank-line)
+ (define-key map "ZZ" 'save-buffers-kill-emacs)
+
+ (define-key map "[" 'vip-nil)
+ (define-key map "\\" 'vip-escape-to-emacs)
+ (define-key map "]" 'vip-nil)
+ (define-key map "^" 'vip-bol-and-skip-white)
+ (define-key map "_" 'vip-nil)
+ (define-key map "`" 'vip-goto-mark)
+
+ (define-key map "a" 'vip-append)
+ (define-key map "b" 'vip-backward-word)
+ (define-key map "c" 'vip-command-argument)
+ (define-key map "d" 'vip-command-argument)
+ (define-key map "e" 'vip-end-of-word)
+ (define-key map "f" 'vip-find-char-forward)
+ (define-key map "g" 'vip-info-on-file)
+ (define-key map "h" 'vip-backward-char)
+ (define-key map "i" 'vip-insert)
+ (define-key map "j" 'vip-next-line)
+ (define-key map "k" 'vip-previous-line)
+ (define-key map "l" 'vip-forward-char)
+ (define-key map "m" 'vip-mark-point)
+ (define-key map "n" 'vip-search-next)
+ (define-key map "o" 'vip-open-line)
+ (define-key map "p" 'vip-put-back)
+ (define-key map "q" 'vip-nil)
+ (define-key map "r" 'vip-replace-char)
+ (define-key map "s" 'vip-switch-to-buffer)
+ (define-key map "t" 'vip-goto-char-forward)
+ (define-key map "u" 'vip-undo)
+ (define-key map "v" 'vip-find-file)
+ (define-key map "w" 'vip-forward-word)
+ (define-key map "x" 'vip-delete-char)
+ (define-key map "y" 'vip-command-argument)
+ (define-key map "zH" 'vip-line-to-top)
+ (define-key map "zM" 'vip-line-to-middle)
+ (define-key map "zL" 'vip-line-to-bottom)
+ (define-key map "z\C-m" 'vip-line-to-top)
+ (define-key map "z." 'vip-line-to-middle)
+ (define-key map "z-" 'vip-line-to-bottom)
+
+ (define-key map "{" 'vip-backward-paragraph)
+ (define-key map "|" 'vip-goto-col)
+ (define-key map "}" 'vip-forward-paragraph)
+ (define-key map "~" 'vip-nil)
+ (define-key map "\177" 'vip-delete-backward-char)
+ map))
(defun vip-version ()
(interactive)
@@ -3054,5 +3055,4 @@ vip-s-string"
(provide 'vip)
-;; arch-tag: bff623ef-48f7-41d4-9aa3-2e840c9ab415
;;; vip.el ends here
diff --git a/lisp/emulation/viper-cmd.el b/lisp/emulation/viper-cmd.el
index 98d77b7212e..5daef7f9666 100644
--- a/lisp/emulation/viper-cmd.el
+++ b/lisp/emulation/viper-cmd.el
@@ -1,9 +1,9 @@
;;; viper-cmd.el --- Vi command support for Viper
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2011 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: viper
;; This file is part of GNU Emacs.
@@ -41,7 +41,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)
@@ -776,7 +776,7 @@ Vi's prefix argument will be used. Otherwise, the prefix argument passed to
(viper-copy-event (viper-seq-last-elt key))))
(if (commandp com)
- ;; pretend that current state is the state we excaped to
+ ;; pretend that current state is the state we escaped to
(let ((viper-current-state state))
(setq prefix-arg (or prefix-arg arg))
(command-execute com)))
@@ -2064,23 +2064,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 +2178,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 +2204,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 +3497,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 +4243,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 +4252,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 +4265,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 +4340,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 +4618,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 +4705,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 +5084,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 b068bd5ca25..93bf8251ce1 100644
--- a/lisp/emulation/viper-ex.el
+++ b/lisp/emulation/viper-ex.el
@@ -1,9 +1,9 @@
;;; viper-ex.el --- functions implementing the Ex commands for Viper
-;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1998, 2000-2011 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: viper
;; This file is part of GNU Emacs.
@@ -750,7 +750,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
@@ -2302,5 +2302,4 @@ Type 'mak ' (including the space) to run make with no args."
-;; arch-tag: 56b80d36-f880-4d10-bd66-85ad91a295db
;;; viper-ex.el ends here
diff --git a/lisp/emulation/viper-init.el b/lisp/emulation/viper-init.el
index 1ecff657d2a..c069c387003 100644
--- a/lisp/emulation/viper-init.el
+++ b/lisp/emulation/viper-init.el
@@ -1,9 +1,9 @@
;;; viper-init.el --- some common definitions for Viper
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2011 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: viper
;; This file is part of GNU Emacs.
@@ -62,9 +62,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 +784,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 +996,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 a3dda4e0ceb..f3bd6bece6e 100644
--- a/lisp/emulation/viper-keym.el
+++ b/lisp/emulation/viper-keym.el
@@ -1,9 +1,9 @@
;;; viper-keym.el --- Viper keymaps
-;; Copyright (C) 1994, 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1997, 2000-2011 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: viper
;; This file is part of GNU Emacs.
@@ -672,5 +672,4 @@ form ((key . function) (key . function) ... )."
;; End:
-;; arch-tag: 43af4b2f-0bea-400b-889e-221ebc00acb1
;;; viper-keym.el ends here
diff --git a/lisp/emulation/viper-macs.el b/lisp/emulation/viper-macs.el
index d39589f44d7..00153c1ff0e 100644
--- a/lisp/emulation/viper-macs.el
+++ b/lisp/emulation/viper-macs.el
@@ -1,9 +1,9 @@
;;; viper-macs.el --- functions implementing keyboard macros for Viper
-;; Copyright (C) 1994, 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1997, 2000-2011 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: viper
;; This file is part of GNU Emacs.
@@ -931,5 +931,4 @@ name from there."
(call-last-kbd-macro)))
-;; arch-tag: ecd3cc5c-8cd0-4bbe-b2ec-7e75a4b7d0aa
;;; viper-macs.el ends here
diff --git a/lisp/emulation/viper-mous.el b/lisp/emulation/viper-mous.el
index 31acf40028a..778910017cd 100644
--- a/lisp/emulation/viper-mous.el
+++ b/lisp/emulation/viper-mous.el
@@ -1,9 +1,9 @@
;;; viper-mous.el --- mouse support for Viper
-;; Copyright (C) 1994, 1995, 1996, 1997, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: viper
;; This file is part of GNU Emacs.
@@ -662,5 +662,4 @@ This buffer may be different from the one where the click occurred."
;; End:
-;; arch-tag: e56b2390-06c4-4dd1-96f5-c7876e2d8c2f
;;; viper-mous.el ends here
diff --git a/lisp/emulation/viper-util.el b/lisp/emulation/viper-util.el
index 81485a0390d..4aace25fc9c 100644
--- a/lisp/emulation/viper-util.el
+++ b/lisp/emulation/viper-util.el
@@ -1,9 +1,9 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1997, 1999-2011 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: viper
;; This file is part of GNU Emacs.
@@ -76,7 +76,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
@@ -1554,5 +1554,4 @@ This option is appropriate if you like Emacs-style words."
;; eval: (put 'viper-deflocalvar 'lisp-indent-hook 'defun)
;; End:
-;; arch-tag: 7f023fd5-dd9e-4378-a397-9c179553b0e3
;;; viper-util.el ends here
diff --git a/lisp/emulation/viper.el b/lisp/emulation/viper.el
index e42d49c5bee..0da3345aae4 100644
--- a/lisp/emulation/viper.el
+++ b/lisp/emulation/viper.el
@@ -3,11 +3,11 @@
;; and a venomous VI PERil.
;; Viper Is also a Package for Emacs Rebels.
-;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-2011 Free Software Foundation, Inc.
;; 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
@@ -1374,5 +1374,4 @@ These two lines must come in the order given.
;; eval: (put 'viper-deflocalvar 'lisp-indent-hook 'defun)
;; End:
-;; arch-tag: 5f3e844c-c4e6-4bbd-9b73-63bdc14e7d79
;;; viper.el ends here
diff --git a/lisp/emulation/ws-mode.el b/lisp/emulation/ws-mode.el
index 5bad5fa4ec1..69f7b1d50ea 100644
--- a/lisp/emulation/ws-mode.el
+++ b/lisp/emulation/ws-mode.el
@@ -1,7 +1,6 @@
;;; ws-mode.el --- WordStar emulation mode for GNU Emacs
-;; Copyright (C) 1991, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1991, 2001-2011 Free Software Foundation, Inc.
;; Author: Juergen Nickelsen <nickel@cs.tu-berlin.de>
;; Version: 0.7
@@ -27,158 +26,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 +336,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:
@@ -754,5 +741,4 @@ sWith: " )
(provide 'ws-mode)
-;; arch-tag: 6dd864bf-2ccb-4d59-af6e-492eba2890a3
;;; ws-mode.el ends here
diff --git a/lisp/env.el b/lisp/env.el
index 1c8e98df62c..5e915eb3126 100644
--- a/lisp/env.el
+++ b/lisp/env.el
@@ -1,10 +1,10 @@
;;; env.el --- functions to manipulate environment variables
-;; Copyright (C) 1991, 1994, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1991, 1994, 2000-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: processes, unix
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -209,5 +209,4 @@ in the environment list of the selected frame."
(provide 'env)
-;; arch-tag: b7d6a8f7-bc81-46db-8e39-8d721d4ed0b8
;;; env.el ends here
diff --git a/lisp/epa-dired.el b/lisp/epa-dired.el
index 431eca90d93..0834a8df23a 100644
--- a/lisp/epa-dired.el
+++ b/lisp/epa-dired.el
@@ -1,8 +1,9 @@
-;;; epa-dired.el --- the EasyPG Assistant, dired extension
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; epa-dired.el --- the EasyPG Assistant, dired extension -*- lexical-binding: t -*-
+;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
;; Author: Daiki Ueno <ueno@unixuser.org>
;; Keywords: PGP, GnuPG
+;; Package: epa
;; This file is part of GNU Emacs.
@@ -73,5 +74,4 @@ If no one is selected, symmetric encryption will be performed. "))
(provide 'epa-dired)
-;; arch-tag: 2025700b-48d0-4684-bc94-228ad1f8e9ff
;;; epa-dired.el ends here
diff --git a/lisp/epa-file.el b/lisp/epa-file.el
index c5c43a724e8..aa9915d8cfa 100644
--- a/lisp/epa-file.el
+++ b/lisp/epa-file.el
@@ -1,8 +1,9 @@
-;;; epa-file.el --- the EasyPG Assistant, transparent file encryption
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; epa-file.el --- the EasyPG Assistant, transparent file encryption -*- lexical-binding: t -*-
+;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
;; Author: Daiki Ueno <ueno@unixuser.org>
;; Keywords: PGP, GnuPG
+;; Package: epa
;; This file is part of GNU Emacs.
@@ -34,9 +35,16 @@ way."
:type 'boolean
:group 'epa-file)
-(defcustom epa-file-select-keys nil
- "If non-nil, always asks user to select recipients."
- :type 'boolean
+(defcustom epa-file-select-keys 'silent
+ "Control whether or not to pop up the key selection dialog.
+
+If t, always asks user to select recipients.
+If nil, query user only when `epa-file-encrypt-to' is not set.
+If neither t nor nil, doesn't ask user. In this case, symmetric
+encryption is used."
+ :type '(choice (const :tag "Ask always" t)
+ (const :tag "Ask when recipients are not set" nil)
+ (const :tag "Don't ask" silent))
:group 'epa-file)
(defvar epa-file-passphrase-alist nil)
@@ -66,10 +74,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 +110,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 +148,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,18 +166,22 @@ 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
(file-exists-p local-copy))
- (let ((delete-by-moving-to-trash nil))
- (delete-file local-copy))))
+ (delete-file local-copy)))
(list file length)))
(put 'insert-file-contents 'epa-file 'epa-file-insert-file-contents)
@@ -194,9 +225,10 @@ way."
end (point-max)))
(epa-file--encode-coding-string (buffer-substring start end)
coding-system))
- (if (or epa-file-select-keys
- (not (local-variable-p 'epa-file-encrypt-to
- (current-buffer))))
+ (if (or (eq epa-file-select-keys t)
+ (and (null epa-file-select-keys)
+ (not (local-variable-p 'epa-file-encrypt-to
+ (current-buffer)))))
(epa-select-keys
context
"Select recipents for encryption.
@@ -266,5 +298,4 @@ If no one is selected, symmetric encryption will be performed. "))))
(provide 'epa-file)
-;; arch-tag: 5715152f-0eb1-4dbc-9008-07098775314d
;;; epa-file.el ends here
diff --git a/lisp/epa-hook.el b/lisp/epa-hook.el
index 44380fddf3f..652ab19ba65 100644
--- a/lisp/epa-hook.el
+++ b/lisp/epa-hook.el
@@ -1,8 +1,9 @@
-;;; epa-hook.el --- preloaded code to enable epa-file.el
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; epa-hook.el --- preloaded code to enable epa-file.el -*- lexical-binding: t -*-
+;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
;; Author: Daiki Ueno <ueno@unixuser.org>
;; Keywords: PGP, GnuPG
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -108,5 +109,4 @@ Return the new status of auto encryption (non-nil means on)."
(provide 'epa-hook)
-;; arch-tag: f75c8a50-d32e-4eb3-9ec6-9e940c1fc8b5
;;; epa-hook.el ends here
diff --git a/lisp/epa-mail.el b/lisp/epa-mail.el
index 2334cce6565..a3f11f78675 100644
--- a/lisp/epa-mail.el
+++ b/lisp/epa-mail.el
@@ -1,8 +1,9 @@
-;;; epa-mail.el --- the EasyPG Assistant, minor-mode for mail composer
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; epa-mail.el --- the EasyPG Assistant, minor-mode for mail composer -*- lexical-binding: t -*-
+;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
;; 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 sign)
(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
@@ -182,5 +197,4 @@ Don't use this command in Lisp programs!"
(provide 'epa-mail)
-;; arch-tag: a6f82b3f-d177-4a11-af95-040da55927d2
;;; epa-mail.el ends here
diff --git a/lisp/epa.el b/lisp/epa.el
index bfde4b26121..d4f4fab2eed 100644
--- a/lisp/epa.el
+++ b/lisp/epa.el
@@ -1,5 +1,6 @@
-;;; epa.el --- the EasyPG Assistant
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; epa.el --- the EasyPG Assistant -*- lexical-binding: t -*-
+
+;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
;; Author: Daiki Ueno <ueno@unixuser.org>
;; Keywords: PGP, GnuPG
@@ -268,7 +269,7 @@ You should bind this variable with `let', but do not set it globally.")
:action 'epa--key-widget-action
:help-echo 'epa--key-widget-help-echo)
-(defun epa--key-widget-action (widget &optional event)
+(defun epa--key-widget-action (widget &optional _event)
(save-selected-window
(epa--show-key (widget-get widget :value))))
@@ -459,7 +460,7 @@ If ARG is non-nil, mark the key."
(list nil)))
(epa--list-keys name t))
-(defun epa--key-list-revert-buffer (&optional ignore-auto noconfirm)
+(defun epa--key-list-revert-buffer (&optional _ignore-auto _noconfirm)
(apply #'epa--list-keys epa-list-keys-arguments))
(defun epa--marked-keys ()
@@ -471,11 +472,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
@@ -491,13 +490,13 @@ If ARG is non-nil, mark the key."
- `\\[epa-mark-key]' to mark a key on the line
- `\\[epa-unmark-key]' to unmark a key on the line\n"))
(widget-create 'link
- :notify (lambda (&rest ignore) (abort-recursive-edit))
+ :notify (lambda (&rest _ignore) (abort-recursive-edit))
:help-echo
(substitute-command-keys
"Click here or \\[abort-recursive-edit] to cancel")
"Cancel")
(widget-create 'link
- :notify (lambda (&rest ignore) (exit-recursive-edit))
+ :notify (lambda (&rest _ignore) (exit-recursive-edit))
:help-echo
(substitute-command-keys
"Click here or \\[exit-recursive-edit] to finish")
@@ -635,8 +634,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: "
@@ -645,7 +649,7 @@ If SECRET is non-nil, list secret keys instead of public keys."
(format "Passphrase for %s %s: " key-id (cdr entry))
(format "Passphrase for %s: " key-id)))))))
-(defun epa-progress-callback-function (context what char current total
+(defun epa-progress-callback-function (_context what _char current total
handback)
(message "%s%d%% (%d/%d)" (or handback
(concat what ": "))
@@ -960,7 +964,7 @@ See the reason described in the `epa-verify-region' documentation."
(eval-and-compile
(if (fboundp 'select-safe-coding-system)
(defalias 'epa--select-safe-coding-system 'select-safe-coding-system)
- (defun epa--select-safe-coding-system (from to)
+ (defun epa--select-safe-coding-system (_from _to)
buffer-file-coding-system)))
;;;###autoload
@@ -1246,5 +1250,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 2b59bd3fd02..38f7dbdaa73 100644
--- a/lisp/epg-config.el
+++ b/lisp/epg-config.el
@@ -1,9 +1,10 @@
;;; epg-config.el --- configuration of the EasyPG Library
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
;; 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)
@@ -144,5 +147,4 @@ Note that the buffer name starts with a space."
(provide 'epg-config)
-;; arch-tag: 9aca7cb8-5f63-4bcb-84ee-46fd2db0763f
;;; epg-config.el ends here
diff --git a/lisp/epg.el b/lisp/epg.el
index 3bda4502a7f..348ad970b14 100644
--- a/lisp/epg.el
+++ b/lisp/epg.el
@@ -1,9 +1,9 @@
-;;; epg.el --- the EasyPG Library
-;; Copyright (C) 1999, 2000, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; epg.el --- the EasyPG Library -*- lexical-binding: t -*-
+;; Copyright (C) 1999-2000, 2002-2011 Free Software Foundation, Inc.
;; Author: Daiki Ueno <ueno@unixuser.org>
;; Keywords: PGP, GnuPG
+;; Version: 1.0.0
;; This file is part of GNU Emacs.
@@ -137,7 +137,8 @@
'((?e . encrypt)
(?s . sign)
(?c . certify)
- (?a . authentication)))
+ (?a . authentication)
+ (?D . disabled)))
(defvar epg-new-signature-type-alist
'((?D . detached)
@@ -1215,15 +1216,14 @@ This function is for internal use only."
"Delete the output file of CONTEXT."
(if (and (epg-context-output-file context)
(file-exists-p (epg-context-output-file context)))
- (let ((delete-by-moving-to-trash nil))
- (delete-file (epg-context-output-file context)))))
+ (delete-file (epg-context-output-file context))))
(eval-and-compile
(if (fboundp 'decode-coding-string)
(defalias 'epg--decode-coding-string 'decode-coding-string)
(defalias 'epg--decode-coding-string 'identity)))
-(defun epg--status-USERID_HINT (context string)
+(defun epg--status-USERID_HINT (_context string)
(if (string-match "\\`\\([^ ]+\\) \\(.*\\)" string)
(let* ((key-id (match-string 1 string))
(user-id (match-string 2 string))
@@ -1238,14 +1238,14 @@ This function is for internal use only."
(setq epg-user-id-alist (cons (cons key-id user-id)
epg-user-id-alist))))))
-(defun epg--status-NEED_PASSPHRASE (context string)
+(defun epg--status-NEED_PASSPHRASE (_context string)
(if (string-match "\\`\\([^ ]+\\)" string)
(setq epg-key-id (match-string 1 string))))
-(defun epg--status-NEED_PASSPHRASE_SYM (context string)
+(defun epg--status-NEED_PASSPHRASE_SYM (_context _string)
(setq epg-key-id 'SYM))
-(defun epg--status-NEED_PASSPHRASE_PIN (context string)
+(defun epg--status-NEED_PASSPHRASE_PIN (_context _string)
(setq epg-key-id 'PIN))
(eval-and-compile
@@ -1308,11 +1308,11 @@ This function is for internal use only."
(if encoded-passphrase-with-new-line
(epg--clear-string encoded-passphrase-with-new-line))))))
-(defun epg--prompt-GET_BOOL (context string)
+(defun epg--prompt-GET_BOOL (_context string)
(let ((entry (assoc string epg-prompt-alist)))
(y-or-n-p (if entry (cdr entry) (concat string "? ")))))
-(defun epg--prompt-GET_BOOL-untrusted_key.override (context string)
+(defun epg--prompt-GET_BOOL-untrusted_key.override (_context _string)
(y-or-n-p (if (and (equal (car epg-last-status) "USERID_HINT")
(string-match "\\`\\([^ ]+\\) \\(.*\\)"
(cdr epg-last-status)))
@@ -1467,31 +1467,31 @@ This function is for internal use only."
signature
(string-to-number (match-string 7 string) 16)))))
-(defun epg--status-TRUST_UNDEFINED (context string)
+(defun epg--status-TRUST_UNDEFINED (context _string)
(let ((signature (car (epg-context-result-for context 'verify))))
(if (and signature
(eq (epg-signature-status signature) 'good))
(epg-signature-set-validity signature 'undefined))))
-(defun epg--status-TRUST_NEVER (context string)
+(defun epg--status-TRUST_NEVER (context _string)
(let ((signature (car (epg-context-result-for context 'verify))))
(if (and signature
(eq (epg-signature-status signature) 'good))
(epg-signature-set-validity signature 'never))))
-(defun epg--status-TRUST_MARGINAL (context string)
+(defun epg--status-TRUST_MARGINAL (context _string)
(let ((signature (car (epg-context-result-for context 'verify))))
(if (and signature
(eq (epg-signature-status signature) 'marginal))
(epg-signature-set-validity signature 'marginal))))
-(defun epg--status-TRUST_FULLY (context string)
+(defun epg--status-TRUST_FULLY (context _string)
(let ((signature (car (epg-context-result-for context 'verify))))
(if (and signature
(eq (epg-signature-status signature) 'good))
(epg-signature-set-validity signature 'full))))
-(defun epg--status-TRUST_ULTIMATE (context string)
+(defun epg--status-TRUST_ULTIMATE (context _string)
(let ((signature (car (epg-context-result-for context 'verify))))
(if (and signature
(eq (epg-signature-status signature) 'good))
@@ -1541,10 +1541,10 @@ This function is for internal use only."
(string-to-number (match-string 3 string)))
(epg-context-result-for context 'encrypted-to)))))
-(defun epg--status-DECRYPTION_FAILED (context string)
+(defun epg--status-DECRYPTION_FAILED (context _string)
(epg-context-set-result-for context 'decryption-failed t))
-(defun epg--status-DECRYPTION_OKAY (context string)
+(defun epg--status-DECRYPTION_OKAY (context _string)
(epg-context-set-result-for context 'decryption-okay t))
(defun epg--status-NODATA (context string)
@@ -1566,13 +1566,13 @@ This function is for internal use only."
(epg--time-from-seconds string)))
(epg-context-result-for context 'error))))
-(defun epg--status-KEYREVOKED (context string)
+(defun epg--status-KEYREVOKED (context _string)
(epg-context-set-result-for
context 'key
(cons '(key-revoked)
(epg-context-result-for context 'error))))
-(defun epg--status-BADARMOR (context string)
+(defun epg--status-BADARMOR (context _string)
(epg-context-set-result-for
context 'error
(cons '(bad-armor)
@@ -1589,7 +1589,7 @@ This function is for internal use only."
(match-string 2 string)))
(epg-context-result-for context 'error)))))
-(defun epg--status-NO_RECP (context string)
+(defun epg--status-NO_RECP (context _string)
(epg-context-set-result-for
context 'error
(cons '(no-recipients)
@@ -1626,13 +1626,13 @@ This function is for internal use only."
(cons 'fingerprint (match-string 2 string)))
(epg-context-result-for context 'generate-key)))))
-(defun epg--status-KEY_NOT_CREATED (context string)
+(defun epg--status-KEY_NOT_CREATED (context _string)
(epg-context-set-result-for
context 'error
(cons '(key-not-created)
(epg-context-result-for context 'error))))
-(defun epg--status-IMPORTED (context string)
+(defun epg--status-IMPORTED (_context string)
(if (string-match "\\`\\([^ ]+\\) \\(.*\\)" string)
(let* ((key-id (match-string 1 string))
(user-id (match-string 2 string))
@@ -1694,7 +1694,7 @@ This function is for internal use only."
(epg-context-result-for context 'import-status)))
(epg-context-set-result-for context 'import-status nil)))
-(defun epg-passphrase-callback-function (context key-id handback)
+(defun epg-passphrase-callback-function (context key-id _handback)
(if (eq key-id 'SYM)
(read-passwd "Passphrase for symmetric encryption: "
(eq (epg-context-operation context) 'encrypt))
@@ -1905,8 +1905,7 @@ You can then use `write-region' to write new data into the file."
;; Cleanup the tempfile.
(and tempfile
(file-exists-p tempfile)
- (let ((delete-by-moving-to-trash nil))
- (delete-file tempfile)))
+ (delete-file tempfile))
;; Cleanup the tempdir.
(and tempdir
(file-directory-p tempdir)
@@ -2006,8 +2005,7 @@ If PLAIN is nil, it returns the result as a string."
(epg-read-output context))
(epg-delete-output-file context)
(if (file-exists-p input-file)
- (let ((delete-by-moving-to-trash nil))
- (delete-file input-file)))
+ (delete-file input-file))
(epg-reset context))))
(defun epg-start-verify (context signature &optional signed-text)
@@ -2104,8 +2102,7 @@ successful verification."
(epg-delete-output-file context)
(if (and input-file
(file-exists-p input-file))
- (let ((delete-by-moving-to-trash nil))
- (delete-file input-file)))
+ (delete-file input-file))
(epg-reset context))))
(defun epg-start-sign (context plain &optional mode)
@@ -2212,8 +2209,7 @@ Otherwise, it makes a cleartext signature."
(epg-read-output context))
(epg-delete-output-file context)
(if input-file
- (let ((delete-by-moving-to-trash nil))
- (delete-file input-file)))
+ (delete-file input-file))
(epg-reset context))))
(defun epg-start-encrypt (context plain recipients
@@ -2333,8 +2329,7 @@ If RECIPIENTS is nil, it performs symmetric encryption."
(epg-read-output context))
(epg-delete-output-file context)
(if input-file
- (let ((delete-by-moving-to-trash nil))
- (delete-file input-file)))
+ (delete-file input-file))
(epg-reset context))))
(defun epg-start-export-keys (context keys)
@@ -2654,5 +2649,4 @@ Type names are resolved using `epg-dn-type-alist'."
(provide 'epg)
-;; arch-tag: de8f0acc-1bcf-4c14-a09e-bfffe1b579b7
;;; epg.el ends here
diff --git a/lisp/erc/ChangeLog b/lisp/erc/ChangeLog
index 9e467f4cc25..187d338c1bc 100644
--- a/lisp/erc/ChangeLog
+++ b/lisp/erc/ChangeLog
@@ -1,27 +1,110 @@
+2011-05-03 Debarshi Ray <rishi@gnu.org> (tiny change)
+
+ * erc-backend.el (671): New response handler.
+ * erc.el (english): Add 671 to catalog.
+
+2011-04-29 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * erc-pcomplete.el (erc-pcomplete-nick-postfix): Remove the " " in the
+ suffix that's added by pcomplete-termination-string anyway.
+ (pcomplete-erc-setup): Remove pcomplete-suffix-list setting now that
+ it's not needed any more.
+
+2011-04-26 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * erc.el (erc-mode-map): Use completion-at-point.
+ (erc-mode): Tell completion-at-point to obey erc-complete-functions.
+ (erc-complete-word-at-point): New function.
+ (erc-complete-word): Make it obsolete.
+ * erc-pcomplete.el (erc-pcompletions-at-point): New function.
+ (pcomplete): Use it.
+ * erc-dcc.el (erc-dcc-chat-mode-map): Use completion-at-point.
+ (erc-dcc-chat-mode): Tell completion-at-point to obey
+ erc-complete-functions.
+ * erc-button.el (erc-button-next-function): New function extracted from
+ erc-button-next.
+ (button, erc-button-next): Use it.
+
2011-03-07 Chong Yidong <cyd@stupidchicken.com>
* Version 23.3 released.
+2011-03-04 Julien Danjou <julien@danjou.info>
+
+ * erc-track.el (erc-track-visibility): Fix :type. (Bug#6369)
+
+2011-02-10 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * erc-list.el (erc-list-menu-mode-map): Move initialization
+ into declaration.
+
+2011-02-07 Julien Danjou <julien@danjou.info>
+
+ * erc-track.el (erc-window-configuration-change): New function.
+ This will allow to track buffer visibility when a command is
+ finished to executed. Idea stolen from rcirc.
+ (track): Put erc-window-configuration-change in
+ window-configuration-change-hook.
+ (erc-modified-channels-update): Remove
+ erc-modified-channels-update from post-command-hook after update.
+
2011-01-31 Antoine Levitt <antoine.levitt@gmail.com> (tiny change)
* erc-track.el (track): Don't reset erc-modified-channels-object
each time erc-track-mode is activated.
-2010-10-23 Julien Danjou <julien@danjou.info>
+2011-01-13 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * erc.el (erc-mode):
+ * erc-dcc.el (erc-dcc-chat-mode): Use define-derived-mode.
+
+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).
@@ -32,8 +115,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>
@@ -103,7 +186,7 @@
See ChangeLog.08 for earlier changes.
- Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 2009-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -125,4 +208,3 @@ See ChangeLog.08 for earlier changes.
;; add-log-time-zone-rule: t
;; End:
-;; arch-tag: d4703244-4a8d-49b1-ab34-ad0d56600ef8
diff --git a/lisp/erc/ChangeLog.01 b/lisp/erc/ChangeLog.01
index 88610b96b66..4016586abc7 100644
--- a/lisp/erc/ChangeLog.01
+++ b/lisp/erc/ChangeLog.01
@@ -1035,7 +1035,7 @@
* erc-speak.el, erc.el: New file.
- Copyright (C) 2001, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 2001, 2006-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -1056,4 +1056,3 @@
;; coding: utf-8
;; End:
-;; arch-tag: 306c4b58-f9ae-4f3d-9fd9-db2d743f05a6
diff --git a/lisp/erc/ChangeLog.02 b/lisp/erc/ChangeLog.02
index 5785f3a0a43..09ab1cb3796 100644
--- a/lisp/erc/ChangeLog.02
+++ b/lisp/erc/ChangeLog.02
@@ -2596,7 +2596,7 @@
See ChangeLog.01 for earlier changes.
- Copyright (C) 2002, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2006-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -2617,4 +2617,3 @@ See ChangeLog.01 for earlier changes.
;; coding: utf-8
;; End:
-;; arch-tag: a6779d5e-99fa-442b-98cf-90e73eb2c272
diff --git a/lisp/erc/ChangeLog.03 b/lisp/erc/ChangeLog.03
index c7b8d1eb087..7f82a9bcbe2 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>
@@ -2140,7 +2140,7 @@
See ChangeLog.02 for earlier changes.
- Copyright (C) 2003, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 2003, 2006-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -2161,4 +2161,3 @@ See ChangeLog.02 for earlier changes.
;; coding: utf-8
;; End:
-;; arch-tag: 808865e1-3cce-4c5b-9997-95a8b7a9d384
diff --git a/lisp/erc/ChangeLog.04 b/lisp/erc/ChangeLog.04
index 2d57d051e2c..7db040fd23f 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,
@@ -2072,7 +2072,7 @@
See ChangeLog.03 for earlier changes.
- Copyright (C) 2004, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 2004, 2006-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -2093,4 +2093,3 @@ See ChangeLog.03 for earlier changes.
;; coding: utf-8
;; End:
-;; arch-tag: cc606d2d-635b-4b36-829b-a50e3c51e2d1
diff --git a/lisp/erc/ChangeLog.05 b/lisp/erc/ChangeLog.05
index 7facf9c31ca..fd5fde00a4a 100644
--- a/lisp/erc/ChangeLog.05
+++ b/lisp/erc/ChangeLog.05
@@ -1217,7 +1217,7 @@
See ChangeLog.04 for earlier changes.
- Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 2005-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -1238,4 +1238,3 @@ See ChangeLog.04 for earlier changes.
;; coding: utf-8
;; End:
-;; arch-tag: 70f1733a-3e2f-43c2-91c3-d9ace93f82ba
diff --git a/lisp/erc/ChangeLog.06 b/lisp/erc/ChangeLog.06
index 71b04b8b3cc..e3026c96a4d 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.
@@ -1430,7 +1430,7 @@
See ChangeLog.05 for earlier changes.
- Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 2006-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -1452,4 +1452,3 @@ See ChangeLog.05 for earlier changes.
;; add-log-time-zone-rule: t
;; End:
-;; arch-tag: 865a75f6-2bcb-46df-bf0c-b514dadf688a
diff --git a/lisp/erc/ChangeLog.07 b/lisp/erc/ChangeLog.07
index 050873f8356..b32155bbce4 100644
--- a/lisp/erc/ChangeLog.07
+++ b/lisp/erc/ChangeLog.07
@@ -812,7 +812,7 @@
See ChangeLog.06 for earlier changes.
- Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 2007-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -834,4 +834,3 @@ See ChangeLog.06 for earlier changes.
;; add-log-time-zone-rule: t
;; End:
-;; arch-tag: 3369b6e5-96b1-4b32-96cd-9a905c747496
diff --git a/lisp/erc/ChangeLog.08 b/lisp/erc/ChangeLog.08
index 404b1df8f7e..feff487fa6e 100644
--- a/lisp/erc/ChangeLog.08
+++ b/lisp/erc/ChangeLog.08
@@ -405,7 +405,7 @@
See ChangeLog.07 for earlier changes.
- Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 2008-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -427,4 +427,3 @@ See ChangeLog.07 for earlier changes.
;; add-log-time-zone-rule: t
;; End:
-;; arch-tag: 15787dfd-e091-4c8c-8b88-747b474e1ac7
diff --git a/lisp/erc/erc-autoaway.el b/lisp/erc/erc-autoaway.el
index f77a75f4748..a15e038dddc 100644
--- a/lisp/erc/erc-autoaway.el
+++ b/lisp/erc/erc-autoaway.el
@@ -1,7 +1,6 @@
;;; erc-autoaway.el --- Provides autoaway for ERC
-;; Copyright (C) 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2004, 2006-2011 Free Software Foundation, Inc.
;; Author: Jorgen Schaefer <forcer@forcix.cx>
;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?ErcAutoAway
@@ -286,4 +285,3 @@ activer server buffer available."
;; tab-width: 8
;; End:
-;; arch-tag: 16fc241e-8358-4b56-9fe2-116bdd0ba3bc
diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el
index 4a9fe594d4b..d363ea92bdb 100644
--- a/lisp/erc/erc-backend.el
+++ b/lisp/erc/erc-backend.el
@@ -1,6 +1,6 @@
;;; erc-backend.el --- Backend network communication for ERC
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Filename: erc-backend.el
;; Author: Lawrence Mitchell <wence@gmx.li>
@@ -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
@@ -1933,6 +1951,13 @@ See `erc-display-server-message'." nil
(erc-display-message parsed '(error notice) 'active 's482
?c channel ?m message)))
+(define-erc-response-handler (671)
+ "Secure connection response in WHOIS." nil
+ (let ((nick (second (erc-response.command-args parsed)))
+ (securemsg (erc-response.contents parsed)))
+ (erc-display-message parsed 'notice 'active 's671
+ ?n nick ?a securemsg)))
+
(define-erc-response-handler (431 445 446 451 462 463 464 481 483 484 485
491 501 502)
;; 431 - No nickname given
@@ -1976,4 +2001,3 @@ See `erc-display-error-notice'." nil
;; indent-tabs-mode: nil
;; End:
-;; arch-tag: a64e6bb7-a780-4efd-8f98-083b18c7c84a
diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el
index cf70c2e47f7..3a897347dea 100644
--- a/lisp/erc/erc-button.el
+++ b/lisp/erc/erc-button.el
@@ -1,7 +1,6 @@
;; erc-button.el --- A way of buttonizing certain things in ERC buffers
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2004, 2006-2011 Free Software Foundation, Inc.
;; Author: Mario Lang <mlang@delysid.org>
;; Keywords: irc, button, url, regexp
@@ -54,11 +53,11 @@
"This mode buttonizes all messages according to `erc-button-alist'."
((add-hook 'erc-insert-modify-hook 'erc-button-add-buttons 'append)
(add-hook 'erc-send-modify-hook 'erc-button-add-buttons 'append)
- (add-hook 'erc-complete-functions 'erc-button-next)
+ (add-hook 'erc-complete-functions 'erc-button-next-function)
(add-hook 'erc-mode-hook 'erc-button-setup))
((remove-hook 'erc-insert-modify-hook 'erc-button-add-buttons)
(remove-hook 'erc-send-modify-hook 'erc-button-add-buttons)
- (remove-hook 'erc-complete-functions 'erc-button-next)
+ (remove-hook 'erc-complete-functions 'erc-button-next-function)
(remove-hook 'erc-mode-hook 'erc-button-setup)
(when (featurep 'xemacs)
(dolist (buffer (erc-buffer-list))
@@ -428,21 +427,28 @@ call it with the value of the `erc-data' text property."
(error "Function %S is not bound" fun))
(apply fun data)))
+(defun erc-button-next-function ()
+ "Pseudo completion function that actually jumps to the next button.
+For use on `completion-at-point-functions'."
+ (let ((here (point)))
+ (when (< here (erc-beg-of-input-line))
+ (lambda ()
+ (while (and (get-text-property here 'erc-callback)
+ (not (= here (point-max))))
+ (setq here (1+ here)))
+ (while (and (not (get-text-property here 'erc-callback))
+ (not (= here (point-max))))
+ (setq here (1+ here)))
+ (if (< here (point-max))
+ (goto-char here)
+ (error "No next button"))
+ t))))
+
(defun erc-button-next ()
"Go to the next button in this buffer."
(interactive)
- (let ((here (point)))
- (when (< here (erc-beg-of-input-line))
- (while (and (get-text-property here 'erc-callback)
- (not (= here (point-max))))
- (setq here (1+ here)))
- (while (and (not (get-text-property here 'erc-callback))
- (not (= here (point-max))))
- (setq here (1+ here)))
- (if (< here (point-max))
- (goto-char here)
- (error "No next button"))
- t)))
+ (let ((f (erc-button-next-function)))
+ (if f (funcall f))))
(defun erc-button-previous ()
"Go to the previous button in this buffer."
@@ -534,4 +540,3 @@ and `apropos' for other symbols."
;; indent-tabs-mode: nil
;; End:
-;; arch-tag: 7d23bed4-2f30-4273-a03f-d7a274c605c4
diff --git a/lisp/erc/erc-capab.el b/lisp/erc/erc-capab.el
index e66170227cc..6b76c4246ad 100644
--- a/lisp/erc/erc-capab.el
+++ b/lisp/erc/erc-capab.el
@@ -1,6 +1,6 @@
;;; erc-capab.el --- support for dancer-ircd and hyperion's CAPAB
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
;; 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
@@ -202,5 +202,4 @@ PARSED is an `erc-parsed' response struct."
(provide 'erc-capab)
-;; arch-tag: 27b6d668-7ee5-4e47-b9f0-27d7a4362062
;;; erc-capab.el ends here
diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el
index f9830f9dae8..792c8dd88b3 100644
--- a/lisp/erc/erc-compat.el
+++ b/lisp/erc/erc-compat.el
@@ -1,7 +1,6 @@
;;; erc-compat.el --- ERC compatibility code for XEmacs
-;; Copyright (C) 2002, 2003, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2003, 2005-2011 Free Software Foundation, Inc.
;; Author: Alex Schroeder <alex@gnu.org>
;; URL: http://www.emacswiki.org/cgi-bin/wiki/ERC
@@ -165,4 +164,3 @@ If START or END is negative, it counts from the end."
;; tab-width: 8
;; End:
-;; arch-tag: 8948ffe0-aff8-4ad8-a196-368ebbfd58ff
diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el
index 9b8a4310992..19e1801e03c 100644
--- a/lisp/erc/erc-dcc.el
+++ b/lisp/erc/erc-dcc.el
@@ -1,7 +1,7 @@
;;; erc-dcc.el --- CTCP DCC module for ERC
-;; Copyright (C) 1993, 1994, 1995, 1998, 2002, 2003, 2004, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1995, 1998, 2002-2004, 2006-2011
+;; Free Software Foundation, Inc.
;; Author: Ben A. Mesander <ben@gnu.ai.mit.edu>
;; Noah Friedman <friedman@prep.ai.mit.edu>
@@ -1094,21 +1094,16 @@ Possible values are: ask, auto, ignore."
(defvar erc-dcc-chat-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "RET") 'erc-send-current-line)
- (define-key map "\t" 'erc-complete-word)
+ (define-key map "\t" 'completion-at-point)
map)
"Keymap for `erc-dcc-mode'.")
-(defun erc-dcc-chat-mode ()
+(define-derived-mode erc-dcc-chat-mode fundamental-mode "DCC-Chat"
"Major mode for wasting time via DCC chat."
- (interactive)
- (kill-all-local-variables)
(setq mode-line-process '(":%s")
- mode-name "DCC-Chat"
- major-mode 'erc-dcc-chat-mode
erc-send-input-line-function 'erc-dcc-chat-send-input-line
erc-default-recipients '(dcc))
- (use-local-map erc-dcc-chat-mode-map)
- (run-hooks 'erc-dcc-chat-mode-hook))
+ (add-hook 'completion-at-point-functions 'erc-complete-word-at-point nil t))
(defun erc-dcc-chat-send-input-line (recipient line &optional force)
"Send LINE to the remote end.
@@ -1257,4 +1252,3 @@ other client."
;; indent-tabs-mode: nil
;; End:
-;; arch-tag: cda5a6b3-c510-4dbe-b699-84cccfa04edb
diff --git a/lisp/erc/erc-ezbounce.el b/lisp/erc/erc-ezbounce.el
index fe9e4bec2f6..b480d83e283 100644
--- a/lisp/erc/erc-ezbounce.el
+++ b/lisp/erc/erc-ezbounce.el
@@ -1,6 +1,6 @@
;;; erc-ezbounce.el --- Handle EZBounce bouncer commands
-;; Copyright (C) 2002, 2004, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002, 2004, 2006-2011 Free Software Foundation, Inc.
;; Author: Andreas Fuchs <asf@void.at>
;; Keywords: comm
@@ -174,5 +174,4 @@ in the alist is `nil', prompt for the appropriate values."
(provide 'erc-ezbounce)
-;; arch-tag: e972aa7b-a9f4-4d16-a489-074ec7a1002e
;;; erc-ezbounce.el ends here
diff --git a/lisp/erc/erc-fill.el b/lisp/erc/erc-fill.el
index c3d6f50b53d..0b9a4051d65 100644
--- a/lisp/erc/erc-fill.el
+++ b/lisp/erc/erc-fill.el
@@ -1,7 +1,6 @@
;;; erc-fill.el --- Filling IRC messages in various ways
-;; Copyright (C) 2001, 2002, 2003, 2004, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001-2004, 2006-2011 Free Software Foundation, Inc.
;; Author: Andreas Fuchs <asf@void.at>
;; Mario Lang <mlang@delysid.org>
@@ -193,4 +192,3 @@ You can put this on `erc-insert-modify-hook' and/or `erc-send-modify-hook'."
;; indent-tabs-mode: nil
;; End:
-;; arch-tag: 89224581-c2c2-4e26-92e5-e3a390dc516a
diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el
index 5d86a2022f6..b2cf9e35622 100644
--- a/lisp/erc/erc-goodies.el
+++ b/lisp/erc/erc-goodies.el
@@ -1,7 +1,6 @@
;; erc-goodies.el --- Collection of ERC modules
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;; Author: Jorgen Schaefer <forcer@forcix.cx>
@@ -569,5 +568,4 @@ servers. If called from a program, PROC specifies the server process."
(provide 'erc-goodies)
-;; arch-tag: d987ae26-9e28-4c72-9596-e617309fb582
;;; erc-goodies.el ends here
diff --git a/lisp/erc/erc-ibuffer.el b/lisp/erc/erc-ibuffer.el
index 42dc37cb03c..9d658eec2f0 100644
--- a/lisp/erc/erc-ibuffer.el
+++ b/lisp/erc/erc-ibuffer.el
@@ -1,7 +1,6 @@
;;; erc-ibuffer.el --- ibuffer integration with ERC
-;; Copyright (C) 2002, 2004, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002, 2004, 2006-2011 Free Software Foundation, Inc.
;; Author: Mario Lang <mlang@delysid.org>
;; Keywords: comm
@@ -190,4 +189,3 @@
;; tab-width: 8
;; End:
-;; arch-tag: fbad56a5-8595-45e0-a8c8-d8bb91e26944
diff --git a/lisp/erc/erc-identd.el b/lisp/erc/erc-identd.el
index 2442d5e8aa5..140802deff0 100644
--- a/lisp/erc/erc-identd.el
+++ b/lisp/erc/erc-identd.el
@@ -1,6 +1,6 @@
;;; erc-identd.el --- RFC1413 (identd authentication protocol) server
-;; Copyright (C) 2003, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2006-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
;; Keywords: comm, processes
@@ -118,4 +118,3 @@ The default port is specified by `erc-identd-port'."
;; tab-width: 8
;; End:
-;; arch-tag: e0b5f926-0f35-40b9-8ddb-ca06b62a7544
diff --git a/lisp/erc/erc-imenu.el b/lisp/erc/erc-imenu.el
index 7ab91db33bf..3e6e853ff70 100644
--- a/lisp/erc/erc-imenu.el
+++ b/lisp/erc/erc-imenu.el
@@ -1,6 +1,6 @@
;;; erc-imenu.el -- Imenu support for ERC
-;; Copyright (C) 2001, 2002, 2004, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001-2002, 2004, 2006-2011 Free Software Foundation, Inc.
;; Author: Mario Lang <mlang@delysid.org>
;; Keywords: comm
@@ -133,4 +133,3 @@ Don't rely on this function, read it first!"
;; tab-width: 8
;; End:
-;; arch-tag: 35c69082-ca29-43f7-a050-8da5f400de81
diff --git a/lisp/erc/erc-join.el b/lisp/erc/erc-join.el
index 8e7eeedad53..c158c47ab64 100644
--- a/lisp/erc/erc-join.el
+++ b/lisp/erc/erc-join.el
@@ -1,6 +1,6 @@
;;; erc-join.el --- autojoin channels on connect and reconnects
-;; Copyright (C) 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2004, 2006-2011 Free Software Foundation, Inc.
;; Author: Alex Schroeder <alex@gnu.org>
;; Keywords: irc
@@ -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'."
@@ -134,4 +202,3 @@ servers, presumably in the same domain."
;; tab-width: 8
;; End:
-;; arch-tag: d62d8b15-8e31-49d6-8a73-12f11e717414
diff --git a/lisp/erc/erc-lang.el b/lisp/erc/erc-lang.el
index f66365a2e6f..84a4c60816e 100644
--- a/lisp/erc/erc-lang.el
+++ b/lisp/erc/erc-lang.el
@@ -1,6 +1,6 @@
;;; erc-lang.el --- provide the LANG command to ERC
-;; Copyright (C) 2002, 2004, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002, 2004, 2006-2011 Free Software Foundation, Inc.
;; Author: Alex Schroeder <alex@gnu.org>
;; Maintainer: Alex Schroeder <alex@gnu.org>
@@ -197,17 +197,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 3a3b40e4850..b8eb5a4aa19 100644
--- a/lisp/erc/erc-list.el
+++ b/lisp/erc/erc-list.el
@@ -1,6 +1,6 @@
;;; erc-list.el --- /list support for ERC
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Tom Tromey <tromey@redhat.com>
;; Version: 0.1
@@ -117,27 +117,23 @@
(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)))
+ (set-keymap-parent map special-mode-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)
+ 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.")
-
-(unless erc-list-menu-sort-button-map
+(defvar erc-list-menu-sort-button-map
(let ((map (make-sparse-keymap)))
(define-key map [header-line mouse-1] 'erc-list-menu-sort-by-column)
(define-key map [follow-link] 'mouse-face)
- (setq erc-list-menu-sort-button-map map)))
+ map)
+ "Local keymap for ERC list menu mode sorting buttons.")
;; Helper function that makes a buttonized column header.
(defun erc-list-button (title column)
@@ -147,7 +143,7 @@
'mouse-face 'highlight
'keymap erc-list-menu-sort-button-map))
-(define-derived-mode erc-list-menu-mode nil "ERC-List"
+(define-derived-mode erc-list-menu-mode special-mode "ERC-List"
"Major mode for editing a list of irc channels."
(setq header-line-format
(concat
@@ -224,4 +220,3 @@ to RFC and send the LIST header (#321) at start of list transmission."
;; tab-width: 8
;; End:
-;; arch-tag: 99c5f9cb-6bac-4224-86bf-e394768cd1d0
diff --git a/lisp/erc/erc-log.el b/lisp/erc/erc-log.el
index de6d755eb65..24990e1e068 100644
--- a/lisp/erc/erc-log.el
+++ b/lisp/erc/erc-log.el
@@ -1,6 +1,6 @@
;;; erc-log.el --- Logging facilities for ERC.
-;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003-2011 Free Software Foundation, Inc.
;; Author: Lawrence Mitchell <wence@gmx.li>
;; Keywords: IRC, chat, client, Internet, logging
@@ -451,4 +451,3 @@ You can save every individual message by putting this function on
;; tab-width: 8
;; End:
-;; arch-tag: 54072f99-9f0a-4846-8908-2ccde92221de
diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el
index 24170caa126..bde51da6e3d 100644
--- a/lisp/erc/erc-match.el
+++ b/lisp/erc/erc-match.el
@@ -1,7 +1,6 @@
;;; erc-match.el --- Highlight messages matching certain regexps
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Andreas Fuchs <asf@void.at>
;; Keywords: comm, faces
@@ -635,4 +634,3 @@ This function is meant to be called from `erc-text-matched-hook'."
;; tab-width: 8
;; End:
-;; arch-tag: 1f1f595e-abcc-4b0b-83db-598a1d3f0f82
diff --git a/lisp/erc/erc-menu.el b/lisp/erc/erc-menu.el
index 627b0453c8e..ea4ed399a64 100644
--- a/lisp/erc/erc-menu.el
+++ b/lisp/erc/erc-menu.el
@@ -1,7 +1,6 @@
;; erc-menu.el -- Menu-bar definitions for ERC
-;; Copyright (C) 2001, 2002, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001-2002, 2004-2011 Free Software Foundation, Inc.
;; Author: Mario Lang <mlang@delysid.org>
;; Keywords: comm, processes, menu
@@ -148,4 +147,3 @@ ERC menu yet.")
;; tab-width: 8
;; End:
-;; arch-tag: 671219f2-b082-4753-a185-1d0c7e0c05bd
diff --git a/lisp/erc/erc-netsplit.el b/lisp/erc/erc-netsplit.el
index 4003431f6a4..d5f4ec48ba9 100644
--- a/lisp/erc/erc-netsplit.el
+++ b/lisp/erc/erc-netsplit.el
@@ -1,6 +1,6 @@
;;; erc-netsplit.el --- Reduce JOIN/QUIT messages on netsplits
-;; Copyright (C) 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2004, 2006-2011 Free Software Foundation, Inc.
;; Author: Mario Lang <mlang@delysid.org>
;; Keywords: comm
@@ -209,4 +209,3 @@ join from that split has been detected or not.")
;; tab-width: 8
;; End:
-;; arch-tag: 61a85cb0-7e7b-4312-a4f6-313c7a25a6e8
diff --git a/lisp/erc/erc-networks.el b/lisp/erc/erc-networks.el
index f20f0b397d9..1f94ef44093 100644
--- a/lisp/erc/erc-networks.el
+++ b/lisp/erc/erc-networks.el
@@ -1,6 +1,6 @@
;;; erc-networks.el --- IRC networks
-;; Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002, 2004-2011 Free Software Foundation, Inc.
;; Author: Mario Lang <mlang@lexx.delysid.org>
;; Keywords: comm
@@ -865,4 +865,3 @@ VALUE is the options value.")
;; tab-width: 8
;; End:
-;; arch-tag: 68cccabd-f66b-456c-9abe-5f993a2dc91c
diff --git a/lisp/erc/erc-notify.el b/lisp/erc/erc-notify.el
index 80427be16dd..1b245ec2e33 100644
--- a/lisp/erc/erc-notify.el
+++ b/lisp/erc/erc-notify.el
@@ -1,6 +1,6 @@
;;; erc-notify.el --- Online status change notification
-;; Copyright (C) 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2004, 2006-2011 Free Software Foundation, Inc.
;; Author: Mario Lang <mlang@lexx.delysid.org>
;; Keywords: comm
@@ -251,4 +251,3 @@ with args, toggle notify status of people."
;; tab-width: 8
;; End:
-;; arch-tag: 0fb19dd0-1359-458a-89b7-81dc195a588e
diff --git a/lisp/erc/erc-page.el b/lisp/erc/erc-page.el
index aaaf800956a..5776dd6fc1a 100644
--- a/lisp/erc/erc-page.el
+++ b/lisp/erc/erc-page.el
@@ -1,6 +1,6 @@
;; erc-page.el - CTCP PAGE support for ERC
-;; Copyright (C) 2002, 2004, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation
+;; Copyright (C) 2002, 2004, 2006-2011 Free Software Foundation
;; This file is part of GNU Emacs.
@@ -109,4 +109,3 @@ receive pages if `erc-page-mode' is on."
;; tab-width: 8
;; End:
-;; arch-tag: 82fd2e0e-6060-4dd2-9788-8c1411e844de
diff --git a/lisp/erc/erc-pcomplete.el b/lisp/erc/erc-pcomplete.el
index 0b1071ce790..eb1398d5b05 100644
--- a/lisp/erc/erc-pcomplete.el
+++ b/lisp/erc/erc-pcomplete.el
@@ -1,6 +1,6 @@
;;; erc-pcomplete.el --- Provides programmable completion for ERC
-;; Copyright (C) 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2004, 2006-2011 Free Software Foundation, Inc.
;; Author: Sacha Chua <sacha@free.net.ph>
;; Keywords: comm, convenience
@@ -48,7 +48,7 @@
"Programmable completion for ERC"
:group 'erc)
-(defcustom erc-pcomplete-nick-postfix ": "
+(defcustom erc-pcomplete-nick-postfix ":"
"*When `pcomplete' is used in the first word after the prompt,
add this string to nicks completed."
:group 'erc-pcomplete
@@ -64,10 +64,16 @@ the most recent speakers are listed first."
(define-erc-module pcomplete Completion
"In ERC Completion mode, the TAB key does completion whenever possible."
((add-hook 'erc-mode-hook 'pcomplete-erc-setup)
- (add-hook 'erc-complete-functions 'erc-pcomplete)
+ (add-hook 'erc-complete-functions 'erc-pcompletions-at-point)
(erc-buffer-list #'pcomplete-erc-setup))
((remove-hook 'erc-mode-hook 'pcomplete-erc-setup)
- (remove-hook 'erc-complete-functions 'erc-pcomplete)))
+ (remove-hook 'erc-complete-functions 'erc-pcompletions-at-point)))
+
+(defun erc-pcompletions-at-point ()
+ "ERC completion data from pcomplete.
+for use on `completion-at-point-function'."
+ (when (> (point) (erc-beg-of-input-line))
+ (pcomplete-completions-at-point)))
(defun erc-pcomplete ()
"Complete the nick before point."
@@ -87,8 +93,6 @@ the most recent speakers are listed first."
t)
(set (make-local-variable 'pcomplete-use-paring)
nil)
- (set (make-local-variable 'pcomplete-suffix-list)
- '(? ?:))
(set (make-local-variable 'pcomplete-parse-arguments-function)
'pcomplete-parse-erc-arguments)
(set (make-local-variable 'pcomplete-command-completion-function)
@@ -279,4 +283,3 @@ up to where point is right now."
;; indent-tabs-mode: nil
;; End:
-;; arch-tag: 32a7703b-be87-45a4-82f3-9eed5a628911
diff --git a/lisp/erc/erc-replace.el b/lisp/erc/erc-replace.el
index df339fec4e8..4d3ba1e230d 100644
--- a/lisp/erc/erc-replace.el
+++ b/lisp/erc/erc-replace.el
@@ -1,7 +1,6 @@
;; erc-replace.el -- wash and massage messages inserted into the buffer
-;; Copyright (C) 2001, 2002, 2004, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001-2002, 2004, 2006-2011 Free Software Foundation, Inc.
;; Author: Andreas Fuchs <asf@void.at>
;; Maintainer: Mario Lang (mlang@delysid.org)
@@ -94,4 +93,3 @@ It replaces text according to `erc-replace-alist'."
;; tab-width: 8
;; End:
-;; arch-tag: dd904a59-d8a6-47f8-ac3a-76b698289a18
diff --git a/lisp/erc/erc-ring.el b/lisp/erc/erc-ring.el
index 6564d1446fd..345c636fa79 100644
--- a/lisp/erc/erc-ring.el
+++ b/lisp/erc/erc-ring.el
@@ -1,7 +1,6 @@
;; erc-ring.el -- Command history handling for erc using ring.el
-;; Copyright (C) 2001, 2002, 2003, 2004, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001-2004, 2006-2011 Free Software Foundation, Inc.
;; Author: Alex Schroeder <alex@gnu.org>
;; Keywords: comm
@@ -144,4 +143,3 @@ containing a password."
;; indent-tabs-mode: nil
;; End:
-;; arch-tag: b77924a8-a80e-489d-84cd-b351761ea5c8
diff --git a/lisp/erc/erc-services.el b/lisp/erc/erc-services.el
index 582737e7246..3acc600b425 100644
--- a/lisp/erc/erc-services.el
+++ b/lisp/erc/erc-services.el
@@ -1,6 +1,6 @@
;;; erc-services.el --- Identify to NickServ
-;; Copyright (C) 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2004, 2006-2011 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
@@ -445,4 +445,3 @@ When called interactively, read the password using `read-passwd'."
;; tab-width: 8
;; End:
-;; arch-tag: d401c8aa-d938-4255-96a9-3efb64c47e58
diff --git a/lisp/erc/erc-sound.el b/lisp/erc/erc-sound.el
index 9664df90f3b..3253aec3386 100644
--- a/lisp/erc/erc-sound.el
+++ b/lisp/erc/erc-sound.el
@@ -1,6 +1,6 @@
;;; erc-sound.el --- CTCP SOUND support for ERC
-;; Copyright (C) 2002, 2003, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2003, 2006-2011 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
@@ -147,4 +147,3 @@ See also `play-sound-file'."
;; tab-width: 8
;; End:
-;; arch-tag: 53657d1d-007f-4a20-91c1-588e71cf0cee
diff --git a/lisp/erc/erc-speedbar.el b/lisp/erc/erc-speedbar.el
index aa45230af0d..3d80371cc68 100644
--- a/lisp/erc/erc-speedbar.el
+++ b/lisp/erc/erc-speedbar.el
@@ -1,7 +1,6 @@
;;; erc-speedbar.el --- Speedbar support for ERC
-;; Copyright (C) 2001, 2002, 2003, 2004, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001-2004, 2006-2011 Free Software Foundation, Inc.
;; Author: Mario Lang <mlang@delysid.org>
;; Contributor: Eric M. Ludlam <eric@siege-engine.com>
@@ -366,4 +365,3 @@ The INDENT level is ignored."
;; tab-width: 8
;; End:
-;; arch-tag: 7a6558a4-3308-4bf5-a284-e1d042c933c6
diff --git a/lisp/erc/erc-spelling.el b/lisp/erc/erc-spelling.el
index 6e8fe5649d6..5bb3c877dbe 100644
--- a/lisp/erc/erc-spelling.el
+++ b/lisp/erc/erc-spelling.el
@@ -1,6 +1,6 @@
;;; erc-spelling.el --- use flyspell in ERC
-;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2005-2011 Free Software Foundation, Inc.
;; Author: Jorgen Schaefer <forcer@forcix.cx>
;; Keywords: irc
@@ -106,5 +106,4 @@ The cadr is the beginning and the caddr is the end."
(provide 'erc-spelling)
-;; arch-tag: 04ae1c46-0fd1-4e1a-8b80-55bfa471c945
;;; erc-spelling.el ends here
diff --git a/lisp/erc/erc-stamp.el b/lisp/erc/erc-stamp.el
index 1efe8983cf0..cfe8616ab65 100644
--- a/lisp/erc/erc-stamp.el
+++ b/lisp/erc/erc-stamp.el
@@ -1,7 +1,6 @@
;;; erc-stamp.el --- Timestamping for ERC messages
-;; Copyright (C) 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2004, 2006-2011 Free Software Foundation, Inc.
;; Author: Mario Lang <mlang@delysid.org>
;; Keywords: comm, processes, timestamp
@@ -422,4 +421,3 @@ NOW is position of point currently."
;; tab-width: 8
;; End:
-;; arch-tag: 57aefab4-63e0-4c48-91d5-6efa145487e0
diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el
index b78880e86b4..28c1ced91c6 100644
--- a/lisp/erc/erc-track.el
+++ b/lisp/erc/erc-track.el
@@ -1,7 +1,6 @@
;;; erc-track.el --- Track modified channel buffers
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Mario Lang <mlang@delysid.org>
;; Keywords: comm, faces
@@ -85,8 +84,8 @@ Activity means that there was no user input in the last 10 seconds."
:type '(choice (const :tag "All frames" t)
(const :tag "All visible frames" visible)
(const :tag "Only the selected frame" nil)
- (const :tag "Only the selected frame if it was active"
- active)))
+ (const :tag "Only the selected frame if it is visible"
+ selected-visible)))
(defcustom erc-track-exclude nil
"A list targets (channel names or query targets) which should not be tracked."
@@ -654,7 +653,7 @@ module, otherwise the keybindings will not do anything useful."
(defadvice switch-to-buffer (after erc-update (&rest args) activate)
(erc-modified-channels-update))
(add-hook 'window-configuration-change-hook
- 'erc-modified-channels-update))
+ 'erc-window-configuration-change))
(add-hook 'erc-insert-post-hook 'erc-track-modified-channels)
(add-hook 'erc-disconnected-hook 'erc-modified-channels-update))
;; enable the tracking keybindings
@@ -676,7 +675,7 @@ module, otherwise the keybindings will not do anything useful."
(if (featurep 'xemacs)
(ad-disable-advice 'switch-to-buffer 'after 'erc-update)
(remove-hook 'window-configuration-change-hook
- 'erc-modified-channels-update))
+ 'erc-window-configuration-change))
(remove-hook 'erc-disconnected-hook 'erc-modified-channels-update)
(remove-hook 'erc-insert-post-hook 'erc-track-modified-channels))
;; disable the tracking keybindings
@@ -731,6 +730,12 @@ only consider active buffers visible.")
;;; Tracking the channel modifications
+(defun erc-window-configuration-change ()
+ (unless (minibuffer-window-active-p (minibuffer-window))
+ ;; delay this until command has finished to make sure window is
+ ;; actually visible before clearing activity
+ (add-hook 'post-command-hook 'erc-modified-channels-update)))
+
(defvar erc-modified-channels-update-inside nil
"Variable to prevent running `erc-modified-channels-update' multiple
times. Without it, you cannot debug `erc-modified-channels-display',
@@ -758,8 +763,9 @@ ARGS are ignored."
(erc-modified-channels-remove-buffer buffer))))
erc-modified-channels-alist)
(when removed-channel
- (erc-modified-channels-display)
- (force-mode-line-update t)))))
+ (erc-modified-channels-display)
+ (force-mode-line-update t)))
+ (remove-hook 'post-command-hook 'erc-modified-channels-update)))
(defvar erc-track-mouse-face (if (featurep 'xemacs)
'modeline-mousable
@@ -1067,4 +1073,3 @@ switch back to the last non-ERC buffer visited. Next is defined by
;; tab-width: 8
;; End:
-;; arch-tag: 11b439f5-e5d7-4c6c-bb3f-eda98f9b0ac1
diff --git a/lisp/erc/erc-truncate.el b/lisp/erc/erc-truncate.el
index 9ed32b6c6e0..46668508637 100644
--- a/lisp/erc/erc-truncate.el
+++ b/lisp/erc/erc-truncate.el
@@ -1,6 +1,6 @@
;;; erc-truncate.el --- Functions for truncating ERC buffers
-;; Copyright (C) 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003-2004, 2006-2011 Free Software Foundation, Inc.
;; Author: Andreas Fuchs <asf@void.at>
;; Keywords: IRC, chat, client, Internet, logging
@@ -115,4 +115,3 @@ Meant to be used in hooks, like `erc-insert-post-hook'."
;; tab-width: 8
;; End:
-;; arch-tag: 22a2ea78-871f-4870-8f1e-efe534170311
diff --git a/lisp/erc/erc-xdcc.el b/lisp/erc/erc-xdcc.el
index 80b4afab097..f4f75c15206 100644
--- a/lisp/erc/erc-xdcc.el
+++ b/lisp/erc/erc-xdcc.el
@@ -1,6 +1,6 @@
;;; erc-xdcc.el --- XDCC file-server support for ERC
-;; Copyright (C) 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003-2004, 2006-2011 Free Software Foundation, Inc.
;; Author: Mario Lang <mlang@delysid.org>
;; Keywords: comm, processes
@@ -136,4 +136,3 @@ being evaluated and should return strings."
;; tab-width: 8
;; End:
-;; arch-tag: a13b62fe-2399-4562-af4e-f18a8dd4b9c8
diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el
index 9249410a87a..a8c592696ad 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -1,7 +1,6 @@
;; erc.el --- An Emacs Internet Relay Chat client
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2011 Free Software Foundation, Inc.
;; Author: Alexander L. Belikoff (alexander@belikoff.net)
;; Contributors: Sergey Berezin (sergey.berezin@cs.cmu.edu),
@@ -12,6 +11,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.
@@ -1110,7 +1110,7 @@ which the local user typed."
(define-key map "\C-c\C-u" 'erc-kill-input)
(define-key map "\C-c\C-x" 'erc-quit-server)
(define-key map "\M-\t" 'ispell-complete-word)
- (define-key map "\t" 'erc-complete-word)
+ (define-key map "\t" 'completion-at-point)
;; Suppress `font-lock-fontify-block' key binding since it
;; destroys face properties.
@@ -1438,19 +1438,9 @@ Defaults to the server buffer."
;; Mode activation routines
-(defun erc-mode ()
- "Major mode for Emacs IRC.
-Special commands:
-
-\\{erc-mode-map}
-
-Turning on `erc-mode' runs the hook `erc-mode-hook'."
- (kill-all-local-variables)
- (use-local-map erc-mode-map)
- (setq mode-name "ERC"
- major-mode 'erc-mode
- local-abbrev-table erc-mode-abbrev-table)
- (set-syntax-table erc-mode-syntax-table)
+(define-derived-mode erc-mode fundamental-mode "ERC"
+ "Major mode for Emacs IRC."
+ (setq local-abbrev-table erc-mode-abbrev-table)
(when (boundp 'next-line-add-newlines)
(set (make-local-variable 'next-line-add-newlines) nil))
(setq line-move-ignore-invisible t)
@@ -1458,8 +1448,7 @@ Turning on `erc-mode' runs the hook `erc-mode-hook'."
(concat "\C-l\\|\\(^" (regexp-quote (erc-prompt)) "\\)"))
(set (make-local-variable 'paragraph-start)
(concat "\\(" (regexp-quote (erc-prompt)) "\\)"))
- ;; Run the mode hooks
- (run-hooks 'erc-mode-hook))
+ (add-hook 'completion-at-point-functions 'erc-complete-word-at-point nil t))
;; activation
@@ -2306,14 +2295,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))
@@ -3815,13 +3804,10 @@ This places `point' just after the prompt, or at the beginning of the line."
(setq erc-input-ring-index nil))
(kill-line)))
-(defun erc-complete-word ()
- "Complete the word before point.
+(defun erc-complete-word-at-point ()
+ (run-hook-with-args-until-success 'erc-complete-functions))
-This function uses `erc-complete-functions'."
- (interactive)
- (unless (run-hook-with-args-until-success 'erc-complete-functions)
- (beep)))
+(define-obsolete-function-alias 'erc-complete-word 'completion-at-point "24.1")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
@@ -6365,7 +6351,8 @@ All windows are opened in the current frame."
(s485 . "You're not the original channel operator")
(s491 . "No O-lines for your host")
(s501 . "Unknown MODE flag")
- (s502 . "You can't change modes for other users")))
+ (s502 . "You can't change modes for other users")
+ (s671 . "%n %a")))
(defun erc-message-english-PART (&rest args)
"Format a proper PART message.
@@ -6540,4 +6527,3 @@ Otherwise, connect to HOST:PORT as USER and /join CHANNEL."
;; tab-width: 8
;; End:
-;; arch-tag: d19587f6-627e-48c1-8d86-58595fa3eca3
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/.gitignore b/lisp/eshell/.gitignore
index 8f16f9600f5..2abf84ba3ee 100644
--- a/lisp/eshell/.gitignore
+++ b/lisp/eshell/.gitignore
@@ -1,3 +1,2 @@
esh-groups.el
-# arch-tag: 270e983f-fee5-4b6d-a00b-c1bafdee8690
diff --git a/lisp/eshell/em-alias.el b/lisp/eshell/em-alias.el
index c47a2d2fbe3..4e1dbd41045 100644
--- a/lisp/eshell/em-alias.el
+++ b/lisp/eshell/em-alias.el
@@ -1,7 +1,6 @@
;;; em-alias.el --- creation and management of command aliases
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -103,7 +102,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 +112,14 @@ 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."
+(defcustom eshell-alias-load-hook nil
+ "A hook that gets run when `eshell-alias' is loaded."
+ :version "24.1" ; removed eshell-alias-initialize
:type 'hook
:group 'eshell-alias)
@@ -157,7 +157,7 @@ command, which will automatically write them to the file named by
(defun eshell/alias (&optional alias &rest definition)
"Define an ALIAS in the user's alias list using DEFINITION."
(if (not alias)
- (eshell-for alias eshell-command-aliases-list
+ (dolist (alias eshell-command-aliases-list)
(eshell-print (apply 'format "alias %s %s\n" alias)))
(if (not definition)
(setq eshell-command-aliases-list
@@ -239,7 +239,7 @@ command, which will automatically write them to the file named by
"Find all possible completions for NAME.
These are all the command aliases which begin with NAME."
(let (completions)
- (eshell-for alias eshell-command-aliases-list
+ (dolist (alias eshell-command-aliases-list)
(if (string-match (concat "^" name) (car alias))
(setq completions (cons (car alias) completions))))
completions))
@@ -279,5 +279,4 @@ These are all the command aliases which begin with NAME."
;; generated-autoload-file: "esh-groups.el"
;; End:
-;; arch-tag: 8b018fc1-4e07-4ccc-aa73-c0a1ba361f82
;;; em-alias.el ends here
diff --git a/lisp/eshell/em-banner.el b/lisp/eshell/em-banner.el
index c2a5a332efd..ce987f132e3 100644
--- a/lisp/eshell/em-banner.el
+++ b/lisp/eshell/em-banner.el
@@ -1,7 +1,6 @@
;;; em-banner.el --- sample module that displays a login banner
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -58,15 +57,16 @@ 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)
(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."
+(defcustom eshell-banner-load-hook nil
+ "A list of functions to run when `eshell-banner' is loaded."
+ :version "24.1" ; removed eshell-banner-initialize
:type 'hook
:group 'eshell-banner)
@@ -82,19 +82,10 @@ This can be any sexp, and should end with at least two newlines."
(assert msg)
(eshell-interactive-print msg))))
-(eshell-deftest banner banner-displayed
- "Startup banner is displayed at point-min"
- (assert eshell-banner-message)
- (let ((msg (eval eshell-banner-message)))
- (assert msg)
- (goto-char (point-min))
- (looking-at msg)))
-
(provide 'em-banner)
;; Local Variables:
;; generated-autoload-file: "esh-groups.el"
;; End:
-;; arch-tag: e738b4ef-8671-42ae-a757-291779b92491
;;; em-banner.el ends here
diff --git a/lisp/eshell/em-basic.el b/lisp/eshell/em-basic.el
index 7805b25642e..df1987e13ee 100644
--- a/lisp/eshell/em-basic.el
+++ b/lisp/eshell/em-basic.el
@@ -1,7 +1,6 @@
;;; em-basic.el --- basic shell builtin commands
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -77,7 +76,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
@@ -184,5 +183,4 @@ or `eshell-printn' for display."
;; generated-autoload-file: "esh-groups.el"
;; End:
-;; arch-tag: 385a31b1-cb95-46f0-9829-9d352ee77db8
;;; em-basic.el ends here
diff --git a/lisp/eshell/em-cmpl.el b/lisp/eshell/em-cmpl.el
index d4bfa3cb05b..c551684210c 100644
--- a/lisp/eshell/em-cmpl.el
+++ b/lisp/eshell/em-cmpl.el
@@ -1,7 +1,6 @@
;;; em-cmpl.el --- completion using the TAB key
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -85,27 +84,28 @@ 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."
+(defcustom eshell-cmpl-load-hook nil
+ "A list of functions to run when `eshell-cmpl' is loaded."
+ :version "24.1" ; removed eshell-cmpl-initialize
: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))
@@ -455,5 +455,4 @@ to writing a completion function."
;; generated-autoload-file: "esh-groups.el"
;; End:
-;; arch-tag: 0e914699-673a-45f8-8cbf-82e1dbc571bc
;;; em-cmpl.el ends here
diff --git a/lisp/eshell/em-dirs.el b/lisp/eshell/em-dirs.el
index f3c019f8cc8..1aa2c34c395 100644
--- a/lisp/eshell/em-dirs.el
+++ b/lisp/eshell/em-dirs.el
@@ -1,7 +1,6 @@
;;; em-dirs.el --- directory navigation commands
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -59,15 +58,16 @@ 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."
+(defcustom eshell-dirs-load-hook nil
+ "A hook that gets run when `eshell-dirs' is loaded."
+ :version "24.1" ; removed eshell-dirs-initialize
: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)
@@ -234,7 +234,7 @@ Thus, this does not include the current directory.")
(defun eshell-save-some-last-dir ()
"Save the list-dir-ring for any open Eshell buffers."
- (eshell-for buf (buffer-list)
+ (dolist (buf (buffer-list))
(if (buffer-live-p buf)
(with-current-buffer buf
(if (and eshell-mode
@@ -573,5 +573,4 @@ in the minibuffer:
;; generated-autoload-file: "esh-groups.el"
;; End:
-;; arch-tag: 1e9c5a95-f1bd-45f8-ad36-55aac706e787
;;; em-dirs.el ends here
diff --git a/lisp/eshell/em-glob.el b/lisp/eshell/em-glob.el
index 7fbdf3d36cd..732c6c05bfe 100644
--- a/lisp/eshell/em-glob.el
+++ b/lisp/eshell/em-glob.el
@@ -1,7 +1,6 @@
;;; em-glob.el --- extended file name globbing
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -62,40 +61,41 @@ 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."
+(defcustom eshell-glob-load-hook nil
+ "A list of functions to run when `eshell-glob' is loaded."
+ :version "24.1" ; removed eshell-glob-initialize
: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 f898b79a00b..993e9d63a94 100644
--- a/lisp/eshell/em-hist.el
+++ b/lisp/eshell/em-hist.el
@@ -1,7 +1,6 @@
;;; em-hist.el --- history list management
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -71,8 +70,9 @@
;;; User Variables:
-(defcustom eshell-hist-load-hook '(eshell-hist-initialize)
- "*A list of functions to call when loading `eshell-hist'."
+(defcustom eshell-hist-load-hook nil
+ "A list of functions to call when loading `eshell-hist'."
+ :version "24.1" ; removed eshell-hist-initialize
: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")))
@@ -293,7 +293,7 @@ element, regardless of any text on the command line. In that case,
(defun eshell-save-some-history ()
"Save the history for any open Eshell buffers."
- (eshell-for buf (buffer-list)
+ (dolist (buf (buffer-list))
(if (buffer-live-p buf)
(with-current-buffer buf
(if (and eshell-mode
@@ -731,7 +731,7 @@ matched."
(narrow-to-region here (point))
(goto-char (point-min))
(let ((modifiers (cdr (eshell-parse-modifiers))))
- (eshell-for mod modifiers
+ (dolist (mod modifiers)
(setq hist (funcall mod hist)))
hist))
(delete-region here (point)))))
@@ -998,5 +998,4 @@ If N is negative, search backwards for the -Nth previous match."
;; generated-autoload-file: "esh-groups.el"
;; End:
-;; arch-tag: 1a847333-f864-4b96-9acd-b549d620b6c6
;;; em-hist.el ends here
diff --git a/lisp/eshell/em-ls.el b/lisp/eshell/em-ls.el
index cc5141040a2..4ef259dee4b 100644
--- a/lisp/eshell/em-ls.el
+++ b/lisp/eshell/em-ls.el
@@ -1,7 +1,6 @@
;;; em-ls.el --- implementation of ls in Lisp
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -54,24 +53,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 +85,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 +110,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 +118,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 +133,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 +148,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 +200,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 +215,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 +249,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)
@@ -561,7 +561,7 @@ relative to that directory."
(when (or (eq listing-style 'long-listing) show-size)
(let ((total 0.0))
(setq size-width 0)
- (eshell-for e entries
+ (dolist (e entries)
(if (nth 7 (cdr e))
(setq total (+ total (nth 7 (cdr e)))
size-width
@@ -611,11 +611,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)
@@ -651,7 +651,7 @@ Each member of FILES is either a string or a cons cell of the form
(not (eq eshell-in-pipeline-p 'last))
(not (eq listing-style 'by-lines)))
(memq listing-style '(long-listing single-column)))
- (eshell-for file files
+ (dolist (file files)
(if file
(eshell-ls-file file size-width copy-fileinfo)))
(let ((f files)
@@ -676,7 +676,7 @@ Each member of FILES is either a string or a cons cell of the form
(setcdr f (cddr f))))))
(if (not show-size)
(setq display-files (mapcar 'eshell-ls-annotate files))
- (eshell-for file files
+ (dolist (file files)
(let* ((str (eshell-ls-printable-size (nth 7 (cdr file)) t))
(len (length str)))
(if (< len size-width)
@@ -696,7 +696,7 @@ Each member of FILES is either a string or a cons cell of the form
(columns (length col-widths))
(col-index 1)
need-return)
- (eshell-for file display-files
+ (dolist (file display-files)
(let ((name
(if (car file)
(if show-size
@@ -731,7 +731,7 @@ ROOT-DIR, if non-nil, specifies the root directory of the listing, to
which non-absolute directory names will be made relative if ever they
need to be printed."
(let (dirs files show-names need-return (size-width 0))
- (eshell-for entry entries
+ (dolist (entry entries)
(if (and (not dir-literal)
(or (eshell-ls-filetype-p (cdr entry) ?d)
(and (eshell-ls-filetype-p (cdr entry) ?l)
@@ -757,7 +757,7 @@ need to be printed."
(setq need-return t))
(setq show-names (or show-recursive
(> (+ (length files) (length dirs)) 1)))
- (eshell-for dir (eshell-ls-sort-entries dirs)
+ (dolist (dir (eshell-ls-sort-entries dirs))
(if (and need-return (not dir-literal))
(funcall insert-func "\n"))
(eshell-ls-dir dir show-names
@@ -940,5 +940,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 8fbedda3e7e..f3027ea9b5e 100644
--- a/lisp/eshell/em-pred.el
+++ b/lisp/eshell/em-pred.el
@@ -1,7 +1,6 @@
;;; em-pred.el --- argument predicates and modifiers (ala zsh)
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -60,8 +59,9 @@ ordinary strings."
;;; User Variables:
-(defcustom eshell-pred-load-hook '(eshell-pred-initialize)
- "*A list of functions to run when `eshell-pred' is loaded."
+(defcustom eshell-pred-load-hook nil
+ "A list of functions to run when `eshell-pred' is loaded."
+ :version "24.1" ; removed eshell-pred-initialize
: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 02e3d44dc39..3e87acc6d1e 100644
--- a/lisp/eshell/em-prompt.el
+++ b/lisp/eshell/em-prompt.el
@@ -1,7 +1,6 @@
;;; em-prompt.el --- command prompts
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -38,8 +37,9 @@ 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'."
+(defcustom eshell-prompt-load-hook nil
+ "A list of functions to call when loading `eshell-prompt'."
+ :version "24.1" ; removed eshell-prompt-initialize
: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
@@ -177,5 +177,4 @@ If this takes us past the end of the current line, don't skip at all."
;; generated-autoload-file: "esh-groups.el"
;; End:
-;; arch-tag: 01c1574b-ce70-4e89-bc38-e6619f61e208
;;; em-prompt.el ends here
diff --git a/lisp/eshell/em-rebind.el b/lisp/eshell/em-rebind.el
index 5af15832355..2c346dfcd3d 100644
--- a/lisp/eshell/em-rebind.el
+++ b/lisp/eshell/em-rebind.el
@@ -1,7 +1,6 @@
;;; em-rebind.el --- rebind keys when point is at current input
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -42,8 +41,9 @@ 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'."
+(defcustom eshell-rebind-load-hook nil
+ "A list of functions to call when loading `eshell-rebind'."
+ :version "24.1" ; removed eshell-rebind-initialize
: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)
@@ -91,7 +91,6 @@ This is default behavior of shells like bash."
'(beginning-of-line-text
beginning-of-line
move-to-column
- move-to-column-force
move-to-left-margin
move-to-tab-stop
forward-char
@@ -132,7 +131,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)
@@ -247,5 +246,4 @@ input."
;; generated-autoload-file: "esh-groups.el"
;; End:
-;; arch-tag: 76d84f12-cc56-4d67-9b7d-c6b44ad20530
;;; em-rebind.el ends here
diff --git a/lisp/eshell/em-script.el b/lisp/eshell/em-script.el
index a25472d927e..d76e19cdd07 100644
--- a/lisp/eshell/em-script.el
+++ b/lisp/eshell/em-script.el
@@ -1,7 +1,6 @@
;;; em-script.el --- Eshell script files
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -35,20 +34,21 @@ 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'."
+(defcustom eshell-script-load-hook nil
+ "A list of functions to call when loading `eshell-script'."
+ :version "24.1" ; removed eshell-script-initialize
: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."
@@ -140,5 +142,4 @@ environment, binding ARGS to $1, $2, etc.")
;; generated-autoload-file: "esh-groups.el"
;; End:
-;; arch-tag: a346439d-5ba8-4faf-ac2b-3aacfeaa4647
;;; em-script.el ends here
diff --git a/lisp/eshell/em-smart.el b/lisp/eshell/em-smart.el
index f9880761076..f08fec8f8fa 100644
--- a/lisp/eshell/em-smart.el
+++ b/lisp/eshell/em-smart.el
@@ -1,7 +1,6 @@
;;; em-smart.el --- smart display of output
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -85,8 +84,9 @@ 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'."
+(defcustom eshell-smart-load-hook nil
+ "A list of functions to call when loading `eshell-smart'."
+ :version "24.1" ; removed eshell-smart-initialize
: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)
@@ -327,5 +327,4 @@ and the end of the buffer are still visible."
;; generated-autoload-file: "esh-groups.el"
;; End:
-;; arch-tag: 8c0112c7-379c-4d54-9a1c-204d68786a4b
;;; em-smart.el ends here
diff --git a/lisp/eshell/em-term.el b/lisp/eshell/em-term.el
index 3a79b4a3c4d..7d5fbbeabeb 100644
--- a/lisp/eshell/em-term.el
+++ b/lisp/eshell/em-term.el
@@ -1,7 +1,6 @@
;;; em-term.el --- running visual commands
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -47,8 +46,9 @@ 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'."
+(defcustom eshell-term-load-hook nil
+ "A list of functions to call when loading `eshell-term'."
+ :version "24.1" ; removed eshell-term-initialize
: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)
@@ -268,5 +267,4 @@ allowed."
;; generated-autoload-file: "esh-groups.el"
;; End:
-;; arch-tag: ab7c8fe4-3101-4257-925b-1354c6b2fe9d
;;; em-term.el ends here
diff --git a/lisp/eshell/em-unix.el b/lisp/eshell/em-unix.el
index 8f612705e9b..707f2ebc2ce 100644
--- a/lisp/eshell/em-unix.el
+++ b/lisp/eshell/em-unix.el
@@ -1,7 +1,6 @@
;;; em-unix.el --- UNIX command aliases
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -54,85 +53,86 @@ by name)."
:tag "UNIX commands in Lisp"
:group 'eshell-module)
-(defcustom eshell-unix-load-hook '(eshell-unix-initialize)
- "*A list of functions to run when `eshell-unix' is loaded."
+(defcustom eshell-unix-load-hook nil
+ "A list of functions to run when `eshell-unix' is loaded."
+ :version "24.1" ; removed eshell-unix-initialize
: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
@@ -596,7 +588,7 @@ symlink, then revert to the system's definition of cat."
(setq args (eshell-stringify-list (eshell-flatten-list args)))
(if (or eshell-in-pipeline-p
(catch 'special
- (eshell-for arg args
+ (dolist (arg args)
(unless (or (and (stringp arg)
(> (length arg) 0)
(eq (aref arg 0) ?-))
@@ -619,12 +611,12 @@ symlink, then revert to the system's definition of cat."
:show-usage
:usage "[OPTION] FILE...
Concatenate FILE(s), or standard input, to standard output.")
- (eshell-for file args
+ (dolist (file args)
(if (string= file "-")
(throw 'eshell-external
(eshell-external-command "cat" args))))
(let ((curbuf (current-buffer)))
- (eshell-for file args
+ (dolist (file args)
(with-temp-buffer
(insert-file-contents file)
(goto-char (point-min))
@@ -860,7 +852,7 @@ external command."
(let ((ext-du (eshell-search-path "du")))
(if (and ext-du
(not (catch 'have-ange-path
- (eshell-for arg args
+ (dolist (arg args)
(if (string-equal
(file-remote-p (expand-file-name arg) 'method) "ftp")
(throw 'have-ange-path t))))))
@@ -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
@@ -1066,7 +1056,7 @@ Become another USER during a login session.")
"localhost"))
(dir (or (file-remote-p default-directory 'localname)
(expand-file-name default-directory))))
- (eshell-for arg args
+ (dolist (arg args)
(if (string-equal arg "-") (setq login t) (setq user arg)))
;; `eshell-eval-using-options' does not handle "-".
(if (member "-" orig-args) (setq login t))
@@ -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/em-xtra.el b/lisp/eshell/em-xtra.el
index e36d3b9aa55..50bda108e95 100644
--- a/lisp/eshell/em-xtra.el
+++ b/lisp/eshell/em-xtra.el
@@ -1,7 +1,6 @@
;;; em-xtra.el --- extra alias functions
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -123,5 +122,4 @@ naturally accessible within Emacs."
;; generated-autoload-file: "esh-groups.el"
;; End:
-;; arch-tag: f944cfda-a118-470c-a0d6-b41a3a5c99c7
;;; em-xtra.el ends here
diff --git a/lisp/eshell/esh-arg.el b/lisp/eshell/esh-arg.el
index 75a8513fb26..1fb8b7f4c32 100644
--- a/lisp/eshell/esh-arg.el
+++ b/lisp/eshell/esh-arg.el
@@ -1,7 +1,6 @@
;;; esh-arg.el --- argument processing
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -118,12 +117,13 @@ treated as a literal character."
;;; User Variables:
-(defcustom eshell-arg-load-hook '(eshell-arg-initialize)
+(defcustom eshell-arg-load-hook nil
"A hook that gets run when `eshell-arg' is loaded."
+ :version "24.1" ; removed eshell-arg-initialize
: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."
@@ -392,5 +391,4 @@ special character that is not itself a backslash."
(char-to-string (char-after)))))
(goto-char end)))))))
-;; arch-tag: 7f593a2b-8fc1-4def-8f84-8f51ed0198d6
;;; esh-arg.el ends here
diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el
index 70a9135d239..bdcdc453272 100644
--- a/lisp/eshell/esh-cmd.el
+++ b/lisp/eshell/esh-cmd.el
@@ -1,7 +1,6 @@
;;; esh-cmd.el --- command invocation
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -122,28 +121,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 +153,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 +179,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 +192,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 +206,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
@@ -230,13 +229,14 @@ 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."
+(defcustom eshell-cmd-load-hook nil
+ "A hook that gets run when `eshell-cmd' is loaded."
+ :version "24.1" ; removed eshell-cmd-initialize
: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)
@@ -320,18 +320,6 @@ otherwise t.")
(add-hook 'pcomplete-try-first-hook
'eshell-complete-lisp-symbols nil t)))
-(eshell-deftest var last-result-var
- "\"last result\" variable"
- (eshell-command-result-p "+ 1 2; + $$ 2" "3\n5\n"))
-
-(eshell-deftest var last-result-var2
- "\"last result\" variable"
- (eshell-command-result-p "+ 1 2; + $$ $$" "3\n6\n"))
-
-(eshell-deftest var last-arg-var
- "\"last arg\" variable"
- (eshell-command-result-p "+ 1 2; + $_ 4" "3\n6\n"))
-
(defun eshell-complete-lisp-symbols ()
"If there is a user reference, complete it."
(let ((arg (pcomplete-actual-arg)))
@@ -355,12 +343,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
@@ -439,32 +429,12 @@ hooks should be run before and after the command."
(eq (caar terms) 'eshell-command-to-value))
(car (cdar terms))))
-(eshell-deftest cmd lisp-command
- "Evaluate Lisp command"
- (eshell-command-result-p "(+ 1 2)" "3"))
-
-(eshell-deftest cmd lisp-command-args
- "Evaluate Lisp command (ignore args)"
- (eshell-command-result-p "(+ 1 2) 3" "3"))
-
(defun eshell-rewrite-initial-subcommand (terms)
"Rewrite a subcommand in initial position, such as '{+ 1 2}'."
(if (and (listp (car terms))
(eq (caar terms) 'eshell-as-subcommand))
(car terms)))
-(eshell-deftest cmd subcommand
- "Run subcommand"
- (eshell-command-result-p "{+ 1 2}" "3\n"))
-
-(eshell-deftest cmd subcommand-args
- "Run subcommand (ignore args)"
- (eshell-command-result-p "{+ 1 2} 3" "3\n"))
-
-(eshell-deftest cmd subcommand-lisp
- "Run subcommand + Lisp form"
- (eshell-command-result-p "{(+ 1 2)}" "3\n"))
-
(defun eshell-rewrite-named-command (terms)
"If no other rewriting rule transforms TERMS, assume a named command."
(let ((sym (if eshell-in-pipeline-p
@@ -476,10 +446,6 @@ hooks should be run before and after the command."
(list sym cmd (append (list 'list) (cdr terms)))
(list sym cmd))))
-(eshell-deftest cmd named-command
- "Execute named command"
- (eshell-command-result-p "+ 1 2" "3\n"))
-
(defvar eshell-command-body)
(defvar eshell-test-body)
@@ -986,7 +952,7 @@ at the moment are:
(not (member name eshell-complex-commands))
(catch 'simple
(progn
- (eshell-for pred eshell-complex-commands
+ (dolist (pred eshell-complex-commands)
(if (and (functionp pred)
(funcall pred name))
(throw 'simple nil)))
@@ -1164,7 +1130,7 @@ be finished later after the completion of an asynchronous subprocess."
(if (and (eq (car form) 'let)
(not (eq (car (cadr args)) 'eshell-do-eval)))
(eshell-manipulate "evaluating let args"
- (eshell-for letarg (car args)
+ (dolist (letarg (car args))
(if (and (listp letarg)
(not (eq (cadr letarg) 'quote)))
(setcdr letarg
@@ -1240,7 +1206,7 @@ be finished later after the completion of an asynchronous subprocess."
(defun eshell/which (command &rest names)
"Identify the COMMAND, and where it is located."
- (eshell-for name (cons command names)
+ (dolist (name (cons command names))
(let (program alias direct)
(if (eq (aref name 0) eshell-explicit-command-char)
(setq name (substring name 1)
@@ -1432,5 +1398,4 @@ messages, and errors."
(provide 'esh-cmd)
-;; arch-tag: 8e4f3867-a0c5-441f-96ba-ddd142d94366
;;; esh-cmd.el ends here
diff --git a/lisp/eshell/esh-ext.el b/lisp/eshell/esh-ext.el
index 54c21f230d9..3acbeac0b89 100644
--- a/lisp/eshell/esh-ext.el
+++ b/lisp/eshell/esh-ext.el
@@ -1,7 +1,6 @@
;;; esh-ext.el --- commands external to Eshell
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -47,18 +46,19 @@ 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."
+(defcustom eshell-ext-load-hook nil
+ "A hook that gets run when `eshell-ext' is loaded."
+ :version "24.1" ; removed eshell-ext-initialize
: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
@@ -203,7 +203,7 @@ causing the user to wonder if anything's really going on..."
(defun eshell-external-command (command args)
"Insert output from an external COMMAND, using ARGS."
(setq args (eshell-stringify-list (eshell-flatten-list args)))
- (if (string-equal (file-remote-p default-directory 'method) "ftp")
+ (if (file-remote-p default-directory)
(eshell-remote-command command args))
(let ((interp (eshell-find-interpreter command)))
(assert interp)
@@ -264,7 +264,7 @@ line of the form #!<interp>."
(let ((finterp
(catch 'found
(ignore
- (eshell-for possible eshell-interpreter-alist
+ (dolist (possible eshell-interpreter-alist)
(cond
((functionp (car possible))
(and (funcall (car possible) file)
@@ -306,5 +306,4 @@ line of the form #!<interp>."
(cdr interp)))))
(or interp (list fullname)))))))
-;; arch-tag: 178d4064-7e60-4745-b81f-bab5d8d7c40f
;;; esh-ext.el ends here
diff --git a/lisp/eshell/esh-io.el b/lisp/eshell/esh-io.el
index f9bd93e9cbf..71fae34b360 100644
--- a/lisp/eshell/esh-io.el
+++ b/lisp/eshell/esh-io.el
@@ -1,7 +1,6 @@
;;; esh-io.el --- I/O management
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -72,13 +71,14 @@ though they were files."
;;; User Variables:
-(defcustom eshell-io-load-hook '(eshell-io-initialize)
- "*A hook that gets run when `eshell-io' is loaded."
+(defcustom eshell-io-load-hook nil
+ "A hook that gets run when `eshell-io' is loaded."
+ :version "24.1" ; removed eshell-io-initialize
: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.
@@ -516,5 +516,4 @@ Returns what was actually sent, or nil if nothing was sent."
(eshell-output-object-to-target object (car target))
(setq target (cdr target))))))
-;; arch-tag: 9ca2080f-d5e0-4b26-aa0b-d59194a905a2
;;; esh-io.el ends here
diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el
index ce5cacefe1b..9abb0c8ecc0 100644
--- a/lisp/eshell/esh-mode.el
+++ b/lisp/eshell/esh-mode.el
@@ -1,7 +1,6 @@
;;; esh-mode.el --- user interface
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -75,54 +74,55 @@
;;; 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.
+(defcustom eshell-exit-hook nil
+ "A hook that is run whenever `eshell' is exited.
This hook is only run if exiting actually kills the buffer."
+ :version "24.1" ; removed eshell-query-kill-processes
: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)
@@ -288,6 +288,17 @@ This is used by `eshell-watch-for-password-prompt'."
;;; User Functions:
+(defun eshell-kill-buffer-function ()
+ "Function added to `kill-buffer-hook' in Eshell buffers.
+This runs the function `eshell-kill-processes-on-exit',
+and the hook `eshell-exit-hook'."
+ ;; It's fine to run this unconditionally since it can be customized
+ ;; via the `eshell-kill-processes-on-exit' variable.
+ (and (fboundp 'eshell-query-kill-processes)
+ (not (memq 'eshell-query-kill-processes eshell-exit-hook))
+ (eshell-query-kill-processes))
+ (run-hooks 'eshell-exit-hook))
+
;;;###autoload
(defun eshell-mode ()
"Emacs shell interactive mode.
@@ -390,7 +401,7 @@ This is used by `eshell-watch-for-password-prompt'."
;; load extension modules into memory. This will cause any global
;; variables they define to be visible, since some of the core
;; modules sometimes take advantage of their functionality if used.
- (eshell-for module eshell-modules-list
+ (dolist (module eshell-modules-list)
(let ((module-fullname (symbol-name module))
module-shortname)
(if (string-match "^eshell-\\(.*\\)" module-fullname)
@@ -404,17 +415,15 @@ This is used by `eshell-watch-for-password-prompt'."
(unless (file-exists-p eshell-directory-name)
(eshell-make-private-directory eshell-directory-name t))
- ;; load core Eshell modules for this session
- (eshell-for module (eshell-subgroups 'eshell)
- (run-hooks (intern-soft (concat (symbol-name module)
- "-load-hook"))))
-
- ;; load extension modules for this session
- (eshell-for module eshell-modules-list
- (let ((load-hook (intern-soft (concat (symbol-name module)
- "-load-hook"))))
- (if (and load-hook (boundp load-hook))
- (run-hooks load-hook))))
+ ;; Load core Eshell modules, then extension modules, for this session.
+ (dolist (module (append (eshell-subgroups 'eshell) eshell-modules-list))
+ (let ((load-hook (intern-soft (format "%s-load-hook" module)))
+ (initfunc (intern-soft (format "%s-initialize" module))))
+ (when (and load-hook (boundp load-hook))
+ (if (memq initfunc (symbol-value load-hook)) (setq initfunc nil))
+ (run-hooks load-hook))
+ ;; So we don't need the -initialize functions on the hooks (b#5375).
+ (and initfunc (fboundp initfunc) (funcall initfunc))))
(if eshell-send-direct-to-subprocesses
(add-hook 'pre-command-hook 'eshell-intercept-commands t t))
@@ -429,10 +438,7 @@ This is used by `eshell-watch-for-password-prompt'."
(add-hook 'eshell-pre-command-hook 'eshell-command-started nil t)
(add-hook 'eshell-post-command-hook 'eshell-command-finished nil t))
- (add-hook 'kill-buffer-hook
- (function
- (lambda ()
- (run-hooks 'eshell-exit-hook))) t t)
+ (add-hook 'kill-buffer-hook 'eshell-kill-buffer-function t t)
(if eshell-first-time-p
(run-hooks 'eshell-first-time-mode-hook))
@@ -441,19 +447,6 @@ This is used by `eshell-watch-for-password-prompt'."
(put 'eshell-mode 'mode-class 'special)
-(eshell-deftest mode major-mode
- "Major mode is correct"
- (eq major-mode 'eshell-mode))
-
-(eshell-deftest mode eshell-mode-variable
- "`eshell-mode' is true"
- (eq eshell-mode t))
-
-(eshell-deftest var window-height
- "LINES equals window height"
- (let ((eshell-stringify-t t))
- (eshell-command-result-p "= $LINES (window-height)" "t\n")))
-
(defun eshell-command-started ()
"Indicate in the modeline that a command has started."
(setq eshell-command-running-string "**")
@@ -464,13 +457,6 @@ This is used by `eshell-watch-for-password-prompt'."
(setq eshell-command-running-string "--")
(force-mode-line-update))
-(eshell-deftest mode command-running-p
- "Modeline shows no command running"
- (or (featurep 'xemacs)
- (not eshell-status-in-modeline)
- (and (memq 'eshell-command-running-string mode-line-format)
- (equal eshell-command-running-string "--"))))
-
;;; Internal Functions:
(defun eshell-toggle-direct-send ()
@@ -511,6 +497,8 @@ This is used by `eshell-watch-for-password-prompt'."
(if intercept
(setq this-command 'eshell-self-insert-command)))))
+(declare-function find-tag-interactive "etags" (prompt &optional no-default))
+
(defun eshell-find-tag (&optional tagname next-p regexp-p)
"A special version of `find-tag' that ignores read-onlyness."
(interactive)
@@ -518,8 +506,7 @@ This is used by `eshell-watch-for-password-prompt'."
(let ((inhibit-read-only t)
(no-default (eobp))
(find-tag-default-function 'ignore))
- (with-no-warnings
- (setq tagname (car (find-tag-interactive "Find tag: "))))
+ (setq tagname (car (find-tag-interactive "Find tag: " no-default)))
(find-tag tagname next-p regexp-p)))
(defun eshell-move-argument (limit func property arg)
@@ -540,20 +527,6 @@ This is used by `eshell-watch-for-password-prompt'."
(= (1+ pos) limit))
(forward-char 1))))
-(eshell-deftest arg forward-arg
- "Move across command arguments"
- (eshell-insert-command "echo $(+ 1 (- 4 3)) \"alpha beta\" file" 'ignore)
- (let ((here (point)) begin valid)
- (eshell-bol)
- (setq begin (point))
- (eshell-forward-argument 4)
- (setq valid (= here (point)))
- (eshell-backward-argument 4)
- (prog1
- (and valid (= begin (point)))
- (eshell-bol)
- (delete-region (point) (point-max)))))
-
(defun eshell-forward-argument (&optional arg)
"Move forward ARG arguments."
(interactive "p")
@@ -653,17 +626,6 @@ waiting for input."
(interactive "P")
(eshell-send-input use-region t))
-(eshell-deftest mode queue-input
- "Queue command input"
- (eshell-insert-command "sleep 2")
- (eshell-insert-command "echo alpha" 'eshell-queue-input)
- (let ((count 10))
- (while (and eshell-current-command
- (> count 0))
- (sit-for 1 0)
- (setq count (1- count))))
- (eshell-match-result "alpha\n"))
-
(defun eshell-send-input (&optional use-region queue-p no-newline)
"Send the input received to Eshell for parsing and processing.
After `eshell-last-output-end', sends all text from that marker to
@@ -742,20 +704,6 @@ newline."
(run-hooks 'eshell-post-command-hook)
(insert-and-inherit input)))))))))
-; (eshell-deftest proc send-to-subprocess
-; "Send input to a subprocess"
-; ;; jww (1999-12-06): what about when bc is unavailable?
-; (if (not (eshell-search-path "bc"))
-; t
-; (eshell-insert-command "bc")
-; (eshell-insert-command "1 + 2")
-; (sit-for 1 0)
-; (forward-line -1)
-; (prog1
-; (looking-at "3\n")
-; (eshell-insert-command "quit")
-; (sit-for 1 0))))
-
(defsubst eshell-kill-new ()
"Add the last input text to the kill ring."
(kill-ring-save eshell-last-input-start eshell-last-input-end))
@@ -901,14 +849,6 @@ Does not delete the prompt."
(insert "*** output flushed ***\n")
(delete-region (point) (eshell-end-of-output))))
-(eshell-deftest io flush-output
- "Flush previous output"
- (eshell-insert-command "echo alpha")
- (eshell-kill-output)
- (and (eshell-match-result (regexp-quote "*** output flushed ***\n"))
- (forward-line)
- (= (point) eshell-last-output-start)))
-
(defun eshell-show-output (&optional arg)
"Display start of this batch of interpreter output at top of window.
Sets mark to the value of point when this command is run.
@@ -969,12 +909,6 @@ When run interactively, widen the buffer first."
(goto-char eshell-last-output-end)
(insert-and-inherit input)))
-(eshell-deftest mode run-old-command
- "Re-run an old command"
- (eshell-insert-command "echo alpha")
- (goto-char eshell-last-input-start)
- (string= (eshell-get-old-input) "echo alpha"))
-
(defun eshell/exit ()
"Leave or kill the Eshell buffer, depending on `eshell-kill-on-exit'."
(throw 'eshell-terminal t))
@@ -1083,5 +1017,4 @@ This function could be in the list `eshell-output-filter-functions'."
(custom-add-option 'eshell-output-filter-functions
'eshell-handle-ansi-color)
-;; arch-tag: ec65bc2b-da14-4547-81d3-a32af3a4dc57
;;; esh-mode.el ends here
diff --git a/lisp/eshell/esh-module.el b/lisp/eshell/esh-module.el
index d56e17211d9..1581d05889e 100644
--- a/lisp/eshell/esh-module.el
+++ b/lisp/eshell/esh-module.el
@@ -1,7 +1,6 @@
;;; esh-module.el --- Eshell modules
-;; Copyright (C) 1999, 2000, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2000, 2002-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
;; Keywords: processes
@@ -44,7 +43,7 @@ customizing the variable `eshell-modules-list'."
(defcustom eshell-module-unload-hook
'(eshell-unload-extension-modules)
- "*A hook run when `eshell-module' is unloaded."
+ "A hook run when `eshell-module' is unloaded."
:type 'hook
:group 'eshell-module)
@@ -62,7 +61,7 @@ customizing the variable `eshell-modules-list'."
eshell-script
eshell-term
eshell-unix)
- "*A list of optional add-on modules to be loaded by Eshell.
+ "A list of optional add-on modules to be loaded by Eshell.
Changes will only take effect in future Eshell buffers."
:type (append
(list 'set ':tag "Supported modules")
@@ -93,12 +92,11 @@ customization group. Example: `eshell-cmpl' for that module."
(defun eshell-unload-extension-modules ()
"Unload any memory resident extension modules."
- (eshell-for module (eshell-subgroups 'eshell-module)
+ (dolist (module (eshell-subgroups 'eshell-module))
(if (featurep module)
(ignore-errors
(message "Unloading %s..." (symbol-name module))
(unload-feature module)
(message "Unloading %s...done" (symbol-name module))))))
-;; arch-tag: 97a3fa16-9d08-40e6-bc2c-36bd70986507
;;; esh-module.el ends here
diff --git a/lisp/eshell/esh-opt.el b/lisp/eshell/esh-opt.el
index 5b0c02b0cb2..91d3cac198a 100644
--- a/lisp/eshell/esh-opt.el
+++ b/lisp/eshell/esh-opt.el
@@ -1,7 +1,6 @@
;;; esh-opt.el --- command options processing
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -36,13 +35,51 @@ Eshell commands implemented in Lisp."
;;; User Functions:
-(defmacro eshell-eval-using-options (name macro-args
- options &rest body-forms)
+(defmacro eshell-eval-using-options (name macro-args options &rest body-forms)
"Process NAME's MACRO-ARGS using a set of command line OPTIONS.
-After doing so, settings will be stored in local symbols as declared
-by OPTIONS; FORMS will then be evaluated -- assuming all was OK.
+After doing so, stores settings in local symbols as declared by OPTIONS;
+then evaluates BODY-FORMS -- assuming all was OK.
-The syntax of OPTIONS is:
+OPTIONS is a list, beginning with one or more elements of the form:
+\(SHORT LONG VALUE SYMBOL HELP-STRING)
+Each of these elements represents a particular command-line switch.
+
+SHORT is either nil, or a character that can be used as a switch -SHORT.
+LONG is either nil, or a string that can be used as a switch --LONG.
+At least one of SHORT and LONG must be non-nil.
+VALUE is the value associated with the option. It can be either:
+ t - the option needs a value to be specified after the switch;
+ nil - the option is given the value t;
+ anything else - specifies the actual value for the option.
+SYMBOL is either nil, or the name of the Lisp symbol that will be bound
+to VALUE. A nil SYMBOL calls `eshell-show-usage', and so is appropriate
+for a \"--help\" type option.
+HELP-STRING is a documentation string for the option.
+
+Any remaining elements of OPTIONS are :KEYWORD arguments. Some take
+arguments, some do not. The recognized :KEYWORDS are:
+
+:external STRING
+ STRING is an external command to run if there are unknown switches.
+
+:usage STRING
+ STRING is the initial part of the command's documentation string.
+ It appears before the options are listed.
+
+:post-usage STRING
+ STRING is an optional trailing part of the command's documentation string.
+ It appears after the options, but before the final part of the
+ documentation about the associated external command (if there is one).
+
+:show-usage
+ If present, then show the usage message if the command is called with no
+ arguments.
+
+:preserve-args
+ If present, do not pass MACRO-ARGS through `eshell-flatten-list'
+and `eshell-stringify-list'.
+
+For example, OPTIONS might look like:
'((?C nil nil multi-column \"multi-column display\")
(nil \"help\" nil nil \"show this usage display\")
@@ -53,8 +90,9 @@ The syntax of OPTIONS is:
Sort entries alphabetically across.\")
`eshell-eval-using-options' returns the value of the last form in
-BODY-FORMS. If instead an external command is run, the tag
-`eshell-external' will be thrown with the new process for its value.
+BODY-FORMS. If instead an external command is run (because of
+an unknown option), the tag `eshell-external' will be thrown with
+the new process for its value.
Lastly, any remaining arguments will be available in a locally
interned variable `args' (created using a `let' form)."
@@ -64,11 +102,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)))
- (cadr options))
+ (let ,(append (delq nil (mapcar (lambda (opt)
+ (and (listp opt) (nth 3 opt)))
+ (cadr options)))
'(usage-msg last-value ext-command args))
(eshell-do-opt ,name ,options (quote ,body-forms)))))
@@ -78,6 +114,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)
@@ -201,7 +238,7 @@ switch is unrecognized."
(defun eshell-process-args (name args options)
"Process the given ARGS using OPTIONS.
-This assumes that symbols have been intern'd by `eshell-with-options'."
+This assumes that symbols have been intern'd by `eshell-eval-using-options'."
(let ((ai 0) arg)
(while (< ai (length args))
(setq arg (nth ai args))
@@ -224,5 +261,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 675f42207cb..eeaccc4b890 100644
--- a/lisp/eshell/esh-proc.el
+++ b/lisp/eshell/esh-proc.el
@@ -1,7 +1,6 @@
;;; esh-proc.el --- process management
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -39,28 +38,29 @@ finish."
;;; User Variables:
-(defcustom eshell-proc-load-hook '(eshell-proc-initialize)
- "*A hook that gets run when `eshell-proc' is loaded."
+(defcustom eshell-proc-load-hook nil
+ "A hook that gets run when `eshell-proc' is loaded."
+ :version "24.1" ; removed eshell-proc-initialize
: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').
@@ -95,13 +95,14 @@ is created."
:type 'hook
:group 'eshell-proc)
-(defcustom eshell-kill-hook '(eshell-reset-after-proc)
- "*Called when a process run by `eshell-gather-process-output' has ended.
+(defcustom eshell-kill-hook nil
+ "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
no relevant process. This can be used for displaying help
information, for example."
+ :version "24.1" ; removed eshell-reset-after-proc
:type 'hook
:group 'eshell-proc)
@@ -114,6 +115,14 @@ information, for example."
;;; Functions:
+(defun eshell-kill-process-function (proc status)
+ "Function run when killing a process.
+Runs `eshell-reset-after-proc' and `eshell-kill-hook', passing arguments
+PROC and STATUS to both."
+ (or (memq 'eshell-reset-after-proc eshell-kill-hook)
+ (eshell-reset-after-proc proc status))
+ (run-hook-with-args 'eshell-kill-hook proc status))
+
(defun eshell-proc-initialize ()
"Initialize the process handling code."
(make-local-variable 'eshell-process-list)
@@ -347,7 +356,7 @@ See `eshell-needs-pipe'."
(eshell-update-markers eshell-last-output-end)
;; Simulate the effect of eshell-sentinel.
(eshell-close-handles (if (numberp exit-status) exit-status -1))
- (run-hook-with-args 'eshell-kill-hook command exit-status)
+ (eshell-kill-process-function command exit-status)
(or eshell-in-pipeline-p
(setq eshell-last-sync-output-start nil))
(if (not (numberp exit-status))
@@ -392,14 +401,14 @@ PROC is the process that's exiting. STRING is the exit message."
(eshell-close-handles (process-exit-status proc) 'nil
(cadr entry))))
(eshell-remove-process-entry entry))))
- (run-hook-with-args 'eshell-kill-hook proc string)))))
+ (eshell-kill-process-function proc string)))))
(defun eshell-process-interact (func &optional all query)
"Interact with a process, using PROMPT if more than one, via FUNC.
If ALL is non-nil, background processes will be interacted with as well.
If QUERY is non-nil, query the user with QUERY before calling FUNC."
(let (defunct result)
- (eshell-for entry eshell-process-list
+ (dolist (entry eshell-process-list)
(if (and (memq (process-status (car entry))
'(run stop open closed))
(or all
@@ -413,17 +422,17 @@ If QUERY is non-nil, query the user with QUERY before calling FUNC."
;; clean up the process list; this can get dirty if an error
;; occurred that brought the user into the debugger, and then they
;; quit, so that the sentinel was never called.
- (eshell-for d defunct
+ (dolist (d defunct)
(eshell-remove-process-entry d))
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 +441,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
@@ -486,31 +495,29 @@ See the variable `eshell-kill-processes-on-exit'."
(kill-buffer buf)))
(message nil))))
-(custom-add-option 'eshell-exit-hook 'eshell-query-kill-processes)
-
(defun eshell-interrupt-process ()
"Interrupt a process."
(interactive)
(unless (eshell-process-interact 'interrupt-process)
- (run-hook-with-args 'eshell-kill-hook nil "interrupt")))
+ (eshell-kill-process-function nil "interrupt")))
(defun eshell-kill-process ()
"Kill a process."
(interactive)
(unless (eshell-process-interact 'kill-process)
- (run-hook-with-args 'eshell-kill-hook nil "killed")))
+ (eshell-kill-process-function nil "killed")))
(defun eshell-quit-process ()
"Send quit signal to process."
(interactive)
(unless (eshell-process-interact 'quit-process)
- (run-hook-with-args 'eshell-kill-hook nil "quit")))
+ (eshell-kill-process-function nil "quit")))
;(defun eshell-stop-process ()
; "Send STOP signal to process."
; (interactive)
; (unless (eshell-process-interact 'stop-process)
-; (run-hook-with-args 'eshell-kill-hook nil "stopped")))
+; (eshell-kill-process-function nil "stopped")))
;(defun eshell-continue-process ()
; "Send CONTINUE signal to process."
@@ -519,7 +526,7 @@ See the variable `eshell-kill-processes-on-exit'."
; ;; jww (1999-09-17): this signal is not dealt with yet. For
; ;; example, `eshell-reset' will be called, and so will
; ;; `eshell-resume-eval'.
-; (run-hook-with-args 'eshell-kill-hook nil "continue")))
+; (eshell-kill-process-function nil "continue")))
(defun eshell-send-eof-to-process ()
"Send EOF to process."
@@ -527,5 +534,4 @@ See the variable `eshell-kill-processes-on-exit'."
(eshell-send-input nil nil t)
(eshell-process-interact 'process-send-eof))
-;; arch-tag: ac477a3e-ee4d-4b44-8ec6-212010e607bb
;;; esh-proc.el ends here
diff --git a/lisp/eshell/esh-test.el b/lisp/eshell/esh-test.el
deleted file mode 100644
index fc52e976a7f..00000000000
--- a/lisp/eshell/esh-test.el
+++ /dev/null
@@ -1,236 +0,0 @@
-;;; esh-test.el --- Eshell test suite
-
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
-
-;; Author: John Wiegley <johnw@gnu.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:
-
-;; The purpose of this module is to verify that Eshell works as
-;; expected. To run it on your system, use the command
-;; \\[eshell-test].
-
-;;; Code:
-
-(eval-when-compile
- (require 'eshell)
- (require 'esh-util))
-(require 'esh-mode)
-
-(defgroup eshell-test nil
- "This module is meant to ensure that Eshell is working correctly."
- :tag "Eshell test suite"
- :group 'eshell)
-
-;;; User Variables:
-
-(defface eshell-test-ok
- '((((class color) (background light)) (:foreground "Green" :bold t))
- (((class color) (background dark)) (:foreground "Green" :bold t)))
- "*The face used to highlight OK result strings."
- :group 'eshell-test)
-(define-obsolete-face-alias 'eshell-test-ok-face 'eshell-test-ok "22.1")
-
-(defface eshell-test-failed
- '((((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."
- :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."
- :set (lambda (symbol value)
- (if value
- (add-hook 'eshell-mode-hook 'eshell-show-usage-metrics)
- (remove-hook 'eshell-mode-hook 'eshell-show-usage-metrics))
- (set symbol value))
- :type '(choice (const :tag "No metrics" nil)
- (const :tag "Cons cells consumed" t)
- (const :tag "Time elapsed" 0))
- :group 'eshell-test)
-
-;;; Code:
-
-(defvar test-buffer)
-
-(defun eshell-insert-command (text &optional func)
- "Insert a command at the end of the buffer."
- (goto-char eshell-last-output-end)
- (insert-and-inherit text)
- (funcall (or func 'eshell-send-input)))
-
-(defun eshell-match-result (regexp)
- "Insert a command at the end of the buffer."
- (goto-char eshell-last-input-end)
- (looking-at regexp))
-
-(defun eshell-command-result-p (text regexp &optional func)
- "Insert a command at the end of the buffer."
- (eshell-insert-command text func)
- (eshell-match-result regexp))
-
-(defvar eshell-test-failures nil)
-
-(defun eshell-run-test (module funcsym label command)
- "Test whether FORM evaluates to a non-nil value."
- (when (let ((sym (intern-soft (concat "eshell-" (symbol-name module)))))
- (or (memq sym (eshell-subgroups 'eshell))
- (eshell-using-module sym)))
- (with-current-buffer test-buffer
- (insert-before-markers
- (format "%-70s " (substring label 0 (min 70 (length label)))))
- (insert-before-markers " ....")
- (eshell-redisplay))
- (let ((truth (eval command)))
- (with-current-buffer test-buffer
- (delete-backward-char 6)
- (insert-before-markers
- "[" (let (str)
- (if truth
- (progn
- (setq str " OK ")
- (put-text-property 0 6 'face 'eshell-test-ok str))
- (setq str "FAILED")
- (setq eshell-test-failures (1+ eshell-test-failures))
- (put-text-property 0 6 'face 'eshell-test-failed str))
- str) "]")
- (add-text-properties (line-beginning-position) (point)
- (list 'test-func funcsym))
- (eshell-redisplay)))))
-
-(defun eshell-test-goto-func ()
- "Jump to the function that defines a particular test."
- (interactive)
- (let ((fsym (get-text-property (point) 'test-func)))
- (when fsym
- (let* ((def (symbol-function fsym))
- (library (locate-library (symbol-file fsym 'defun)))
- (name (substring (symbol-name fsym)
- (length "eshell-test--")))
- (inhibit-redisplay t))
- (find-file library)
- (goto-char (point-min))
- (re-search-forward (concat "^(eshell-deftest\\s-+\\w+\\s-+"
- name))
- (beginning-of-line)))))
-
-(defun eshell-run-one-test (&optional arg)
- "Jump to the function that defines a particular test."
- (interactive "P")
- (let ((fsym (get-text-property (point) 'test-func)))
- (when fsym
- (beginning-of-line)
- (delete-region (point) (line-end-position))
- (let ((test-buffer (current-buffer)))
- (set-buffer (let ((inhibit-redisplay t))
- (save-window-excursion (eshell t))))
- (funcall fsym)
- (unless arg
- (kill-buffer (current-buffer)))))))
-
-;;;###autoload
-(defun eshell-test (&optional arg)
- "Test Eshell to verify that it works as expected."
- (interactive "P")
- (let* ((begin (eshell-time-to-seconds (current-time)))
- (test-buffer (get-buffer-create "*eshell test*")))
- (set-buffer (let ((inhibit-redisplay t))
- (save-window-excursion (eshell t))))
- (with-current-buffer test-buffer
- (erase-buffer)
- (setq major-mode 'eshell-test-mode)
- (setq mode-name "EShell Test")
- (set (make-local-variable 'eshell-test-failures) 0)
- (local-set-key [(control ?c) (control ?c)] 'eshell-test-goto-func)
- (local-set-key [(control ?c) (control ?r)] 'eshell-run-one-test)
- (local-set-key [(control ?m)] 'eshell-test-goto-func)
- (local-set-key [return] 'eshell-test-goto-func)
-
- (insert "Testing Eshell under " (emacs-version))
- (switch-to-buffer test-buffer)
- (delete-other-windows))
- (eshell-for funcname (sort (all-completions "eshell-test--"
- obarray 'functionp)
- 'string-lessp)
- (with-current-buffer test-buffer
- (insert "\n"))
- (funcall (intern-soft funcname)))
- (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)))
- (message "Eshell test suite completed: %s failure%s"
- (if (> eshell-test-failures 0)
- (number-to-string eshell-test-failures)
- "No")
- (if (= eshell-test-failures 1) "" "s"))))
- (goto-char eshell-last-output-end)
- (unless arg
- (kill-buffer (current-buffer))))
-
-
-(defvar eshell-metric-before-command 0)
-(defvar eshell-metric-after-command 0)
-
-(defun eshell-show-usage-metrics ()
- "If run at Eshell mode startup, metrics are shown after each command."
- (set (make-local-variable 'eshell-metric-before-command)
- (if (eq eshell-show-usage-metrics t)
- 0
- (current-time)))
- (set (make-local-variable 'eshell-metric-after-command)
- (if (eq eshell-show-usage-metrics t)
- 0
- (current-time)))
-
- (add-hook 'eshell-pre-command-hook
- (function
- (lambda ()
- (setq eshell-metric-before-command
- (if (eq eshell-show-usage-metrics t)
- (car (memory-use-counts))
- (current-time))))) nil t)
-
- (add-hook 'eshell-post-command-hook
- (function
- (lambda ()
- (setq eshell-metric-after-command
- (if (eq eshell-show-usage-metrics t)
- (car (memory-use-counts))
- (current-time)))
- (eshell-interactive-print
- (concat
- (int-to-string
- (if (eq eshell-show-usage-metrics t)
- (- eshell-metric-after-command
- eshell-metric-before-command 7)
- (- (eshell-time-to-seconds
- eshell-metric-after-command)
- (eshell-time-to-seconds
- 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 f7cf7fe1bc7..424d246a2b6 100644
--- a/lisp/eshell/esh-util.el
+++ b/lisp/eshell/esh-util.el
@@ -1,7 +1,6 @@
;;; esh-util.el --- general utilities
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -32,7 +31,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 +39,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 +95,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 +103,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"
@@ -138,7 +138,8 @@ function `string-to-number'."
(memq system-type '(ms-dos windows-nt)))
(defmacro eshell-condition-case (tag form &rest handlers)
- "Like `condition-case', but only if `eshell-pass-through-errors' is nil."
+ "If `eshell-handle-errors' is non-nil, this is `condition-case'.
+Otherwise, evaluates FORM with no error handling."
(if eshell-handle-errors
`(condition-case ,tag
,form
@@ -147,18 +148,6 @@ function `string-to-number'."
(put 'eshell-condition-case 'lisp-indent-function 2)
-(defmacro eshell-deftest (module name label &rest forms)
- (if (and (fboundp 'cl-compiling-file) (cl-compiling-file))
- nil
- (let ((fsym (intern (concat "eshell-test--" (symbol-name name)))))
- `(eval-when-compile
- (ignore
- (defun ,fsym () ,label
- (eshell-run-test (quote ,module) (quote ,fsym) ,label
- (quote (progn ,@forms)))))))))
-
-(put 'eshell-deftest 'lisp-indent-function 2)
-
(defun eshell-find-delimiter
(open close &optional bound reverse-p backslash-p)
"From point, find the CLOSE delimiter corresponding to OPEN.
@@ -285,7 +274,6 @@ Prepend remote identification of `default-directory', if any."
(setq text (replace-match " " t t text)))
text))
-;; FIXME this is just dolist.
(defmacro eshell-for (for-var for-list &rest forms)
"Iterate through a list"
`(let ((list-iter ,for-list))
@@ -296,10 +284,12 @@ Prepend remote identification of `default-directory', if any."
(put 'eshell-for 'lisp-indent-function 2)
+(make-obsolete 'eshell-for 'dolist "24.1")
+
(defun eshell-flatten-list (args)
"Flatten any lists within ARGS, so that there are no sublists."
(let ((new-list (list t)))
- (eshell-for a args
+ (dolist (a args)
(if (and (listp a)
(listp (cdr a)))
(nconc new-list (eshell-flatten-list a))
@@ -340,20 +330,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)
@@ -419,7 +395,7 @@ list."
(unless (listp entries)
(setq entries (list entries)
listified t))
- (eshell-for entry entries
+ (dolist (entry entries)
(unless (and exclude (string-match exclude entry))
(setq p predicates valid (null p))
(while p
@@ -467,7 +443,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 +497,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 +511,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 +562,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 +576,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 +771,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 9dd031a7997..69004a841f1 100644
--- a/lisp/eshell/esh-var.el
+++ b/lisp/eshell/esh-var.el
@@ -1,7 +1,6 @@
;;; esh-var.el --- handling of variables
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -110,7 +109,6 @@
(eval-when-compile
(require 'pcomplete)
- (require 'esh-test)
(require 'esh-util)
(require 'esh-opt)
(require 'esh-mode))
@@ -127,28 +125,29 @@ 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'."
+(defcustom eshell-var-load-hook nil
+ "A list of functions to call when loading `eshell-var'."
+ :version "24.1" ; removed eshell-var-initialize
: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 +182,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
@@ -352,8 +351,7 @@ This function is explicit for adding to `eshell-parse-argument-hook'."
'((?h "help" nil nil "show this usage screen")
:external "env"
:usage "<no arguments>")
- (eshell-for setting (sort (eshell-environment-variables)
- 'string-lessp)
+ (dolist (setting (sort (eshell-environment-variables) 'string-lessp))
(eshell-buffered-print setting "\n"))
(eshell-flush)))
@@ -375,7 +373,7 @@ This function is explicit for adding to `eshell-parse-argument-hook'."
This involves setting any variable aliases which affect the
environment, as specified in `eshell-variable-aliases-list'."
(let ((process-environment (eshell-copy-environment)))
- (eshell-for var-alias eshell-variable-aliases-list
+ (dolist (var-alias eshell-variable-aliases-list)
(if (nth 2 var-alias)
(setenv (car var-alias)
(eshell-stringify
@@ -478,30 +476,6 @@ Possible options are:
(t
(error "Invalid variable reference")))))
-(eshell-deftest var interp-cmd
- "Interpolate command result"
- (eshell-command-result-p "+ ${+ 1 2} 3" "6\n"))
-
-(eshell-deftest var interp-lisp
- "Interpolate Lisp form evalution"
- (eshell-command-result-p "+ $(+ 1 2) 3" "6\n"))
-
-(eshell-deftest var interp-concat
- "Interpolate and concat command"
- (eshell-command-result-p "+ ${+ 1 2}3 3" "36\n"))
-
-(eshell-deftest var interp-concat-lisp
- "Interpolate and concat Lisp form"
- (eshell-command-result-p "+ $(+ 1 2)3 3" "36\n"))
-
-(eshell-deftest var interp-concat2
- "Interpolate and concat two commands"
- (eshell-command-result-p "+ ${+ 1 2}${+ 1 2} 3" "36\n"))
-
-(eshell-deftest var interp-concat-lisp2
- "Interpolate and concat two Lisp forms"
- (eshell-command-result-p "+ $(+ 1 2)$(+ 1 2) 3" "36\n"))
-
(defun eshell-parse-indices ()
"Parse and return a list of list of indices."
(let (indices)
@@ -624,7 +598,7 @@ For example, to retrieve the second element of a user's record in
"Generate list of applicable variables."
(let ((argname pcomplete-stub)
completions)
- (eshell-for alias eshell-variable-aliases-list
+ (dolist (alias eshell-variable-aliases-list)
(if (string-match (concat "^" argname) (car alias))
(setq completions (cons (car alias) completions))))
(sort
@@ -653,5 +627,4 @@ For example, to retrieve the second element of a user's record in
(setq pcomplete-stub (substring arg pos))
(throw 'pcomplete-completions (pcomplete-entries)))))
-;; arch-tag: 393654fe-bdad-4f27-9a10-b1472ded14cf
;;; esh-var.el ends here
diff --git a/lisp/eshell/eshell.el b/lisp/eshell/eshell.el
index d93658b9749..1a9d7c97b83 100644
--- a/lisp/eshell/eshell.el
+++ b/lisp/eshell/eshell.el
@@ -1,7 +1,6 @@
;;; eshell.el --- the Emacs command shell
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
;; Version: 2.4.2
@@ -281,25 +280,12 @@ shells such as bash, zsh, rc, 4dos."
:type 'string
:group 'eshell)
-(eshell-deftest mode same-window-buffer-names
- "`eshell-buffer-name' is a member of `same-window-buffer-names'"
- (member eshell-buffer-name same-window-buffer-names))
-
-(defcustom eshell-directory-name (convert-standard-filename "~/.eshell/")
+(defcustom eshell-directory-name
+ (locate-user-emacs-file "eshell/" ".eshell/")
"The directory where Eshell control files should be kept."
:type 'directory
:group 'eshell)
-(eshell-deftest mode eshell-directory-exists
- "`eshell-directory-name' exists and is writable"
- (file-writable-p eshell-directory-name))
-
-(eshell-deftest mode eshell-directory-modes
- "`eshell-directory-name' has correct access protections"
- (or (eshell-under-windows-p)
- (= (file-modes eshell-directory-name)
- eshell-private-directory-modes)))
-
;;;_* Running Eshell
;;
;; There are only three commands used to invoke Eshell. The first two
@@ -404,7 +390,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
@@ -450,10 +436,6 @@ corresponding to a successful execution."
(set status-var eshell-last-command-status))
(cadr result))))))
-(eshell-deftest mode simple-command-result
- "`eshell-command-result' works with a simple command."
- (= (eshell-command-result "+ 1 2") 3))
-
;;;_* Reporting bugs
;;
;; If you do encounter a bug, on any system, please report
@@ -474,7 +456,7 @@ Emacs."
;; if the user set `eshell-prefer-to-shell' to t, but never loaded
;; Eshell, then `eshell-subgroups' will be unbound
(when (fboundp 'eshell-subgroups)
- (eshell-for module (eshell-subgroups 'eshell)
+ (dolist (module (eshell-subgroups 'eshell))
;; this really only unloads as many modules as possible,
;; since other `require' references (such as by customizing
;; `eshell-prefer-to-shell' to a non-nil value) might make it
@@ -490,5 +472,4 @@ Emacs."
(provide 'eshell)
-;; arch-tag: 9d4d5214-0e4e-4e02-b349-39add640d63f
;;; eshell.el ends here
diff --git a/lisp/expand.el b/lisp/expand.el
index 09f0b70d6f3..544d0b1cb17 100644
--- a/lisp/expand.el
+++ b/lisp/expand.el
@@ -1,7 +1,6 @@
;;; expand.el --- make abbreviations more usable
-;; Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-1996, 2001-2011 Free Software Foundation, Inc.
;; Author: Frederic Lepied <Frederic.Lepied@sugix.frmug.org>
;; Maintainer: Frederic Lepied <Frederic.Lepied@sugix.frmug.org>
@@ -368,7 +367,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))
@@ -470,7 +469,6 @@ This is used only in conjunction with `expand-add-abbrevs'."
(beginning-of-defun)
(point))
(point-min)))
- (here (point))
(state (parse-partial-sexp lim (point))))
(cond
((nth 3 state) 'string)
@@ -504,5 +502,4 @@ This is used only in conjunction with `expand-add-abbrevs'."
;; run load hooks
(run-hooks 'expand-load-hook)
-;; arch-tag: fee53e9e-30e3-4ef3-b191-9785e1f8e885
;;; expand.el ends here
diff --git a/lisp/ezimage.el b/lisp/ezimage.el
index 47fca5fbad5..b828f79f8fa 100644
--- a/lisp/ezimage.el
+++ b/lisp/ezimage.el
@@ -1,7 +1,6 @@
;;; ezimage --- Generalized Image management
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: file, tags, tools
@@ -72,7 +71,7 @@ IMAGESPEC is the image data, and DOCSTRING is documentation for the image."
;; XEmacs.
(if (not (fboundp 'make-glyph))
- (defmacro defezimage (variable imagespec docstring)
+ (defmacro defezimage (variable _imagespec docstring)
"Don't bother loading up an image...
Argument VARIABLE is the variable to define.
Argument IMAGESPEC is the list defining the image to create.
@@ -350,5 +349,4 @@ See `ezimage-expand-image-button-alist' for details."
(provide 'ezimage)
-;; arch-tag: d4ea2d93-3c7a-4cb3-b5a6-c1b9178183aa
;;; sb-image.el ends here
diff --git a/lisp/face-remap.el b/lisp/face-remap.el
index 6bb84acb16c..9e5ab58636b 100644
--- a/lisp/face-remap.el
+++ b/lisp/face-remap.el
@@ -1,9 +1,9 @@
;;; face-remap.el --- Functions for managing `face-remapping-alist'
;;
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 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.
;;
@@ -423,5 +423,4 @@ Besides the choice of face, it is the same as `buffer-face-mode'."
(provide 'face-remap)
-;; arch-tag: 5c5f034b-8d58-4967-82bd-d61fd364e686
;;; face-remap.el ends here
diff --git a/lisp/facemenu.el b/lisp/facemenu.el
index 5c0dbba7b7c..1b42aa9ea73 100644
--- a/lisp/facemenu.el
+++ b/lisp/facemenu.el
@@ -1,10 +1,10 @@
;;; facemenu.el --- create a face menu for interactively adding fonts to text
-;; Copyright (C) 1994, 1995, 1996, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1996, 2001-2011 Free Software Foundation, Inc.
;; Author: Boris Goldowsky <boris@gnu.org>
;; Keywords: faces
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -357,7 +357,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 +379,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 +461,168 @@ 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)
+
+(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."
+ (require 'color)
+ (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-name-to-rgb color)))
+ ((eq (car-safe list-colors-sort) 'hsv-dist)
+ (let* ((c-rgb (color-name-to-rgb color))
+ (c-hsv (apply 'color-rgb-to-hsv c-rgb))
+ (o-hsv (apply 'color-rgb-to-hsv
+ (color-name-to-rgb (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*")
+ (unless buffer-name
+ (setq buffer-name "*Colors*"))
+ (with-help-window buffer-name
(with-current-buffer standard-output
- (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)))
+ (erase-buffer)
+ (list-colors-print list callback)
+ (set-buffer-modified-p nil)
+ (setq truncate-lines t)))
+ (when callback
+ (pop-to-buffer buffer-name)
+ (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))))
+ (insert (car color))
+ (indent-to 22)
+ (put-text-property opoint (point) 'face `(:background ,(car color)))
+ (put-text-property
+ (prog1 (point)
+ (insert " ")
+ ;; Insert all color names.
+ (insert (mapconcat 'identity color ",")))
+ (point)
+ 'face (list :foreground (car color)))
+ (insert (propertize " " 'display '(space :align-to (- right 9))))
+ (insert " ")
+ (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-name-to-rgb (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 +654,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 +683,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")))
@@ -721,19 +825,13 @@ MENU should be `facemenu-foreground-menu' or `facemenu-background-menu'.
Return the event type (a symbol) of the added menu entry.
This is called whenever you use a new color."
- (let (symbol docstring)
+ (let (symbol)
(unless (color-defined-p color)
(error "Color `%s' undefined" color))
(cond ((eq menu 'facemenu-foreground-menu)
- (setq docstring
- (format "Select foreground color %s for subsequent insertion."
- color)
- symbol (intern (concat "fg:" color))))
+ (setq symbol (intern (concat "fg:" color))))
((eq menu 'facemenu-background-menu)
- (setq docstring
- (format "Select background color %s for subsequent insertion."
- color)
- symbol (intern (concat "bg:" color))))
+ (setq symbol (intern (concat "bg:" color))))
(t (error "MENU should be `facemenu-foreground-menu' or `facemenu-background-menu'")))
(unless (facemenu-iterate ; Check if color is already in the menu.
(lambda (m) (and (listp m)
@@ -776,5 +874,4 @@ Returns the non-nil value it found, or nil if all were nil."
(provide 'facemenu)
-;; arch-tag: 85f6d02b-9085-420e-b651-0678f0e9c7eb
;;; facemenu.el ends here
diff --git a/lisp/faces.el b/lisp/faces.el
index cc1847a2164..3fb8bc80931 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -1,11 +1,10 @@
;;; faces.el --- Lisp faces
-;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1992-1996, 1998-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -29,7 +28,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 +184,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.
@@ -235,7 +207,7 @@ Value is FACE."
;; of realized faces. The ID assigned to Lisp faces is used to
;; support faces in display table entries.
-(defun face-id (face &optional frame)
+(defun face-id (face &optional _frame)
"Return the internal ID of face with name FACE.
If FACE is a face-alias, return the ID of the target face.
The optional argument FRAME is ignored, since the internal face ID
@@ -376,7 +348,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)
@@ -752,7 +724,7 @@ like an underlying face would be, with higher priority than underlying faces."
where))
(setq args (cddr args)))))
-(defun make-face-bold (face &optional frame noerror)
+(defun make-face-bold (face &optional frame _noerror)
"Make the font of FACE be bold, if possible.
FRAME nil or not specified means change face on all frames.
Argument NOERROR is ignored and retained for compatibility.
@@ -761,7 +733,7 @@ Use `set-face-attribute' for finer control of the font weight."
(set-face-attribute face frame :weight 'bold))
-(defun make-face-unbold (face &optional frame noerror)
+(defun make-face-unbold (face &optional frame _noerror)
"Make the font of FACE be non-bold, if possible.
FRAME nil or not specified means change face on all frames.
Argument NOERROR is ignored and retained for compatibility."
@@ -769,7 +741,7 @@ Argument NOERROR is ignored and retained for compatibility."
(set-face-attribute face frame :weight 'normal))
-(defun make-face-italic (face &optional frame noerror)
+(defun make-face-italic (face &optional frame _noerror)
"Make the font of FACE be italic, if possible.
FRAME nil or not specified means change face on all frames.
Argument NOERROR is ignored and retained for compatibility.
@@ -778,7 +750,7 @@ Use `set-face-attribute' for finer control of the font slant."
(set-face-attribute face frame :slant 'italic))
-(defun make-face-unitalic (face &optional frame noerror)
+(defun make-face-unitalic (face &optional frame _noerror)
"Make the font of FACE be non-italic, if possible.
FRAME nil or not specified means change face on all frames.
Argument NOERROR is ignored and retained for compatibility."
@@ -786,7 +758,7 @@ Argument NOERROR is ignored and retained for compatibility."
(set-face-attribute face frame :slant 'normal))
-(defun make-face-bold-italic (face &optional frame noerror)
+(defun make-face-bold-italic (face &optional frame _noerror)
"Make the font of FACE be bold and italic, if possible.
FRAME nil or not specified means change face on all frames.
Argument NOERROR is ignored and retained for compatibility.
@@ -919,13 +891,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)
@@ -964,10 +937,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
@@ -975,7 +948,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)
@@ -1338,7 +1311,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")
@@ -1440,11 +1413,12 @@ If FRAME is omitted or nil, use the selected frame."
;; Parameter FRAME Is kept for call compatibility to with previous
;; face implementation.
-(defun face-attr-construct (face &optional frame)
- "Return a `defface'-style attribute list for FACE on FRAME.
+(defun face-attr-construct (face &optional _frame)
+ "Return a `defface'-style attribute list for FACE.
Value is a property list of pairs ATTRIBUTE VALUE for all specified
face attributes of FACE where ATTRIBUTE is the attribute name and
-VALUE is the specified value of that attribute."
+VALUE is the specified value of that attribute.
+Argument FRAME is ignored and retained for compatibility."
(let (result)
(dolist (entry face-attribute-name-alist result)
(let* ((attribute (car entry))
@@ -1477,18 +1451,18 @@ If FRAME is nil, the current FRAME is used."
;; of supported colors, and all defface's
;; are changed to look at number of colors
;; instead of (type graphic) etc.
- (and (null (window-system frame))
- (memq 'tty options))
- (and (memq 'motif options)
- (featurep 'motif))
- (and (memq 'gtk options)
- (featurep 'gtk))
- (and (memq 'lucid options)
- (featurep 'x-toolkit)
- (not (featurep 'motif))
- (not (featurep 'gtk)))
- (and (memq 'x-toolkit options)
- (featurep 'x-toolkit))))
+ (if (null (window-system frame))
+ (memq 'tty options)
+ (or (and (memq 'motif options)
+ (featurep 'motif))
+ (and (memq 'gtk options)
+ (featurep 'gtk))
+ (and (memq 'lucid options)
+ (featurep 'x-toolkit)
+ (not (featurep 'motif))
+ (not (featurep 'gtk)))
+ (and (memq 'x-toolkit options)
+ (featurep 'x-toolkit))))))
((eq req 'min-colors)
(>= (display-color-cells frame) (car options)))
((eq req 'class)
@@ -1536,12 +1510,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.
@@ -1619,8 +1592,8 @@ is used. If nil or omitted, use the selected frame."
(plist-put plist :weight (if bold 'bold 'normal)))
(if italic
(plist-put plist :slant (if italic 'italic 'normal)))
- (while (and match (not (null list)))
- (let* ((attr (car (car list)))
+ (while (and match list)
+ (let* ((attr (caar list))
(specified-value
(if (plist-member plist attr)
(plist-get plist attr)
@@ -1630,7 +1603,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))
@@ -1681,18 +1654,28 @@ If COLOR is the symbol `unspecified' or one of the strings
(defun color-values (color &optional frame)
"Return a description of the color named COLOR on frame FRAME.
-The value is a list of integer RGB values--(RED GREEN BLUE).
-These values appear to range from 0 to 65280 or 65535, depending
-on the system; white is \(65280 65280 65280\) or \(65535 65535 65535\).
+COLOR should be a string naming a color (e.g. \"white\"), or a
+string specifying a color's RGB components (e.g. \"#ff12ec\").
+
+Return a list of three integers, (RED GREEN BLUE), each between 0
+and either 65280 or 65535 (the maximum depends on the system).
+Use `color-name-to-rgb' if you want RGB floating-point values
+normalized to 1.0.
+
If FRAME is omitted or nil, use the selected frame.
If FRAME cannot display COLOR, the value is nil.
-If COLOR is the symbol `unspecified' or one of the strings
-\"unspecified-fg\" or \"unspecified-bg\", the value is nil."
- (if (member color '(unspecified "unspecified-fg" "unspecified-bg"))
- nil
- (if (memq (framep (or frame (selected-frame))) '(x w32 ns))
- (xw-color-values color frame)
- (tty-color-values color frame))))
+
+COLOR can also be the symbol `unspecified' or one of the strings
+\"unspecified-fg\" or \"unspecified-bg\", in which case the
+return value is nil."
+ (cond
+ ((member color '(unspecified "unspecified-fg" "unspecified-bg"))
+ nil)
+ ((memq (framep (or frame (selected-frame))) '(x w32 ns))
+ (xw-color-values color frame))
+ (t
+ (tty-color-values color frame))))
+
(defalias 'x-color-values 'color-values)
(declare-function xw-display-color-p "xfns.c" (&optional terminal))
@@ -1718,89 +1701,75 @@ 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.
+
+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.
+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, use a default prompt.
-Optional arg PROMPT is the prompt; if nil, uses a default prompt.
+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.
-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.
+If optional arg ALLOW-EMPTY-NAME is non-nil, the user is allowed
+to enter an empty color name (the empty 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.
-
-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)))
+
+ ;; 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.
@@ -1878,10 +1847,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)
@@ -1929,29 +1901,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)))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -1964,8 +1936,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)
@@ -1976,7 +1947,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))
@@ -1988,7 +1959,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
@@ -2011,16 +1981,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))
@@ -2036,7 +2003,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)
@@ -2051,21 +2018,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)
@@ -2077,16 +2045,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))))
@@ -2102,11 +2068,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
@@ -2117,7 +2080,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
@@ -2173,27 +2136,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.
@@ -2306,6 +2252,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))
@@ -2513,7 +2462,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"
@@ -2555,6 +2506,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.
@@ -2641,98 +2601,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/ffap.el b/lisp/ffap.el
index 842e693a0c1..97105ed422b 100644
--- a/lisp/ffap.el
+++ b/lisp/ffap.el
@@ -1,7 +1,6 @@
;;; ffap.el --- find file (or url) at point
-;; Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-1997, 2000-2011 Free Software Foundation, Inc.
;; Author: Michelangelo Grigni <mic@mathcs.emory.edu>
;; Maintainer: FSF
@@ -1960,5 +1959,4 @@ Of course if you do not like these bindings, just roll your own!")
(provide 'ffap)
-;; arch-tag: 9dd3e88a-5dec-4607-bd57-60ae9ede8ebc
;;; ffap.el ends here
diff --git a/lisp/filecache.el b/lisp/filecache.el
index 1dc551bc549..ef41fb41907 100644
--- a/lisp/filecache.el
+++ b/lisp/filecache.el
@@ -1,7 +1,6 @@
;;; filecache.el --- find files using a pre-loaded cache
-;; Copyright (C) 1996, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 2000-2011 Free Software Foundation, Inc.
;; Author: Peter Breton <pbreton@cs.umb.edu>
;; Created: Sun Nov 10 1996
@@ -207,7 +206,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 +215,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 +224,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 +686,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 7068e49d6a4..a6320b32e50 100644
--- a/lisp/files-x.el
+++ b/lisp/files-x.el
@@ -1,10 +1,11 @@
;;; files-x.el --- extended file handling commands
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
;; Author: Juri Linkov <juri@jurta.org>
;; Maintainer: FSF
;; Keywords: files
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -298,11 +299,11 @@ from the -*- line ignoring the input argument VALUE."
(or (looking-at "[ \t]*\\([^ \t\n:]+\\)[ \t]*:[ \t]*")
(throw 'exit (message "Malformed -*- line")))
(goto-char (match-end 0))
- (let ((key (intern (match-string 1)))
- (val (save-restriction
- (narrow-to-region (point) end)
- (let ((read-circle nil))
- (read (current-buffer))))))
+ (let ((key (intern (match-string 1))))
+ (save-restriction
+ (narrow-to-region (point) end)
+ (let ((read-circle nil))
+ (read (current-buffer))))
(skip-chars-forward " \t;")
(when (eq key variable)
(delete-region (match-beginning 0) (point))
@@ -343,6 +344,8 @@ then this function adds it."
(list (read-file-local-variable "Delete -*- file-local variable")))
(modify-file-local-variable-prop-line variable nil 'delete))
+(defvar auto-insert) ; from autoinsert.el
+
(defun modify-dir-local-variable (mode variable value op)
"Modify directory-local VARIABLE in .dir-locals.el depending on operation OP.
@@ -359,18 +362,28 @@ from the MODE alist ignoring the input argument VALUE."
(catch 'exit
(unless enable-local-variables
(throw 'exit (message "Directory-local variables are disabled")))
-
(let ((variables-file (or (and (buffer-file-name)
(not (file-remote-p (buffer-file-name)))
(dir-locals-find-file (buffer-file-name)))
dir-locals-file))
variables)
-
+ (if (consp variables-file) ; result from cache
+ ;; If cache element has an mtime, assume it came from a file.
+ ;; Otherwise, assume it was set directly.
+ (setq variables-file (if (nth 2 variables-file)
+ (expand-file-name dir-locals-file
+ (car variables-file))
+ (cadr variables-file))))
+ ;; I can't be bothered to handle this case right now.
+ ;; Dir locals were set directly from a class. You need to
+ ;; directly modify the class in dir-locals-class-alist.
+ (and variables-file (not (stringp variables-file))
+ (throw 'exit (message "Directory locals were not set from a file")))
;; Don't create ".dir-locals.el" for the deletion operation.
- (when (and (eq op 'delete)
- (not (file-exists-p variables-file)))
- (throw 'exit (message "File .dir-locals.el not found")))
-
+ (and (eq op 'delete)
+ (or (not variables-file)
+ (not (file-exists-p variables-file)))
+ (throw 'exit (message "No .dir-locals.el file was found")))
(let ((auto-insert nil))
(find-file variables-file))
(widen)
@@ -460,5 +473,4 @@ from the MODE alist ignoring the input argument VALUE."
(provide 'files-x)
-;; arch-tag: 949d263c-30a8-4b49-af26-cda97c7c5477
;;; files-x.el ends here
diff --git a/lisp/files.el b/lisp/files.el
index 91fed0d1274..336a0a436f9 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -1,10 +1,9 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1987, 1992-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -117,13 +116,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)
@@ -191,17 +191,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.
@@ -578,6 +567,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
@@ -595,15 +587,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.
@@ -638,22 +635,22 @@ the value of `default-directory'."
"Value of the CDPATH environment variable, as a list.
Not actually set up until the first time you use it.")
-(defun parse-colon-path (cd-path)
+(defun parse-colon-path (search-path)
"Explode a search path into a list of directory names.
Directories are separated by occurrences of `path-separator'
\(which is colon in GNU and GNU-like systems)."
;; We could use split-string here.
- (and cd-path
+ (and search-path
(let (cd-list (cd-start 0) cd-colon)
- (setq cd-path (concat cd-path path-separator))
- (while (setq cd-colon (string-match path-separator cd-path cd-start))
+ (setq search-path (concat search-path path-separator))
+ (while (setq cd-colon (string-match path-separator search-path cd-start))
(setq cd-list
(nconc cd-list
(list (if (= cd-start cd-colon)
nil
(substitute-in-file-name
(file-name-as-directory
- (substring cd-path cd-start cd-colon)))))))
+ (substring search-path cd-start cd-colon)))))))
(setq cd-start (+ cd-colon 1)))
cd-list)))
@@ -684,26 +681,37 @@ that list of directories (separated by occurrences of
`path-separator') when resolving a relative directory name.
The path separator is colon in GNU and GNU-like systems."
(interactive
- (list (read-directory-name "Change default directory: "
- default-directory default-directory
- (and (member cd-path '(nil ("./")))
- (null (getenv "CDPATH"))))))
- (if (file-name-absolute-p dir)
- (cd-absolute (expand-file-name dir))
- (if (null cd-path)
- (let ((trypath (parse-colon-path (getenv "CDPATH"))))
- (setq cd-path (or trypath (list "./")))))
- (if (not (catch 'found
- (mapc
- (function (lambda (x)
- (let ((f (expand-file-name (concat x dir))))
- (if (file-directory-p f)
- (progn
- (cd-absolute f)
- (throw 'found t))))))
- cd-path)
- nil))
- (error "No such directory found via CDPATH environment variable"))))
+ (list
+ ;; FIXME: There's a subtle bug in the completion below. Seems linked
+ ;; to a fundamental difficulty of implementing `predicate' correctly.
+ ;; The manifestation is that TAB may list non-directories in the case where
+ ;; those files also correspond to valid directories (if your cd-path is (A/
+ ;; B/) and you have A/a a file and B/a a directory, then both `a' and `a/'
+ ;; will be listed as valid completions).
+ ;; This is because `a' (listed because of A/a) is indeed a valid choice
+ ;; (which will lead to the use of B/a).
+ (minibuffer-with-setup-hook
+ (lambda ()
+ (setq minibuffer-completion-table
+ (apply-partially #'locate-file-completion-table
+ cd-path nil))
+ (setq minibuffer-completion-predicate
+ (lambda (dir)
+ (locate-file dir cd-path nil
+ (lambda (f) (and (file-directory-p f) 'dir-ok))))))
+ (unless cd-path
+ (setq cd-path (or (parse-colon-path (getenv "CDPATH"))
+ (list "./"))))
+ (read-directory-name "Change default directory: "
+ default-directory default-directory
+ t))))
+ (unless cd-path
+ (setq cd-path (or (parse-colon-path (getenv "CDPATH"))
+ (list "./"))))
+ (cd-absolute
+ (or (locate-file dir cd-path nil
+ (lambda (f) (and (file-directory-p f) 'dir-ok)))
+ (error "No such directory found via CDPATH environment variable"))))
(defun load-file (file)
"Load the Lisp file named FILE."
@@ -723,9 +731,12 @@ If SUFFIXES is non-nil, it should be a list of suffixes to append to
file name when searching. If SUFFIXES is nil, it is equivalent to '(\"\").
Use '(\"/\") to disable PATH search, but still try the suffixes in SUFFIXES.
If non-nil, PREDICATE is used instead of `file-readable-p'.
+
+This function will normally skip directories, so if you want it to find
+directories, make sure the PREDICATE function returns `dir-ok' for them.
+
PREDICATE can also be an integer to pass to the `access' system call,
in which case file-name handlers are ignored. This usage is deprecated.
-
For compatibility, PREDICATE can also be one of the symbols
`executable', `readable', `writable', or `exists', or a list of
one or more of those symbols."
@@ -753,21 +764,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)))))
@@ -831,11 +866,10 @@ and return the directory. Return nil if not found."
;; `name' in /home or in /.
(setq file (abbreviate-file-name file))
(let ((root nil)
- (prev-file file)
;; `user' is not initialized outside the loop because
;; `file' may not exist, so we may have to walk up part of the
- ;; hierarchy before we find the "initial UID".
- (user nil)
+ ;; hierarchy before we find the "initial UID". Note: currently unused
+ ;; (user nil)
try)
(while (not (or root
(null file)
@@ -852,8 +886,7 @@ and return the directory. Return nil if not found."
(string-match locate-dominating-stop-dir-regexp file)))
(setq try (file-exists-p (expand-file-name name file)))
(cond (try (setq root file))
- ((equal file (setq prev-file file
- file (file-name-directory
+ ((equal file (setq file (file-name-directory
(directory-file-name file))))
(setq file nil))))
root))
@@ -906,6 +939,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
@@ -918,7 +981,8 @@ accessible."
nil)))
(defun file-truename (filename &optional counter prev-dirs)
- "Return the truename of FILENAME, which should be absolute.
+ "Return the truename of FILENAME.
+If FILENAME is not absolute, first expands it against `default-directory'.
The truename of a file name is found by chasing symbolic links
both at the level of the file and at the level of the directories
containing it, until no links are left at any level.
@@ -1074,6 +1138,37 @@ it means chase no more than that many links and then stop."
(setq count (1+ count))))
newname))
+;; A handy function to display file sizes in human-readable form.
+;; See http://en.wikipedia.org/wiki/Kibibyte for the reference.
+(defun file-size-human-readable (file-size &optional flavor)
+ "Produce a string showing FILE-SIZE in human-readable form.
+
+Optional second argument FLAVOR controls the units and the display format:
+
+ If FLAVOR is nil or omitted, each kilobyte is 1024 bytes and the produced
+ suffixes are \"k\", \"M\", \"G\", \"T\", etc.
+ If FLAVOR is `si', each kilobyte is 1000 bytes and the produced suffixes
+ are \"k\", \"M\", \"G\", \"T\", etc.
+ If FLAVOR is `iec', each kilobyte is 1024 bytes and the produced suffixes
+ are \"KiB\", \"MiB\", \"GiB\", \"TiB\", etc."
+ (let ((power (if (or (null flavor) (eq flavor 'iec))
+ 1024.0
+ 1000.0))
+ (post-fixes
+ ;; none, kilo, mega, giga, tera, peta, exa, zetta, yotta
+ (list "" "k" "M" "G" "T" "P" "E" "Z" "Y")))
+ (while (and (>= file-size power) (cdr post-fixes))
+ (setq file-size (/ file-size power)
+ post-fixes (cdr post-fixes)))
+ (format (if (> (mod file-size 1.0) 0.05)
+ "%.1f%s%s"
+ "%.0f%s%s")
+ file-size
+ (if (and (eq flavor 'iec) (string= (car post-fixes) "k"))
+ "K"
+ (car post-fixes))
+ (if (eq flavor 'iec) "iB" ""))))
+
(defun make-temp-file (prefix &optional dir-flag suffix)
"Create a temporary file.
The returned file name (created by appending some random characters at the end
@@ -1271,7 +1366,7 @@ its documentation for additional customization information."
(interactive "BDisplay buffer in other frame: ")
(let ((pop-up-frames t)
same-window-buffer-names same-window-regexps
- (old-window (selected-window))
+ ;;(old-window (selected-window))
new-window)
(setq new-window (display-buffer buffer t))
;; This may have been here in order to prevent the new frame from hiding
@@ -1478,6 +1573,8 @@ expand wildcards (if any) and replace the file with multiple files."
(other-window 1)
(find-alternate-file filename wildcards))))
+(defvar kill-buffer-hook) ; from buffer.c
+
(defun find-alternate-file (filename &optional wildcards)
"Find file FILENAME, select its buffer, kill previous buffer.
If the current buffer now contains an empty file that you just visited
@@ -1506,7 +1603,7 @@ killed."
(error "Aborted"))
(when (and (buffer-modified-p) buffer-file-name)
(if (yes-or-no-p (format "Buffer %s is modified; save it first? "
- (buffer-name)))
+ (buffer-name)))
(save-buffer)
(unless (yes-or-no-p "Kill and replace the buffer without saving it? ")
(error "Aborted"))))
@@ -1708,12 +1805,11 @@ When nil, never request confirmation."
"If file SIZE larger than `large-file-warning-threshold', allow user to abort.
OP-TYPE specifies the file operation being performed (for message to user)."
(when (and large-file-warning-threshold size
- (> size large-file-warning-threshold)
- (not (y-or-n-p
- (format "File %s is large (%dMB), really %s? "
- (file-name-nondirectory filename)
- (/ size 1048576) op-type))))
- (error "Aborted")))
+ (> size large-file-warning-threshold)
+ (not (y-or-n-p (format "File %s is large (%dMB), really %s? "
+ (file-name-nondirectory filename)
+ (/ size 1048576) op-type))))
+ (error "Aborted")))
(defun find-file-noselect (filename &optional nowarn rawfile wildcards)
"Read file FILENAME into a buffer and return the buffer.
@@ -1829,8 +1925,8 @@ the various files."
(not nonexistent)
;; It is confusing to ask whether to visit
;; non-literally if they have the file in
- ;; hexl-mode.
- (not (eq major-mode 'hexl-mode)))
+ ;; hexl-mode or image-mode.
+ (not (memq major-mode '(hexl-mode image-mode))))
(if (buffer-modified-p)
(if (y-or-n-p
(format
@@ -1977,7 +2073,7 @@ This function ensures that none of these modifications will take place."
(inhibit-file-name-operation 'insert-file-contents))
(unwind-protect
(progn
- (fset 'find-buffer-file-type (lambda (filename) t))
+ (fset 'find-buffer-file-type (lambda (_filename) t))
(insert-file-contents filename visit beg end replace))
(if find-buffer-file-type-function
(fset 'find-buffer-file-type find-buffer-file-type-function)
@@ -2035,10 +2131,8 @@ the file contents into it using `insert-file-contents-literally'."
(confirm-nonexistent-file-or-buffer))))
(switch-to-buffer (find-file-noselect filename nil t)))
-(defvar after-find-file-from-revert-buffer nil)
-
(defun after-find-file (&optional error warn noauto
- after-find-file-from-revert-buffer
+ _after-find-file-from-revert-buffer
nomodes)
"Called after finding a file and by the default revert function.
Sets buffer mode, parses local variables.
@@ -2046,8 +2140,8 @@ Optional args ERROR, WARN, and NOAUTO: ERROR non-nil means there was an
error in reading the file. WARN non-nil means warn if there
exists an auto-save file more recent than the visited file.
NOAUTO means don't mess with auto-save mode.
-Fourth arg AFTER-FIND-FILE-FROM-REVERT-BUFFER non-nil
- means this call was from `revert-buffer'.
+Fourth arg AFTER-FIND-FILE-FROM-REVERT-BUFFER is ignored
+\(see `revert-buffer-in-progress-p' for similar functionality).
Fifth arg NOMODES non-nil means don't alter the file's modes.
Finishes by calling the functions in `find-file-hook'
unless NOMODES is non-nil."
@@ -2088,7 +2182,7 @@ unless NOMODES is non-nil."
(message "%s" msg)
(or not-serious (sit-for 1 t))))
(when (and auto-save-default (not noauto))
- (auto-save-mode t)))
+ (auto-save-mode 1)))
;; Make people do a little extra work (C-x C-q)
;; before altering a backup file.
(when (backup-file-name-p buffer-file-name)
@@ -2164,7 +2258,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.
@@ -2183,7 +2277,16 @@ since only a single case-insensitive search through the alist is made."
(lambda (elt)
(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)
+ ("\\.[sx]?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.
@@ -2219,6 +2322,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)
@@ -2235,6 +2346,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)
@@ -2257,15 +2369,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)
@@ -2275,6 +2386,7 @@ ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|RAR\\)\\'" . archive-mode)
("\\.dtd\\'" . sgml-mode)
("\\.ds\\(ss\\)?l\\'" . dsssl-mode)
("\\.js\\'" . js-mode) ; javascript-mode would be better
+ ("\\.json\\'" . js-mode)
("\\.[ds]?vh?\\'" . verilog-mode)
;; .emacs or .gnus or .viper following a directory delimiter in
;; Unix, MSDOG or VMS syntax.
@@ -2285,6 +2397,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)
@@ -2292,7 +2418,7 @@ ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|RAR\\)\\'" . archive-mode)
("\\.\\(diffs?\\|patch\\|rej\\)\\'" . diff-mode)
("\\.\\(dif\\|pat\\)\\'" . diff-mode) ; for MSDOG
("\\.[eE]?[pP][sS]\\'" . ps-mode)
- ("\\.\\(?:PDF\\|DVI\\|pdf\\|dvi\\)\\'" . doc-view-mode)
+ ("\\.\\(?:PDF\\|DVI\\|OD[FGPST]\\|DOCX?\\|XLSX?\\|PPTX?\\|pdf\\|dvi\\|od[fgpst]\\|docx?\\|xlsx?\\|pptx?\\)\\'" . doc-view-mode-maybe)
("configure\\.\\(ac\\|in\\)\\'" . autoconf-mode)
("\\.s\\(v\\|iv\\|ieve\\)\\'" . sieve-mode)
("BROWSE\\'" . ebrowse-tree-mode)
@@ -2300,7 +2426,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)
@@ -2410,7 +2535,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).
@@ -2566,7 +2692,7 @@ we don't actually set it to the same mode the buffer already has."
(min (point-max)
(+ (point-min) magic-mode-regexp-match-limit)))
(assoc-default nil magic-mode-alist
- (lambda (re dummy)
+ (lambda (re _dummy)
(if (functionp re)
(funcall re)
(looking-at re)))))))
@@ -2619,7 +2745,7 @@ we don't actually set it to the same mode the buffer already has."
(min (point-max)
(+ (point-min) magic-mode-regexp-match-limit)))
(assoc-default nil magic-fallback-mode-alist
- (lambda (re dummy)
+ (lambda (re _dummy)
(if (functionp re)
(funcall re)
(looking-at re)))))))
@@ -2711,7 +2837,9 @@ symbol and VAL is a value that is considered safe."
:type 'alist)
(defcustom safe-local-eval-forms
- '((add-hook 'write-file-functions 'time-stamp)
+ ;; This should be here at least as long as Emacs supports write-file-hooks.
+ '((add-hook 'write-file-hooks 'time-stamp)
+ (add-hook 'write-file-functions 'time-stamp)
(add-hook 'before-save-hook 'time-stamp))
"Expressions that are considered safe in an `eval:' local variable.
Add expressions to this list if you want Emacs to evaluate them, when
@@ -2719,7 +2847,7 @@ they appear in an `eval' local variable specification, without first
asking you for confirmation."
:risky t
:group 'find-file
- :version "22.2"
+ :version "24.1" ; added write-file-hooks
:type '(repeat sexp))
;; Risky local variables:
@@ -2771,17 +2899,22 @@ asking you for confirmation."
;;
;; For variables defined in the C source code the declaration should go here:
-(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
+(dolist (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)
+ (lexical-binding . booleanp) ;; C source code
+ (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 (car pair) 'safe-local-variable (cdr pair)))
+
+(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)
@@ -2818,95 +2951,84 @@ variable to set.")
ALL-VARS is the list of all variables to be set up.
UNSAFE-VARS is the list of those that aren't marked as safe or risky.
RISKY-VARS is the list of those that are marked as risky.
-DIR-NAME is a directory name if these settings come from
-directory-local variables, or nil otherwise."
+If these settings come from directory-local variables, then
+DIR-NAME is the name of the associated directory. Otherwise it is nil."
(if noninteractive
nil
- (let ((name (or dir-name
- (if buffer-file-name
- (file-name-nondirectory buffer-file-name)
- (concat "buffer " (buffer-name)))))
- (offer-save (and (eq enable-local-variables t) unsafe-vars))
- prompt char)
- (save-window-excursion
- (let ((buf (get-buffer-create "*Local Variables*")))
- (pop-to-buffer buf)
- (set (make-local-variable 'cursor-type) nil)
- (erase-buffer)
- (if unsafe-vars
- (insert "The local variables list in " name
- "\ncontains values that may not be safe (*)"
- (if risky-vars
- ", and variables that are risky (**)."
- "."))
- (if risky-vars
- (insert "The local variables list in " name
- "\ncontains variables that are risky (**).")
- (insert "A local variables list is specified in " name ".")))
- (insert "\n\nDo you want to apply it? You can type
+ (save-window-excursion
+ (let* ((name (or dir-name
+ (if buffer-file-name
+ (file-name-nondirectory buffer-file-name)
+ (concat "buffer " (buffer-name)))))
+ (offer-save (and (eq enable-local-variables t)
+ unsafe-vars))
+ (exit-chars
+ (if offer-save '(?! ?y ?n ?\s ?\C-g) '(?y ?n ?\s ?\C-g)))
+ (buf (pop-to-buffer "*Local Variables*"))
+ prompt char)
+ (set (make-local-variable 'cursor-type) nil)
+ (erase-buffer)
+ (cond
+ (unsafe-vars
+ (insert "The local variables list in " name
+ "\ncontains values that may not be safe (*)"
+ (if risky-vars
+ ", and variables that are risky (**)."
+ ".")))
+ (risky-vars
+ (insert "The local variables list in " name
+ "\ncontains variables that are risky (**)."))
+ (t
+ (insert "A local variables list is specified in " name ".")))
+ (insert "\n\nDo you want to apply it? You can type
y -- to apply the local variables list.
n -- to ignore the local variables list.")
- (if offer-save
- (insert "
+ (if offer-save
+ (insert "
! -- to apply the local variables list, and permanently mark these
values (*) as safe (in the future, they will be set automatically.)\n\n")
- (insert "\n\n"))
- (dolist (elt all-vars)
- (cond ((member elt unsafe-vars)
- (insert " * "))
- ((member elt risky-vars)
- (insert " ** "))
- (t
- (insert " ")))
- (princ (car elt) buf)
- (insert " : ")
- ;; Make strings with embedded whitespace easier to read.
- (let ((print-escape-newlines t))
- (prin1 (cdr elt) buf))
- (insert "\n"))
- (setq prompt
- (format "Please type %s%s: "
- (if offer-save "y, n, or !" "y or n")
- (if (< (line-number-at-pos) (window-body-height))
- ""
- ", or C-v to scroll")))
- (goto-char (point-min))
- (let ((cursor-in-echo-area t)
- (executing-kbd-macro executing-kbd-macro)
- (exit-chars
- (if offer-save '(?! ?y ?n ?\s ?\C-g) '(?y ?n ?\s ?\C-g)))
- done)
- (while (not done)
- (message "%s" prompt)
- (setq char (read-event))
- (if (numberp char)
- (cond ((eq char ?\C-v)
- (condition-case nil
- (scroll-up)
- (error (goto-char (point-min)))))
- ;; read-event returns -1 if we are in a kbd
- ;; macro and there are no more events in the
- ;; macro. In that case, attempt to get an
- ;; event interactively.
- ((and executing-kbd-macro (= char -1))
- (setq executing-kbd-macro nil))
- (t (setq done (memq (downcase char) exit-chars)))))))
- (setq char (downcase char))
- (when (and offer-save (= char ?!) unsafe-vars)
- (dolist (elt unsafe-vars)
- (add-to-list 'safe-local-variable-values elt))
- ;; When this is called from desktop-restore-file-buffer,
- ;; coding-system-for-read may be non-nil. Reset it before
- ;; writing to .emacs.
- (if (or custom-file user-init-file)
- (let ((coding-system-for-read nil))
- (customize-save-variable
- 'safe-local-variable-values
- safe-local-variable-values))))
- (kill-buffer buf)
- (or (= char ?!)
- (= char ?\s)
- (= char ?y)))))))
+ (insert "\n\n"))
+ (dolist (elt all-vars)
+ (cond ((member elt unsafe-vars)
+ (insert " * "))
+ ((member elt risky-vars)
+ (insert " ** "))
+ (t
+ (insert " ")))
+ (princ (car elt) buf)
+ (insert " : ")
+ ;; Make strings with embedded whitespace easier to read.
+ (let ((print-escape-newlines t))
+ (prin1 (cdr elt) buf))
+ (insert "\n"))
+ (setq prompt
+ (format "Please type %s%s: "
+ (if offer-save "y, n, or !" "y or n")
+ (if (< (line-number-at-pos) (window-body-height))
+ ""
+ (push ?\C-v exit-chars)
+ ", or C-v to scroll")))
+ (goto-char (point-min))
+ (while (null char)
+ (setq char (read-char-choice prompt exit-chars t))
+ (when (eq char ?\C-v)
+ (condition-case nil
+ (scroll-up)
+ (error (goto-char (point-min))))
+ (setq char nil)))
+ (kill-buffer buf)
+ (when (and offer-save (= char ?!) unsafe-vars)
+ (dolist (elt unsafe-vars)
+ (add-to-list 'safe-local-variable-values elt))
+ ;; When this is called from desktop-restore-file-buffer,
+ ;; coding-system-for-read may be non-nil. Reset it before
+ ;; writing to .emacs.
+ (if (or custom-file user-init-file)
+ (let ((coding-system-for-read nil))
+ (customize-save-variable
+ 'safe-local-variable-values
+ safe-local-variable-values))))
+ (memq char '(?! ?\s ?y))))))
(defun hack-local-variables-prop-line (&optional mode-only)
"Return local variables specified in the -*- line.
@@ -2972,8 +3094,8 @@ VARIABLES is the alist of variable-value settings. This alist is
`enable-local-eval', `enable-local-variables', and (if necessary)
user interaction. The results are added to
`file-local-variables-alist', without applying them.
-DIR-NAME is a directory name if these settings come from
- directory-local variables, or nil otherwise."
+If these settings come from directory-local variables, then
+DIR-NAME is the name of the associated directory. Otherwise it is nil."
;; Find those variables that we may want to save to
;; `safe-local-variable-values'.
(let (all-vars risky-vars unsafe-vars)
@@ -3120,14 +3242,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.
@@ -3145,7 +3270,7 @@ It is safe if any of these conditions are met:
;; can't assure us that the value is safe.
(with-demoted-errors (funcall safep val))))))
-(defun risky-local-variable-p (sym &optional ignored)
+(defun risky-local-variable-p (sym &optional _ignored)
"Non-nil if SYM could be dangerous as a file-local variable.
It is dangerous if either of these conditions are met:
@@ -3202,21 +3327,25 @@ It is dangerous if either of these conditions are met:
;; Certain functions can be allowed with safe arguments
;; or can specify verification functions to try.
(and (symbolp (car exp))
- (let ((prop (get (car exp) 'safe-local-eval-function)))
- (cond ((eq prop t)
- (let ((ok t))
- (dolist (arg (cdr exp))
- (unless (hack-one-local-variable-constantp arg)
- (setq ok nil)))
- ok))
- ((functionp prop)
- (funcall prop exp))
- ((listp prop)
- (let ((ok nil))
- (dolist (function prop)
- (if (funcall function exp)
- (setq ok t)))
- ok)))))))
+ ;; Allow (minor)-modes calls with no arguments.
+ ;; This obsoletes the use of "mode:" for such things. (Bug#8613)
+ (or (and (null (cdr exp))
+ (string-match "-mode\\'" (symbol-name (car exp))))
+ (let ((prop (get (car exp) 'safe-local-eval-function)))
+ (cond ((eq prop t)
+ (let ((ok t))
+ (dolist (arg (cdr exp))
+ (unless (hack-one-local-variable-constantp arg)
+ (setq ok nil)))
+ ok))
+ ((functionp prop)
+ (funcall prop exp))
+ ((listp prop)
+ (let ((ok nil))
+ (dolist (function prop)
+ (if (funcall function exp)
+ (setq ok t)))
+ ok))))))))
(defun hack-one-local-variable (var val)
"Set local variable VAR with value VAL.
@@ -3254,11 +3383,11 @@ Each element in this list has the form (DIR CLASS MTIME).
DIR is the name of the directory.
CLASS is the name of a variable class (a symbol).
MTIME is the recorded modification time of the directory-local
- variables file associated with this entry. This time is a list
- of two integers (the same format as `file-attributes'), and is
- used to test whether the cache entry is still valid.
- Alternatively, MTIME can be nil, which means the entry is always
- considered valid.")
+variables file associated with this entry. This time is a list
+of two integers (the same format as `file-attributes'), and is
+used to test whether the cache entry is still valid.
+Alternatively, MTIME can be nil, which means the entry is always
+considered valid.")
(defsubst dir-locals-get-class-variables (class)
"Return the variable list for CLASS."
@@ -3285,22 +3414,40 @@ ROOT is the root directory of the project.
Return the new variables list."
(let* ((file-name (buffer-file-name))
(sub-file-name (if file-name
+ ;; FIXME: Why not use file-relative-name?
(substring file-name (length root)))))
- (dolist (entry class-variables variables)
- (let ((key (car entry)))
- (cond
- ((stringp key)
- ;; Don't include this in the previous condition, because we
- ;; want to filter all strings before the next condition.
- (when (and sub-file-name
- (>= (length sub-file-name) (length key))
- (string= key (substring sub-file-name 0 (length key))))
- (setq variables (dir-locals-collect-variables
- (cdr entry) root variables))))
- ((or (not key)
- (derived-mode-p key))
- (setq variables (dir-locals-collect-mode-variables
- (cdr entry) variables))))))))
+ (condition-case err
+ (dolist (entry class-variables variables)
+ (let ((key (car entry)))
+ (cond
+ ((stringp key)
+ ;; Don't include this in the previous condition, because we
+ ;; want to filter all strings before the next condition.
+ (when (and sub-file-name
+ (>= (length sub-file-name) (length key))
+ (string-prefix-p key sub-file-name))
+ (setq variables (dir-locals-collect-variables
+ (cdr entry) root variables))))
+ ((or (not key)
+ (derived-mode-p key))
+ (let* ((alist (cdr entry))
+ (subdirs (assq 'subdirs alist)))
+ (if (or (not subdirs)
+ (progn
+ (setq alist (delq subdirs alist))
+ (cdr-safe subdirs))
+ ;; TODO someone might want to extend this to allow
+ ;; integer values for subdir, where N means
+ ;; variables apply to this directory and N levels
+ ;; below it (0 == nil).
+ (equal root default-directory))
+ (setq variables (dir-locals-collect-mode-variables
+ alist variables))))))))
+ (error
+ ;; The file's content might be invalid (e.g. have a merge conflict), but
+ ;; that shouldn't prevent the user from opening the file.
+ (message ".dir-locals error: %s" (error-message-string err))
+ nil))))
(defun dir-locals-set-directory-class (directory class &optional mtime)
"Declare that the DIRECTORY root is an instance of CLASS.
@@ -3360,13 +3507,20 @@ across different environments and users.")
(defun dir-locals-find-file (file)
"Find the directory-local variables for FILE.
This searches upward in the directory tree from FILE.
-If the directory root of FILE has been registered in
- `dir-locals-directory-cache' and the directory-local variables
- file has not been modified, return the matching entry in
- `dir-locals-directory-cache'.
-Otherwise, if a directory-local variables file is found, return
- the file name.
-Otherwise, return nil."
+It stops at the first directory that has been registered in
+`dir-locals-directory-cache' or contains a `dir-locals-file'.
+If it finds an entry in the cache, it checks that it is valid.
+A cache entry with no modification time element (normally, one that
+has been assigned directly using `dir-locals-set-directory-class', not
+set from a file) is always valid.
+A cache entry based on a `dir-locals-file' is valid if the modification
+time stored in the cache matches the current file modification time.
+If not, the cache entry is cleared so that the file will be re-read.
+
+This function returns either nil (no directory local variables found),
+or the matching entry from `dir-locals-directory-cache' (a list),
+or the full path to the `dir-locals-file' (a string) in the case
+of no valid cache entry."
(setq file (expand-file-name file))
(let* ((dir-locals-file-name
(if (eq system-type 'ms-dos)
@@ -3375,8 +3529,8 @@ Otherwise, return nil."
(locals-file (locate-dominating-file file dir-locals-file-name))
(dir-elt nil))
;; `locate-dominating-file' may have abbreviated the name.
- (when locals-file
- (setq locals-file (expand-file-name dir-locals-file-name locals-file)))
+ (if locals-file
+ (setq locals-file (expand-file-name dir-locals-file-name locals-file)))
;; Find the best cached value in `dir-locals-directory-cache'.
(dolist (elt dir-locals-directory-cache)
(when (and (eq t (compare-strings file nil (length (car elt))
@@ -3385,23 +3539,32 @@ Otherwise, return nil."
'(windows-nt cygwin ms-dos))))
(> (length (car elt)) (length (car dir-elt))))
(setq dir-elt elt)))
- (let ((use-cache (and dir-elt
- (or (null locals-file)
- (<= (length (file-name-directory locals-file))
- (length (car dir-elt)))))))
- (if use-cache
- ;; Check the validity of the cache.
- (if (and (file-readable-p (car dir-elt))
- (or (null (nth 2 dir-elt))
+ (if (and dir-elt
+ (or (null locals-file)
+ (<= (length (file-name-directory locals-file))
+ (length (car dir-elt)))))
+ ;; Found a potential cache entry. Check validity.
+ ;; A cache entry with no MTIME is assumed to always be valid
+ ;; (ie, set directly, not from a dir-locals file).
+ ;; Note, we don't bother to check that there is a matching class
+ ;; element in dir-locals-class-alist, since that's done by
+ ;; dir-locals-set-directory-class.
+ (if (or (null (nth 2 dir-elt))
+ (let ((cached-file (expand-file-name dir-locals-file-name
+ (car dir-elt))))
+ (and (file-readable-p cached-file)
(equal (nth 2 dir-elt)
- (nth 5 (file-attributes (car dir-elt))))))
- ;; This cache entry is OK.
- dir-elt
- ;; This cache entry is invalid; clear it.
- (setq dir-locals-directory-cache
- (delq dir-elt dir-locals-directory-cache))
- locals-file)
- locals-file))))
+ (nth 5 (file-attributes cached-file))))))
+ ;; This cache entry is OK.
+ dir-elt
+ ;; This cache entry is invalid; clear it.
+ (setq dir-locals-directory-cache
+ (delq dir-elt dir-locals-directory-cache))
+ ;; Return the first existing dir-locals file. Might be the same
+ ;; as dir-elt's, might not (eg latter might have been deleted).
+ locals-file)
+ ;; No cache entry.
+ locals-file)))
(defun dir-locals-read-from-file (file)
"Load a variables FILE and register a new class and instance.
@@ -3424,16 +3587,15 @@ 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 class (dir-locals-read-from-file variables-file)))
+ (setq dir-name (file-name-directory variables-file)
+ class (dir-locals-read-from-file variables-file)))
((consp variables-file)
(setq dir-name (nth 0 variables-file))
(setq class (nth 1 variables-file))))
@@ -3449,6 +3611,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.
@@ -3495,7 +3661,7 @@ the old visited file has been renamed to the new name FILENAME."
(and buffer (not (eq buffer (current-buffer)))
(not no-query)
(not (y-or-n-p (format "A buffer is visiting %s; proceed? "
- filename)))
+ filename)))
(error "Aborted")))
(or (equal filename buffer-file-name)
(progn
@@ -3628,10 +3794,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)
@@ -3659,7 +3828,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
@@ -3679,10 +3849,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
;; .emacs.d/%backup%.
@@ -3690,7 +3860,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
@@ -3702,7 +3872,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
@@ -3729,23 +3899,31 @@ 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)))
+
+(defvar file-name-version-regexp
+ "\\(?:~\\|\\.~[-[:alnum:]:#@^._]+\\(?:~[[:digit:]]+\\)?~\\)"
+ ;; The last ~[[:digit]]+ matches relative versions in git,
+ ;; e.g. `foo.js.~HEAD~1~'.
+ "Regular expression matching the backup/version part of a file name.
+Used by `file-name-sans-versions'.")
(defun file-name-sans-versions (name &optional keep-backup-version)
"Return file NAME sans backup versions or strings.
This is a separate procedure so your site-init or startup file can
redefine it.
If the optional argument KEEP-BACKUP-VERSION is non-nil,
-we do not remove backup version numbers, only true file version numbers."
+we do not remove backup version numbers, only true file version numbers.
+See also `file-name-version-regexp'."
(let ((handler (find-file-name-handler name 'file-name-sans-versions)))
(if handler
(funcall handler 'file-name-sans-versions name keep-backup-version)
(substring name 0
- (if keep-backup-version
- (length name)
- (or (string-match "\\.~[-[:alnum:]:#@^._]+~\\'" name)
- (string-match "~\\'" name)
- (length name)))))))
+ (unless keep-backup-version
+ (string-match (concat file-name-version-regexp "\\'")
+ name))))))
(defun file-ownership-preserved-p (file)
"Return t if deleting FILE and rewriting it would preserve the owner."
@@ -4217,7 +4395,11 @@ Before and after saving the buffer, this function runs
;; In an indirect buffer, save its base buffer instead.
(if (buffer-base-buffer)
(set-buffer (buffer-base-buffer)))
- (if (buffer-modified-p)
+ (if (or (buffer-modified-p)
+ ;; handle the case when no modification has been made but
+ ;; the file disappeared since visited
+ (and buffer-file-name
+ (not (file-exists-p buffer-file-name))))
(let ((recent-save (recent-auto-save-p))
setmodes)
;; If buffer has no file name, ask user for one.
@@ -4244,8 +4426,9 @@ Before and after saving the buffer, this function runs
(or (verify-visited-file-modtime (current-buffer))
(not (file-exists-p buffer-file-name))
(yes-or-no-p
- (format "%s has changed since visited or saved. Save anyway? "
- (file-name-nondirectory buffer-file-name)))
+ (format
+ "%s has changed since visited or saved. Save anyway? "
+ (file-name-nondirectory buffer-file-name)))
(error "Save not confirmed"))
(save-restriction
(widen)
@@ -4283,7 +4466,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.
@@ -4296,7 +4481,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
@@ -4308,7 +4493,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))
@@ -4320,9 +4505,10 @@ Before and after saving the buffer, this function runs
(if (not (file-exists-p buffer-file-name))
(error "Directory %s write-protected" dir)
(if (yes-or-no-p
- (format "File %s is write-protected; try to save anyway? "
- (file-name-nondirectory
- buffer-file-name)))
+ (format
+ "File %s is write-protected; try to save anyway? "
+ (file-name-nondirectory
+ buffer-file-name)))
(setq tempsetmodes t)
(error "Attempt to save to a file which you aren't allowed to write"))))))
(or buffer-backed-up
@@ -4379,8 +4565,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.
@@ -4391,8 +4578,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
@@ -4406,32 +4596,12 @@ 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)
+(declare-function diff-no-select "diff"
+ (old new &optional switches no-async buf))
(defvar save-some-buffers-action-alist
`((?\C-r
@@ -4447,13 +4617,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")))
@@ -4470,6 +4641,9 @@ You can answer `y' to save, `n' not to save, `C-r' to look at the
buffer in question with `view-buffer' before deciding or `d' to
view the differences using `diff-buffer-with-file'.
+This command first saves any buffers where `buffer-save-without-query' is
+non-nil, without asking.
+
Optional argument (the prefix) non-nil means save all with no questions.
Optional second argument PRED determines which buffers are considered:
If PRED is nil, all the file-visiting buffers are considered.
@@ -4481,14 +4655,14 @@ See `save-some-buffers-action-alist' if you want to
change the additional actions you can take on files."
(interactive "P")
(save-window-excursion
- (let* (queried some-automatic
+ (let* (queried autosaved-buffers
files-done abbrevs-done)
(dolist (buffer (buffer-list))
;; First save any buffers that we're supposed to save unconditionally.
;; That way the following code won't ask about them.
(with-current-buffer buffer
(when (and buffer-save-without-query (buffer-modified-p))
- (setq some-automatic t)
+ (push (buffer-name) autosaved-buffers)
(save-buffer))))
;; Ask about those buffers that merit it,
;; and record the number thus saved.
@@ -4528,16 +4702,21 @@ change the additional actions you can take on files."
(progn
(if (or arg
(eq save-abbrevs 'silently)
- (y-or-n-p (format "Save abbrevs in %s? "
- abbrev-file-name)))
+ (y-or-n-p (format "Save abbrevs in %s? " abbrev-file-name)))
(write-abbrev-file nil))
;; Don't keep bothering user if he says no.
(setq abbrevs-changed nil)
(setq abbrevs-done t)))
(or queried (> files-done 0) abbrevs-done
- (message (if some-automatic
- "(Some special files were saved without asking)"
- "(No files need saving)"))))))
+ (cond
+ ((null autosaved-buffers)
+ (message "(No files need saving)"))
+ ((= (length autosaved-buffers) 1)
+ (message "(Saved %s)" (car autosaved-buffers)))
+ (t
+ (message "(Saved %d files: %s)"
+ (length autosaved-buffers)
+ (mapconcat 'identity autosaved-buffers ", "))))))))
(defun not-modified (&optional arg)
"Mark current buffer as unmodified, not needing to be saved.
@@ -4643,16 +4822,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)
@@ -4683,19 +4863,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-directory-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)))
@@ -4703,7 +4894,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.
@@ -4723,14 +4914,14 @@ 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)))
(delete-directory-internal directory)))))
-(defun copy-directory (directory newname &optional keep-time parents)
+(defun copy-directory (directory newname &optional keep-time parents copy-contents)
"Copy DIRECTORY to NEWNAME. Both args must be strings.
This function always sets the file modes of the output files to match
the corresponding input file.
@@ -4742,15 +4933,20 @@ A prefix arg makes KEEP-TIME non-nil.
Noninteractively, the last argument PARENTS says whether to
create parent directories if they don't exist. Interactively,
-this happens by default."
+this happens by default.
+
+If NEWNAME names an existing directory, copy DIRECTORY as a
+subdirectory there. However, if called from Lisp with a non-nil
+optional argument COPY-CONTENTS, copy the contents of DIRECTORY
+directly into NEWNAME instead."
(interactive
(let ((dir (read-directory-name
"Copy directory: " default-directory default-directory t nil)))
(list dir
- (read-file-name
+ (read-directory-name
(format "Copy directory %s to: " dir)
default-directory default-directory nil nil)
- current-prefix-arg t)))
+ current-prefix-arg t nil)))
;; If default-directory is a remote directory, make sure we find its
;; copy-directory handler.
(let ((handler (or (find-file-name-handler directory 'copy-directory)
@@ -4761,22 +4957,36 @@ this happens by default."
;; Compute target name.
(setq directory (directory-file-name (expand-file-name directory))
newname (directory-file-name (expand-file-name newname)))
- (if (not (file-directory-p newname)) (make-directory newname parents))
+
+ (cond ((not (file-directory-p newname))
+ ;; If NEWNAME is not an existing directory, create it;
+ ;; that is where we will copy the files of DIRECTORY.
+ (make-directory newname parents))
+ ;; If NEWNAME is an existing directory and COPY-CONTENTS
+ ;; is nil, copy into NEWNAME/[DIRECTORY-BASENAME].
+ ((not copy-contents)
+ (setq newname (expand-file-name
+ (file-name-nondirectory
+ (directory-file-name directory))
+ newname))
+ (and (file-exists-p newname)
+ (not (file-directory-p newname))
+ (error "Cannot overwrite non-directory %s with a directory"
+ newname))
+ (make-directory newname t)))
;; Copy recursively.
- (mapc
- (lambda (file)
- (let ((target (expand-file-name
- (file-name-nondirectory file) newname))
- (attrs (file-attributes file)))
- (cond ((file-directory-p file)
- (copy-directory file target keep-time parents))
- ((stringp (car attrs)) ; Symbolic link
- (make-symbolic-link (car attrs) target t))
- (t
- (copy-file file target t keep-time)))))
- ;; We do not want to copy "." and "..".
- (directory-files directory 'full directory-files-no-dot-files-regexp))
+ (dolist (file
+ ;; We do not want to copy "." and "..".
+ (directory-files directory 'full
+ directory-files-no-dot-files-regexp))
+ (if (file-directory-p file)
+ (copy-directory file newname keep-time parents)
+ (let ((target (expand-file-name (file-name-nondirectory file) newname))
+ (attrs (file-attributes file)))
+ (if (stringp (car attrs)) ; Symbolic link
+ (make-symbolic-link (car attrs) target t)
+ (copy-file file target t keep-time)))))
;; Set directory attributes.
(set-file-modes newname (file-modes directory))
@@ -4828,6 +5038,10 @@ hook functions.
If `revert-buffer-function' is used to override the normal revert
mechanism, this hook is not used.")
+(defvar revert-buffer-in-progress-p nil
+ "Non-nil if a `revert-buffer' operation is in progress, nil otherwise.
+This is true even if a `revert-buffer-function' is being used.")
+
(defvar revert-buffer-internal-hook)
(defun revert-buffer (&optional ignore-auto noconfirm preserve-modes)
@@ -4850,7 +5064,7 @@ sake of backward compatibility. IGNORE-AUTO is optional, defaulting
to nil.
Optional second argument NOCONFIRM means don't ask for confirmation
-at all. \(The variable `revert-without-query' offers another way to
+at all. (The variable `revert-without-query' offers another way to
revert buffers without querying for confirmation.)
Optional third argument PRESERVE-MODES non-nil means don't alter
@@ -4870,10 +5084,12 @@ non-nil, it is called instead of rereading visited file contents."
;; interface, but leaving the programmatic interface the same.
(interactive (list (not current-prefix-arg)))
(if revert-buffer-function
- (funcall revert-buffer-function ignore-auto noconfirm)
+ (let ((revert-buffer-in-progress-p t))
+ (funcall revert-buffer-function ignore-auto noconfirm))
(with-current-buffer (or (buffer-base-buffer (current-buffer))
(current-buffer))
- (let* ((auto-save-p (and (not ignore-auto)
+ (let* ((revert-buffer-in-progress-p t)
+ (auto-save-p (and (not ignore-auto)
(recent-auto-save-p)
buffer-auto-save-file-name
(file-readable-p buffer-auto-save-file-name)
@@ -4964,7 +5180,7 @@ non-nil, it is called instead of rereading visited file contents."
;; have changed the truename.
(setq buffer-file-truename
(abbreviate-file-name (file-truename buffer-file-name)))
- (after-find-file nil nil t t preserve-modes)
+ (after-find-file nil nil t nil preserve-modes)
;; Run after-revert-hook as it was before we reverted.
(setq-default revert-buffer-internal-hook global-hook)
(if local-hook
@@ -5131,10 +5347,10 @@ This command is used in the special Dired buffer created by
(defun kill-buffer-ask (buffer)
"Kill BUFFER if confirmed."
- (when (yes-or-no-p
- (format "Buffer %s %s. Kill? " (buffer-name buffer)
- (if (buffer-modified-p buffer)
- "HAS BEEN EDITED" "is unmodified")))
+ (when (yes-or-no-p (format "Buffer %s %s. Kill? "
+ (buffer-name buffer)
+ (if (buffer-modified-p buffer)
+ "HAS BEEN EDITED" "is unmodified")))
(kill-buffer buffer)))
(defun kill-some-buffers (&optional list)
@@ -5166,30 +5382,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."
@@ -5456,7 +5648,7 @@ Prefix arg (second arg if noninteractive) means supply -l switch to `ls'.
Actions controlled by variables `list-directory-brief-switches'
and `list-directory-verbose-switches'."
(interactive (let ((pfx current-prefix-arg))
- (list (read-file-name (if pfx "List directory (verbose): "
+ (list (read-directory-name (if pfx "List directory (verbose): "
"List directory (brief): ")
nil default-directory nil)
pfx)))
@@ -5553,12 +5745,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.
@@ -5578,19 +5772,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
@@ -5715,6 +5907,9 @@ normally equivalent short `-D' option is just passed on to
(file-name-directory file)
(file-name-directory (expand-file-name file))))
(pattern (file-name-nondirectory file)))
+ ;; NB since switches is passed to the shell, be
+ ;; careful of malicious values, eg "-l;reboot".
+ ;; See eg dired-safe-switches-p.
(call-process
shell-file-name nil t nil
"-c"
@@ -5987,8 +6182,8 @@ With prefix ARG, silently save all file-visiting buffers, then kill."
(setq active t))
(setq processes (cdr processes)))
(or (not active)
- (list-processes t)
- (yes-or-no-p "Active processes exist; kill them and exit anyway? "))))
+ (progn (list-processes t)
+ (yes-or-no-p "Active processes exist; kill them and exit anyway? ")))))
;; Query the user for other things, perhaps.
(run-hook-with-args-until-failure 'kill-emacs-query-functions)
(or (null confirm-kill-emacs)
@@ -6379,5 +6574,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 a8579ad4a54..269ee331fb2 100644
--- a/lisp/filesets.el
+++ b/lisp/filesets.el
@@ -1,7 +1,6 @@
;;; filesets.el --- handle group of files
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Thomas Link <sanobast-emacs@yahoo.de>
;; Maintainer: FSF
@@ -348,7 +347,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)
@@ -2534,5 +2533,4 @@ Set up hooks, load the cache file -- if existing -- and build the menu."
;; sentence-end-double-space:t
;; End:
-;; arch-tag: 2c03f85f-c3df-4cec-b0a3-b46fd5592d70
;;; filesets.el ends here
diff --git a/lisp/find-cmd.el b/lisp/find-cmd.el
index b7dc11c1211..8b0c1eb522a 100644
--- a/lisp/find-cmd.el
+++ b/lisp/find-cmd.el
@@ -1,6 +1,6 @@
;;; find-cmd.el --- Build a valid find(1) command with sexps
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Philip Jackson <phil@shellarchive.co.uk>
;; Version: 0.6
@@ -240,5 +240,4 @@ them into valid switches. The result is -and(ed) together."
(provide 'find-cmd)
-;; arch-tag: 9687fd9e-4e90-4022-864a-f904526e2046
;;; find-cmd.el ends here
diff --git a/lisp/find-dired.el b/lisp/find-dired.el
index 53522945d8a..a2b196dc029 100644
--- a/lisp/find-dired.el
+++ b/lisp/find-dired.el
@@ -1,7 +1,6 @@
;;; find-dired.el --- run a `find' command and dired the output
-;; Copyright (C) 1992, 1994, 1995, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 1994-1995, 2000-2011 Free Software Foundation, Inc.
;; Author: Roland McGrath <roland@gnu.org>,
;; Sebastian Kremer <sk@thp.uni-koeln.de>
@@ -34,36 +33,62 @@
:group 'dired
:prefix "find-")
+;; FIXME this option does not really belong in this file, it's more general.
+;; Eg cf some tests in grep.el.
+(defcustom find-exec-terminator
+ (if (eq 0
+ (ignore-errors
+ (process-file find-program nil nil nil
+ null-device "-exec" "echo" "{}" "+")))
+ "+"
+ (shell-quote-argument ";"))
+ "String that terminates \"find -exec COMMAND {} \".
+The value should include any needed quoting for the shell.
+Common values are \"+\" and \"\\\\;\", with the former more efficient
+than the latter."
+ :version "24.1"
+ :group 'find-dired
+ :type 'string)
+
;; find's -ls corresponds to these switches.
;; Note -b, at least GNU find quotes spaces etc. in filenames
-;;;###autoload
(defcustom find-ls-option
- (if (eq system-type 'berkeley-unix) (purecopy '("-ls" . "-gilsb"))
- (purecopy '("-exec ls -ld {} \\;" . "-ld")))
+ (if (eq 0
+ (ignore-errors
+ (process-file find-program nil nil nil null-device "-ls")))
+ (cons "-ls"
+ (if (eq system-type 'berkeley-unix)
+ "-gilsb"
+ "-dilsb"))
+ (cons
+ (format "-exec ls -ld {} %s" find-exec-terminator)
+ "-ld"))
"Description of the option to `find' to produce an `ls -l'-type listing.
This is a cons of two strings (FIND-OPTION . LS-SWITCHES). FIND-OPTION
gives the option (or options) to `find' that produce the desired output.
LS-SWITCHES is a list of `ls' switches to tell dired how to parse the output."
+ :version "24.1" ; add tests for -ls and -exec + support
:type '(cons (string :tag "Find Option")
(string :tag "Ls Switches"))
:group 'find-dired)
-;;;###autoload
-(defcustom find-ls-subdir-switches (purecopy "-al")
+(defcustom find-ls-subdir-switches
+ (if (string-match "-[a-z]*b" (cdr find-ls-option))
+ "-alb"
+ "-al")
"`ls' switches for inserting subdirectories in `*Find*' buffers.
This should contain the \"-l\" switch.
Use the \"-F\" or \"-b\" switches if and only if you also use
them for `find-ls-option'."
+ :version "24.1" ; add -b test
:type 'string
- :group 'find-dired
- :version "22.1")
+ :group 'find-dired)
-;;;###autoload
(defcustom find-grep-options
- (purecopy (if (or (eq system-type 'berkeley-unix)
+ (if (or (eq system-type 'berkeley-unix)
(string-match "solaris2" system-configuration)
(string-match "irix" system-configuration))
- "-s" "-q"))
+ "-s" "-q")
"Option to grep to be as silent as possible.
On Berkeley systems, this is `-s'; on Posix, and with GNU grep, `-q' does it.
On other systems, the closest you can come is to use `-l'."
@@ -72,9 +97,9 @@ On other systems, the closest you can come is to use `-l'."
;; This used to be autoloaded (see bug#4387).
(defcustom find-name-arg
- (purecopy (if read-file-name-completion-ignore-case
+ (if read-file-name-completion-ignore-case
"-iname"
- "-name"))
+ "-name")
"Argument used to specify file name pattern.
If `read-file-name-completion-ignore-case' is non-nil, -iname is used so that
find also ignores case. Otherwise, -name is used."
@@ -93,13 +118,13 @@ find also ignores case. Otherwise, -name is used."
;;;###autoload
(defun find-dired (dir args)
"Run `find' and go into Dired mode on a buffer of the output.
-The command run (after changing into DIR) is
+The command run (after changing into DIR) is essentially
find . \\( ARGS \\) -ls
-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)
+except that the car of the variable `find-ls-option' specifies what to
+use in place of \"-ls\" as the final argument."
+ (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))
@@ -139,11 +164,12 @@ as the final argument."
" " args " "
(shell-quote-argument ")")
" "))
- (if (equal (car find-ls-option) "-exec ls -ld {} \\;")
- (concat "-exec ls -ld "
+ (if (string-match "\\`\\(.*\\) {} \\(\\\\;\\|+\\)\\'"
+ (car find-ls-option))
+ (format "%s %s %s"
+ (match-string 1 (car find-ls-option))
(shell-quote-argument "{}")
- " "
- (shell-quote-argument ";"))
+ find-exec-terminator)
(car find-ls-option))))
;; Start the find process.
(shell-command (concat args "&") (current-buffer))
@@ -217,9 +243,14 @@ The command run (after changing into DIR) is
"Find files in DIR containing a regexp REGEXP and start Dired on output.
The command run (after changing into DIR) is
- find . -exec grep -s -e REGEXP {} \\\; -ls
+ find . \\( -type f -exec `grep-program' `find-grep-options' \\
+ -e REGEXP {} \\; \\) -ls
-Thus ARG can also contain additional grep options."
+where the car of the variable `find-ls-option' specifies what to
+use in place of \"-ls\" as the final argument."
+ ;; Doc used to say "Thus ARG can also contain additional grep options."
+ ;; i) Presumably ARG == REGEXP?
+ ;; ii) No it can't have options, since it gets shell-quoted.
(interactive "DFind-grep (directory): \nsFind-grep (grep regexp): ")
;; find -exec doesn't allow shell i/o redirections in the command,
;; or we could use `grep -l >/dev/null'
@@ -232,6 +263,7 @@ Thus ARG can also contain additional grep options."
" "
(shell-quote-argument "{}")
" "
+ ;; Doesn't work with "+".
(shell-quote-argument ";"))))
(defun find-dired-filter (proc string)
@@ -312,5 +344,4 @@ Thus ARG can also contain additional grep options."
(provide 'find-dired)
-;; arch-tag: 8edece95-af00-4221-bc74-a4bd2f75f9b0
;;; find-dired.el ends here
diff --git a/lisp/find-file.el b/lisp/find-file.el
index 244a9470d51..e4285523184 100644
--- a/lisp/find-file.el
+++ b/lisp/find-file.el
@@ -4,8 +4,7 @@
;; Maintainer: FSF
;; Keywords: c, matching, tools
-;; Copyright (C) 1994, 1995, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1995, 2001-2011 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
@@ -184,7 +183,7 @@ To override this, give an argument to `ff-find-other-file'."
;;;###autoload
(defvar ff-special-constructs
`(
- ;; C/C++ include, for NeXTSTEP too
+ ;; C/C++ include, for NeXTstep too
(,(purecopy "^\#\\s *\\(include\\|import\\)\\s +[<\"]\\(.*\\)[>\"]") .
(lambda ()
(buffer-substring (match-beginning 2) (match-end 2))))
@@ -495,7 +494,7 @@ If optional IN-OTHER-WINDOW is non-nil, find the file in another window."
(setq name
(expand-file-name
- (read-file-name
+ (read-directory-name
(format "Find or create %s in: " default-name)
default-directory default-name nil)))
@@ -968,5 +967,4 @@ That name was previously determined by `ff-which-function-are-we-in'."
(provide 'find-file)
-;; arch-tag: 5a2fc49e-3b0a-4708-9acf-fb14e471a97a
;;; find-file.el ends here
diff --git a/lisp/find-lisp.el b/lisp/find-lisp.el
index 9c76e8ed268..b89762dc1a8 100644
--- a/lisp/find-lisp.el
+++ b/lisp/find-lisp.el
@@ -4,8 +4,7 @@
;; Created: Fri Mar 26 1999
;; Keywords: unix
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
@@ -193,7 +192,6 @@ It is a function which takes two arguments, the directory and its parent."
directory-predicate buffer-name)
"Run find (Lisp version) and go into Dired mode on a buffer of the output."
(let ((dired-buffers dired-buffers)
- buf
(regexp find-lisp-regexp))
;; Expand DIR ("" means default-directory), and make sure it has a
;; trailing slash.
@@ -204,7 +202,7 @@ It is a function which takes two arguments, the directory and its parent."
(or
(and (buffer-name)
(string= buffer-name (buffer-name)))
- (switch-to-buffer (setq buf (get-buffer-create buffer-name))))
+ (switch-to-buffer (get-buffer-create buffer-name)))
(widen)
(kill-all-local-variables)
(setq buffer-read-only nil)
@@ -224,7 +222,7 @@ It is a function which takes two arguments, the directory and its parent."
(make-local-variable 'revert-buffer-function)
(setq revert-buffer-function
(function
- (lambda(ignore1 ignore2)
+ (lambda (_ignore1 _ignore2)
(find-lisp-insert-directory
default-directory
find-lisp-file-predicate
@@ -247,10 +245,10 @@ It is a function which takes two arguments, the directory and its parent."
(goto-char (point-min))
(dired-goto-next-file)))
-(defun find-lisp-insert-directory (dir
- file-predicate
- directory-predicate
- sort-function)
+(defun find-lisp-insert-directory (dir
+ file-predicate
+ directory-predicate
+ _sort-function)
"Insert the results of `find-lisp-find-files' in the current buffer."
(let ((buffer-read-only nil)
(files (find-lisp-find-files-internal
@@ -270,7 +268,7 @@ It is a function which takes two arguments, the directory and its parent."
;; Run the find function
(mapc
(function
- (lambda(file)
+ (lambda (file)
(find-lisp-find-dired-insert-file
(substring file len)
(current-buffer))))
@@ -356,5 +354,4 @@ It is a function which takes two arguments, the directory and its parent."
(provide 'find-lisp)
-;; arch-tag: a711374c-f12a-46f6-aa18-ba7d77b9602a
;;; find-lisp.el ends here
diff --git a/lisp/finder.el b/lisp/finder.el
index 5ec9928d986..ae2afba5bbb 100644
--- a/lisp/finder.el
+++ b/lisp/finder.el
@@ -1,7 +1,6 @@
;;; finder.el --- topic & keyword-based code finder
-;; Copyright (C) 1992, 1997, 1998, 1999, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 1997-1999, 2001-2011 Free Software Foundation, Inc.
;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
;; Created: 16 Jun 1992
@@ -27,64 +26,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 +119,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 +137,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 +230,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 +277,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 +296,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-show-package-list packages)))
(define-button-type 'finder-xref 'action #'finder-goto-xref)
@@ -364,8 +403,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,11 +421,10 @@ 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)
-;; arch-tag: ec85ff49-8cb8-41f5-a63f-9131d53ce2c5
;;; finder.el ends here
diff --git a/lisp/flow-ctrl.el b/lisp/flow-ctrl.el
index d8e6154c52f..a025f0a184c 100644
--- a/lisp/flow-ctrl.el
+++ b/lisp/flow-ctrl.el
@@ -1,7 +1,6 @@
;;; flow-ctrl.el --- help for lusers on cu(1) or ttys with wired-in ^S/^Q flow control
-;; Copyright (C) 1990, 1991, 1994, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1991, 1994, 2001-2011 Free Software Foundation, Inc.
;; Author: Kevin Gallagher
;; Maintainer: FSF
@@ -122,5 +121,4 @@ to get the effect of a C-q."
(provide 'flow-ctrl)
-;; arch-tag: 0eb7b19e-0d93-4e0b-9ea2-72b574076a56
;;; flow-ctrl.el ends here
diff --git a/lisp/foldout.el b/lisp/foldout.el
index 8c9293682ad..b0eaf753d60 100644
--- a/lisp/foldout.el
+++ b/lisp/foldout.el
@@ -1,12 +1,11 @@
;;; foldout.el --- folding extensions for outline-mode and outline-minor-mode
-;; Copyright (C) 1994, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 2001-2011 Free Software Foundation, Inc.
;; 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.
@@ -565,5 +564,4 @@ Valid modifiers are shift, control, meta, alt, hyper and super.")
(provide 'foldout)
-;; arch-tag: 19d095a2-1f09-42a7-a5ac-e2a3078cfe95
;;; foldout.el ends here
diff --git a/lisp/follow.el b/lisp/follow.el
index 57a8f231b1f..9bf472e547c 100644
--- a/lisp/follow.el
+++ b/lisp/follow.el
@@ -1,7 +1,6 @@
;;; follow.el --- synchronize windows showing the same buffer
-;; Copyright (C) 1995, 1996, 1997, 1999, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-1997, 1999, 2001-2011 Free Software Foundation, Inc.
;; Author: Anders Lindgren <andersl@andersl.com>
;; Maintainer: FSF (Anders' email bounces, Sep 2005)
@@ -872,8 +871,7 @@ Returns (end-pos end-of-buffer-p)"
;; XEmacs can calculate the end of the window by using
;; the 'guarantee options. GOOD!
(let ((end (window-end win t)))
- (if (= end (funcall (symbol-function 'point-max)
- (window-buffer win)))
+ (if (= end (point-max (window-buffer win)))
(list end t)
(list (+ end 1) nil)))
;; Emacs: We have to calculate the end by ourselves.
@@ -1063,7 +1061,7 @@ Return the selected window."
;; it wasn't just moved here. (i.e. M-> shall not unconditionally place
;; the point in the selected window.)
;;
-;; (Compability cludge: in Emacs `window-end' is equal to `point-max';
+;; (Compatibility cludge: in Emacs `window-end' is equal to `point-max';
;; in XEmacs, it is equal to `point-max + 1'. Should I really bother
;; checking `window-end' now when I check `end-of-buffer' explicitly?)
@@ -1262,7 +1260,7 @@ should be a member of WINDOWS, starts at position START."
;; especially if it is placed in the debug filter section. I must
;; investigate this further...
-(defun follow-avoid-tail-recenter (&rest rest)
+(defun follow-avoid-tail-recenter (&rest _rest)
"Make sure windows displaying the end of a buffer aren't recentered.
This is done by reading and rewriting the start position of
@@ -2122,5 +2120,4 @@ This prevents `mouse-drag-region' from messing things up."
;; | save it". -- Douglas Adams, "Last Chance to See" |
;; \------------------------------------------------------------------------/
-;; arch-tag: 7b16bb1a-808c-4991-a8cc-66d3822936d0
;;; follow.el ends here
diff --git a/lisp/font-core.el b/lisp/font-core.el
index b6bc60ddd55..fcaaf33b718 100644
--- a/lisp/font-core.el
+++ b/lisp/font-core.el
@@ -1,11 +1,10 @@
;;; font-core.el --- Core interface to font-lock
-;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1992-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: languages, faces
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -80,17 +79,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 +131,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 +193,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 +294,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 5cc7bc51fc5..32fbb0608a2 100644
--- a/lisp/font-lock.el
+++ b/lisp/font-lock.el
@@ -1,14 +1,13 @@
;;; 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, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1992-2011 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 +100,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 +207,7 @@
;;; Code:
(require 'syntax)
+(eval-when-compile (require 'cl))
;; Define core `font-lock' group.
(defgroup font-lock '((jit-lock custom-group))
@@ -275,13 +274,14 @@ decoration for buffers in C++ mode, and level 1 decoration otherwise."
(integer :tag "level" 1)))))
:group 'font-lock)
-(defcustom font-lock-verbose 0
+(defcustom font-lock-verbose nil
"If non-nil, means show status messages for buffer fontification.
If a number, only buffers greater than this size have fontification messages."
:type '(choice (const :tag "never" nil)
(other :tag "always" t)
(integer :tag "size"))
- :group 'font-lock)
+ :group 'font-lock
+ :version "24.1")
;; Originally these variable values were face names such as `bold' etc.
@@ -542,6 +542,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 +614,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 +894,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 +1021,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 +1114,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 +1441,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 +1487,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 +1756,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
@@ -1781,8 +1765,7 @@ variables directly.
Note: This function will erase modifications done by
`font-lock-add-keywords' or `font-lock-remove-keywords', but will
preserve `hi-lock-mode' highlighting patterns."
- (let ((hi-lock--inhibit-font-lock-hook t))
- (font-lock-mode -1))
+ (font-lock-mode -1)
(kill-local-variable 'font-lock-set-defaults)
(font-lock-mode 1))
@@ -1792,8 +1775,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 +1784,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 +2075,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))
@@ -2262,7 +2241,7 @@ in which C preprocessor directives are used. e.g. `asm-mode' and
"\\)\\)\\>"
;; Any whitespace and defined object.
"[ \t'\(]*"
- "\\(setf[ \t]+\\sw+)\\|\\sw+\\)?")
+ "\\(setf[ \t]+\\sw+\\|\\sw+\\)?")
(1 font-lock-keyword-face)
(9 (cond ((match-beginning 3) font-lock-function-name-face)
((match-beginning 6) font-lock-variable-name-face)
@@ -2286,14 +2265,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 +2345,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 6611c3fc481..68d57b73db1 100644
--- a/lisp/format-spec.el
+++ b/lisp/format-spec.el
@@ -1,7 +1,6 @@
;;; format-spec.el --- functions for formatting arbitrary formatting strings
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: tools
@@ -76,5 +75,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 f9b00414c99..61c68870e08 100644
--- a/lisp/format.el
+++ b/lisp/format.el
@@ -1,9 +1,10 @@
;;; format.el --- read and save files in multiple formats
-;; Copyright (C) 1994, 1995, 1997, 1999, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1995, 1997, 1999, 2001-2011
+;; Free Software Foundation, Inc.
;; Author: Boris Goldowsky <boris@gnu.org>
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -89,7 +90,7 @@
,(purecopy "diac") iso-iso2duden t nil)
(de646 ,(purecopy "German ASCII (ISO 646)")
nil
- ,(purecopy "recode -f iso646-ge:latin1")
+ ,(purecopy "recode -f iso646-ge:latin1")
,(purecopy "recode -f latin1:iso646-ge") t nil)
(denet ,(purecopy "net German")
nil
@@ -166,10 +167,10 @@ BUFFER should be the buffer that the output originally came from."
(error "Format encoding failed")))
(funcall method from to buffer)))
-(defun format-decode-run-method (method from to &optional buffer)
+(defun format-decode-run-method (method from to &optional _buffer)
"Decode using METHOD the text from FROM to TO.
If METHOD is a string, it is a shell command (including options); otherwise,
-it should be a Lisp function. Decoding is done for the given BUFFER."
+it should be a Lisp function. BUFFER is currently ignored."
(if (stringp method)
(let ((error-buff (get-buffer-create "*Format Errors*"))
(coding-system-for-write 'no-conversion)
@@ -355,13 +356,11 @@ one of the formats defined in `format-alist', or a list of such symbols."
(if (symbolp format) (setq format (list format)))
(save-excursion
(goto-char end)
- (let ((cur-buf (current-buffer))
- (end (point-marker)))
+ (let ((end (point-marker)))
(while format
(let* ((info (assq (car format) format-alist))
(to-fn (nth 4 info))
- (modify (nth 5 info))
- result)
+ (modify (nth 5 info)))
(if to-fn
(if modify
(setq end (format-encode-run-method to-fn beg end
@@ -538,22 +537,6 @@ Compare using `equal'."
(setq tail next)))
(cons acopy bcopy)))
-(defun format-common-tail (a b)
- "Given two lists that have a common tail, return it.
-Compare with `equal', and return the part of A that is equal to the
-equivalent part of B. If even the last items of the two are not equal,
-return nil."
- (let ((la (length a))
- (lb (length b)))
- ;; Make sure they are the same length
- (if (> la lb)
- (setq a (nthcdr (- la lb) a))
- (setq b (nthcdr (- lb la) b))))
- (while (not (equal a b))
- (setq a (cdr a)
- b (cdr b)))
- a)
-
(defun format-proper-list-p (list)
"Return t if LIST is a proper list.
A proper list is a list ending with a nil cdr, not with an atom "
@@ -640,7 +623,7 @@ to write these unknown annotations back into the file."
(save-restriction
(narrow-to-region (point-min) to)
(goto-char from)
- (let (next open-ans todo loc unknown-ans)
+ (let (next open-ans todo unknown-ans)
(while (setq next (funcall next-fn))
(let* ((loc (nth 0 next))
(end (nth 1 next))
@@ -931,12 +914,11 @@ The same TRANSLATIONS structure can be used in reverse for reading files."
all-ans))
(setq neg-ans (cdr neg-ans)))
;; Now deal with positive (opening) annotations
- (let ((p pos-ans))
- (while pos-ans
- (push (car pos-ans) open-ans)
- (push (cons loc (funcall format-fn (car pos-ans) t))
- all-ans)
- (setq pos-ans (cdr pos-ans))))))
+ (while pos-ans
+ (push (car pos-ans) open-ans)
+ (push (cons loc (funcall format-fn (car pos-ans) t))
+ all-ans)
+ (setq pos-ans (cdr pos-ans)))))
;; Close any annotations still open
(while open-ans
@@ -1015,8 +997,7 @@ They can be whatever the FORMAT-FN in `format-annotate-region'
can handle. If that is `enriched-make-annotation', they can be
either strings, or lists of the form (PARAMETER VALUE)."
- (let ((prop-alist (cdr (assoc prop translations)))
- default)
+ (let ((prop-alist (cdr (assoc prop translations))))
(if (not prop-alist)
nil
;; If either old or new is a list, have to treat both that way.
@@ -1027,7 +1008,6 @@ either strings, or lists of the form (PARAMETER VALUE)."
(format-annotate-atomic-property-change prop-alist old new)
(let* ((old (if (listp old) old (list old)))
(new (if (listp new) new (list new)))
- (tail (format-common-tail old new))
close open)
(while old
(setq close
@@ -1086,5 +1066,4 @@ OLD and NEW are the values."
(provide 'format)
-;; arch-tag: c387e9c7-a93d-47bf-89bc-8ca67e96755a
;;; format.el ends here
diff --git a/lisp/forms-d2.el b/lisp/forms-d2.el
index 00c26d43ecb..12cd5d7d570 100644
--- a/lisp/forms-d2.el
+++ b/lisp/forms-d2.el
@@ -1,7 +1,6 @@
;;; forms-d2.el --- demo forms-mode -*- no-byte-compile: t -*-
-;; Copyright (C) 1991, 1994, 1995, 1996, 1997, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1991, 1994-1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Johan Vromans <jvromans@squirrel.nl>
;; Created: 1989
@@ -101,5 +100,4 @@ used to fill to the column."
;; That's all, folks!
-;; arch-tag: 8e5d5dac-7abf-4722-ab5e-03eb749beaca
;;; forms-d2.el ends here
diff --git a/lisp/forms-pass.el b/lisp/forms-pass.el
index 431dca58786..b635c965cf0 100644
--- a/lisp/forms-pass.el
+++ b/lisp/forms-pass.el
@@ -30,5 +30,4 @@
"Shell: " 7
"\n"))
-;; arch-tag: 74801012-1a2d-4173-b9e4-fcfa241e2305
;;; forms-pass.el ends here
diff --git a/lisp/forms.el b/lisp/forms.el
index 856a1ce4ca1..ef6d9b023b4 100644
--- a/lisp/forms.el
+++ b/lisp/forms.el
@@ -1,7 +1,6 @@
;;; forms.el --- Forms mode: edit a file as a form to fill in
-;; Copyright (C) 1991, 1994, 1995, 1996, 1997, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1991, 1994-1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Johan Vromans <jvromans@squirrel.nl>
@@ -846,7 +845,7 @@ Commands: Equivalent keys in read-only mode:
(defvar forms--iif-properties nil
"Original properties of the character being overridden.")
-(defun forms--iif-hook (begin end)
+(defun forms--iif-hook (_begin _end)
"`insert-in-front-hooks' function for read-only segments."
;; Note start location. By making it a marker that points one
@@ -1198,6 +1197,8 @@ Commands: Equivalent keys in read-only mode:
(setq forms--field nil)))
))
+(defvar read-file-filter) ; bound in forms--intuit-from-file
+
(defun forms--intuit-from-file ()
"Get number of fields and a default form using the data file."
@@ -1407,7 +1408,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
@@ -1918,7 +1921,7 @@ after writing out the data."
(forms-jump-record cur))
t)
-(defun forms--revert-buffer (&optional arg noconfirm)
+(defun forms--revert-buffer (&optional _arg noconfirm)
"Reverts current form to un-modified."
(interactive "P")
(if (or noconfirm
@@ -2053,5 +2056,4 @@ Usage: (setq forms-number-of-fields
(goto-char (point-max))
(insert ret)))))
-;; arch-tag: 4a6695c7-d47a-4a21-809b-5cec7f8ec7a1
;;; forms.el ends here
diff --git a/lisp/frame.el b/lisp/frame.el
index f2d82431f89..a95e91c8eeb 100644
--- a/lisp/frame.el
+++ b/lisp/frame.el
@@ -1,10 +1,11 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1994, 1996-1997, 2000-2011
+;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -24,12 +25,13 @@
;;; Commentary:
;;; Code:
+(eval-when-compile (require 'cl))
(defvar frame-creation-function-alist
(list (cons nil
(if (fboundp 'tty-create-frame-with-faces)
'tty-create-frame-with-faces
- (lambda (parameters)
+ (lambda (_parameters)
(error "Can't create multiple frames without a window system")))))
"Alist of window-system dependent functions to call to create a new frame.
The window system startup file should add its frame creation
@@ -38,13 +40,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 +281,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 +295,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 +508,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 +684,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 +706,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 +731,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 +907,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 +1066,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 +1076,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 +1086,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 +1094,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 +1105,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 +1211,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)))
@@ -1465,25 +1430,8 @@ Examples (measures in pixels) -
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))))
+ (cons (car spec) (frame-geom-value-cons (car spec) (cdr spec) frame)))
-;;;; 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 +1457,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 +1466,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 +1474,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 +1560,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 +1571,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 6b433cc20ae..ce24bb60100 100644
--- a/lisp/fringe.el
+++ b/lisp/fringe.el
@@ -1,11 +1,11 @@
;;; fringe.el --- fringe setup and control -*- coding: utf-8 -*-
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Simon Josefsson <simon@josefsson.org>
;; Maintainer: FSF
;; Keywords: frames
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -96,7 +96,7 @@
"Non-nil means `set-fringe-mode' should really do something.
This is nil while loading `fringe.el', and t afterward.")
-(defun set-fringe-mode-1 (ignore value)
+(defun set-fringe-mode-1 (_ignore value)
"Call `set-fringe-mode' with VALUE.
See `fringe-mode' for valid values and their effect.
This is usually invoked when setting `fringe-mode' via customize."
@@ -135,6 +135,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 +151,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 +188,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.
@@ -261,5 +268,4 @@ SIDE must be the symbol `left' or `right'."
(provide 'fringe)
-;; arch-tag: 6611ef60-0869-47ed-8b93-587ee7d3ff5d
;;; fringe.el ends here
diff --git a/lisp/generic-x.el b/lisp/generic-x.el
index 5ad25905a74..5205a6811f6 100644
--- a/lisp/generic-x.el
+++ b/lisp/generic-x.el
@@ -1,11 +1,11 @@
;;; generic-x.el --- A collection of generic modes
-;; Copyright (C) 1997, 1998, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-1998, 2001-2011 Free Software Foundation, Inc.
;; 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.
@@ -229,7 +229,8 @@ This hook will be installed if the variable
prototype-generic-mode
resolve-conf-generic-mode
samba-generic-mode
- x-resource-generic-mode)
+ x-resource-generic-mode
+ xmodmap-generic-mode)
"List of generic modes that are defined by default on Unix.")
(defconst generic-other-modes
@@ -370,6 +371,15 @@ your changes into effect."
nil
"Generic mode for X Resource configuration files."))
+(if (memq 'xmodmap-generic-mode generic-extras-enable-list)
+(define-generic-mode xmodmap-generic-mode
+ '(?!)
+ '("add" "clear" "keycode" "keysym" "remove" "pointer")
+ nil
+ '("[xX]modmap\\(rc\\)?\\'")
+ nil
+ "Simple mode for xmodmap files."))
+
;;; Hosts
(when (memq 'hosts-generic-mode generic-extras-enable-list)
@@ -533,7 +543,7 @@ like an INI file. You can add this hook to `find-file-hook'."
(interactive)
(let ((compilation-buffer-name-function
(function
- (lambda(ign)
+ (lambda (_ign)
(concat "*" (buffer-file-name) "*")))))
(compile
(concat (w32-shell-name) " -c " (buffer-file-name)))))
@@ -1695,6 +1705,7 @@ like an INI file. You can add this hook to `find-file-hook'."
"efs"
"ext2"
"ext3"
+ "ext4"
"hfs"
"hpfs"
"iso9660"
@@ -1712,6 +1723,7 @@ like an INI file. You can add this hook to `find-file-hook'."
"cifs"
"usbdevfs"
"sysv"
+ "sysfs"
"tmpfs"
"udf"
"ufs"
@@ -1991,5 +2003,4 @@ like an INI file. You can add this hook to `find-file-hook'."
(provide 'generic-x)
-;; arch-tag: cde692a5-9ff6-4506-9999-c67999c2bdb5
;;; generic-x.el ends here
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 1b2ef3e167e..0405bf0eb59 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,35 +1,6646 @@
-2011-02-18 Glenn Morris <rgm@gnu.org>
+2011-05-11 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * registry.el (registry-usage-test): Disable pruning test.
+
+2011-05-10 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * registry.el (registry-prune-hard-candidates)
+ (registry-prune-soft-candidates): Helper methods for registry pruning.
+ (registry-prune): Use them. Make the sort function optional.
+
+2011-05-10 Julien Danjou <julien@danjou.info>
+
+ * shr.el (shr-put-color-1): Do not bug out when old-props is a face
+ symbol and not a list.
+
+2011-05-10 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-art.el (gnus-article-mode): Move binding of
+ shr-put-image-function here from gnus-article-prepare-display.
+
+ * shr.el (shr-put-image-function): New variable.
+ (shr-image-fetched, shr-image-displayer, shr-tag-img): Funcall it.
+ (shr-put-image): Return scaled image.
+
+ * gnus-art.el (gnus-shr-put-image): New function.
+ (gnus-article-prepare-display): Bind shr-put-image-function to it.
+
+ * gnus-html.el (gnus-html-wash-images): Register scaled images, not
+ original ones, as deletable.
+
+2011-05-09 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * nntp.el (nntp-open-connection): Set TCP keepalive option.
+
+2011-05-09 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * registry.el (registry-full): Add convenience method. Fix logic.
+ (registry-insert): Use it. Fix logic here too.
+
+ * gnus-registry.el (gnus-registry-insert): Add wrapper that calls
+ `registry-prune' if `registry-full' returns t.
+ (gnus-registry-handle-action)
+ (gnus-registry-get-or-make-entry, gnus-registry-set-id-key)
+ (gnus-registry-usage-test): Use it.
+
+2011-05-07 Julien Danjou <julien@danjou.info>
+
+ * shr.el (shr-link): Make shr-link inherit from link by default.
+
+2011-05-06 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * shr.el (shr-urlify, shr-link): Fix shr-link face.
+
+2011-05-05 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * shr.el (shr-urlify, shr-link): Still broken but at least doesn't
+ error out because the face is not a list.
+
+2011-05-05 Glenn Morris <rgm@gnu.org>
+
+ * gnus-start.el (gnus-propagate-marks): Declare.
+
+2011-05-04 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * registry.el (registry-reindex): Fix percentage message.
+
+2011-05-03 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * shr.el: Add shr-link face for links.
+ (shr-urlify): Use it.
+
+ * registry.el (registry-insert): Make error message more helpful.
+
+2011-05-02 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-html.el (gnus-html-schedule-image-fetching):
+ Use url-queue-retrieve, if it exists.
+
+ * shr.el (shr-tag-img): Ditto.
+
+ * gnus.el: Autoload more gnus-agent functions.
+
+ * gnus-art.el (gnus-request-article-this-buffer): Store articles in the
+ agent if we haven't already (bug#8502).
+
+ * gnus-async.el (gnus-async-article-callback): Put prefetched articles
+ into the Agent, too.
+
+ * gnus-agent.el (gnus-agent-store-article): New function.
+
+ * nnheader.el (nnheader-insert-buffer-substring): Rename from nntp-
+ and moved from that file for reuse.
+
+ * pop3.el (pop3-open-server): Error messages are "-ERR".
+
+2011-05-01 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * pop3.el (pop3-open-server): Upgrade opportunistically to STARTTLS.
+ (open-tls-stream): Remove superfluous tls/starttls autoloads.
+
+2011-05-01 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * gnus-sum.el (gnus-summary-next-article): Don't bug out if the summary
+ buffer has moved to a different frame.
+
+2011-05-01 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-request-article): Use nntp-insert-buffer-substring
+ to get the conversion from unibyte to multibyte buffers to work on
+ Emacs 22.
+
+ * nntp.el (nntp-request-article): Slight clean-up.
+
+2011-04-29 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-strike-through): New face.
+ (shr-tag-s): Use it to provide <s> support.
+ (shr-tag-s): Remove duplicate definition.
+
+2011-04-25 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * gnus-registry.el (gnus-registry-ignore-group-p): Don't call
+ `gnus-parameter-registry-ignore' if the *Group* buffer doesn't exist.
+
+2011-04-23 Glenn Morris <rgm@gnu.org>
+
+ * gnus-sum.el (gnus-extra-headers): Bump :version.
+
+2011-04-24 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-tag-sup): New function.
+ (shr-tag-sub): Ditto.
+
+2011-04-22 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * gnus-registry.el (gnus-registry-ignore-group-p): Test specifically
+ for the case where `gnus-registry-ignored-groups' is a list of lists,
+ and don't call `gnus-parameter-registry-ignore' otherwise.
+
+2011-04-21 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * nnimap.el (nnimap-user): New backend variable.
+ (nnimap-open-connection-1): Use it.
+ (nnimap-credentials): Accept user parameter so it's explicit what user
+ name is desired.
+
+ * gnus-sum.el (gnus-extra-headers): Add Keywords, Cc, and Gcc to
+ default.
+
+ * gnus.el (gnus-registry-ignored-groups): Provide default in gnus.el,
+ not gnus-registry.el.
+
+ * gnus-registry.el: Mention in comments how to modify
+ `gnus-extra-headers' for proper recipient tracking and that it may
+ already have To and Cc recently, which it does as of this commit.
+ (gnus-registry-ignored-groups): Remove defcustom.
+ Explain why in comments.
+ (gnus-registry-action): Fix data-header reference to use the extra
+ headers. Explain in package commentary how to add To and Cc headers to
+ the gnus-extra-headers.
+ (gnus-registry-ignored-groups): Adjust defaults to match the parameter.
+ (gnus-registry-ignore-group-p): Adjust to take either a group/topic
+ parameter list or a string list in `gnus-registry-ignored-groups'.
+ Fix logic error.
+
+2011-04-21 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-expand-url): Protect against null urls.
+
+2011-04-20 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-base): New binding.
+ (shr-tag-base): Keep track of <base>.
+ (shr-expand-url): New function used throughout.
+
+2011-04-20 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * gnus-registry.el
+ (gnus-registry--split-fancy-with-parent-internal): Fix loop bugs.
+ (gnus-registry-ignored-groups): New variable.
+ (gnus-registry-ignore-group-p): Use it.
+ (gnus-registry-handle-action): Use `gnus-registry-ignore-group-p' and
+ set the destination group to nil (same as delete) if it's ignored.
+
+2011-04-20 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-registry.el (gnus-registry-action)
+ (gnus-registry-fetch-header-fast):
+ Don't use mail-header that looks an internal function of mailheader.el.
+
+2011-04-18 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-registry.el: Eliminate cl functions.
+ (gnus-registry-sort-addresses): New function that replaces mapcan.
+ (gnus-registry-action, gnus-registry-spool-action)
+ (gnus-registry-split-fancy-with-parent)
+ (gnus-registry-fetch-recipients-fast): Use it.
+ (gnus-registry-import-eld): Replace delete* with dolist + delq.
+
+ * registry.el (initialize-instance, registry-lookup)
+ (registry-lookup-breaks-before-lexbind, registry-lookup-secondary)
+ (registry-lookup-secondary-value, registry-search, registry-delete)
+ (registry-insert, registry-reindex, registry-size, registry-prune):
+ Use eval-and-compile.
+
+2011-04-16 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * registry.el (registry-reindex): New method to recreate the secondary
+ registry indices.
+
+ * gnus-registry.el (gnus-registry-fixup-registry): Use it if the
+ tracked field changes.
+ (gnus-registry-unfollowed-addresses, gnus-registry-track-extra)
+ (gnus-registry-action, gnus-registry-spool-action)
+ (gnus-registry-handle-action)
+ (gnus-registry--split-fancy-with-parent-internal)
+ (gnus-registry-split-fancy-with-parent)
+ (gnus-registry-register-message-ids): Add recipient tracking on spool,
+ move, and delete actions, and for fancy splitting with parent.
+ (gnus-registry-extract-addresses)
+ (gnus-registry-fetch-recipients-fast)
+ (gnus-registry-fetch-header-fast): Convenience functions.
+ (gnus-registry-misc-test): ERT test of
+ `gnus-registry-extract-addresses'.
+
+2011-04-15 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * gnus-registry.el (gnus-registry--split-fancy-with-parent-internal):
+ Track by subject first, then sender.
+
+2011-04-15 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * message.el (message-bogus-system-names): Replace ^...$ => \`...\'.
+
+ * gnus.el (gnus-splash-svg-color-symbols): Don't use insert-file from
+ Lisp.
+
+ * gnus-draft.el (gnus-draft-setup): New arg `dont-pop'.
+ (gnus-draft-send): Use it to avoid popping
+ up frames from gnus-group-send-queue.
+
+2011-04-14 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * gnus-registry.el: Updated gnus-registry docs.
+
+2011-04-12 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * gnus-registry.el (gnus-registry--split-fancy-with-parent-internal):
+ Fix logic bug.
+ (gnus-registry-post-process-groups): Fix logging of no results and
+ quote sender and subject.
+
+2011-04-12 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-start.el (gnus-get-unread-articles): Slight cleanup.
+ (gnus-read-active-for-groups): Don't try to finish getting stuff where
+ we had no early-data returned.
+ (gnus-get-unread-articles): Add a sanity check so that we don't issue
+ two async commands to the same server at the same time.
+
+2011-04-12 Stig Sandbeck Mathisen <ssm@fnord.no> (tiny change)
+
+ * gnus-sum.el (gnus-summary-select-article-buffer): Doc fix.
+
+2011-04-12 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-registry.el (gnus-registry-remake-db): Put the warning on a
+ "warning" level.
+
+ * mm-url.el (mm-url-package-name): Remove to ease third-party reuse.
+ (mm-url-insert-file-contents): Don't set the package names.
+
+2011-04-11 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * gnus-registry.el (gnus-registry-action): Remove properties and
+ simplify subject in `gnus-registry-handle-action'.
+ (gnus-registry-spool-action): Get subject and sender from message if
+ they are not passed in.
+ (gnus-registry-handle-action): Remove properties and simplify subject
+ consistently.
+
+2011-04-11 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * registry.el: Require CL before using defmacro*.
+
+2011-04-11 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-art.el (article-treat-date): Assume that
+ gnus-article-date-headers may be a group parameter.
+
+2011-04-07 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * gnus-registry.el (gnus-registry-handle-action): More debugging.
+
+ * gnus-start.el (gnus-gnus-to-newsrc-format): Add a way to run
+ interactively so the newsrc file can contain foreign groups too.
+ Useful for debugging but not much for users.
+
+2011-04-07 David Engster <dengste@eml.cc>
+
+ * registry.el (registry-usage-test): Only do
+ `registry-lookup-breaks-before-lexbind' testing for Emacs24 with
+ lexical binding.
+
+2011-04-06 David Engster <dengste@eml.cc>
+
+ * registry.el, gnus-registry.el: Use `ignore-errors' instead of third
+ argument NOERROR for `require', since XEmacs 21.4 does not support it.
+
+2011-04-06 David Engster <dengste@eml.cc>
+
+ * registry.el (initialize-instance): Change :after to :AFTER to be
+ compatible with old EIEIO version in XEmacs.
+
+2011-04-06 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * gnus-registry.el (gnus-registry-post-process-groups)
+ (gnus-registry--split-fancy-with-parent-internal): Fix splitting bugs
+ and provide better messaging.
+
+2011-04-06 David Engster <dengste@eml.cc>
+
+ * Makefile.in (fail-on-warning): New rule to compile with warnings as
+ errors.
+
+ * dgnushack.el (dgnushack-compile-error-on-warn): New function to call
+ dgnushack-compile with error-on-warn enabled, and to signal an error if
+ clean compilation failed.
+ (dgnushack-compile): New argument 'error-on-warn'. If non-nil, compile
+ with `byte-compile-error-on-warn'. Return nil if errors occured.
+
+2011-04-06 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * gnus-registry.el: Don't use ERT if it's not available. Load it
+ unconditionally anyway, discarding errors.
+ (gnus-registry-delete-entries): New convenience function.
+ (gnus-registry-import-eld): Import from old .eld registry.
+
+ * registry.el: Don't use ERT if it's not available. Load it
+ unconditionally anyway, discarding errors.
+
+ * proto-stream.el (gnutls-negotiate): Revert inadvertent commit of the
+ version from the Claudio Bley GnuTLS patch (extra optional parameters
+ and host name).
+
+2011-04-05 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * gnus-registry.el (gnus-registry-fixup-registry): New function to
+ fixup the parameters that can be customized by the user between
+ save/read cycles.
+ (gnus-registry-read): Use it.
+ (gnus-registry-make-db): Use it.
+ (gnus-registry-spool-action, gnus-registry-handle-action):
+ Fix messaging.
+ (gnus-registry--split-fancy-with-parent-internal): Fix loop.
+ Map references to actual group names with sender and subject tracking.
+ (gnus-registry-post-process-groups): Use `cond' for better messaging.
+ (gnus-registry-usage-test): Add subject lookup test.
+
+ * registry.el (registry-db, initialize-instance): Set up constructor
+ instead of :initform arguments for the sake of older Emacsen.
+ (registry-lookup-breaks-before-lexbind): New method to demonstrate
+ pre-lexbind merge bug.
+ (registry-usage-test): Use it.
+ (initialize-instance, registry-db): Move the non-function initforms
+ back to the class definition.
+
+2011-04-03 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * registry.el: New library to manage gnus-registry-style data.
+
+ * gnus-registry.el: Use it (major rewrite).
+
+ * nnregistry.el: Use it.
+
+ * spam.el: Use it.
+
+2011-04-03 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-sum.el (gnus-update-marks): Reinstate the code to not alter
+ marks on non-selected articles.
+
+2011-04-02 Chong Yidong <cyd@stupidchicken.com>
+
+ * proto-stream.el: Move to Emacs core, at net/network-stream.el.
+
+ * nnimap.el (nnimap-open-connection-1): Pass explicit :end-of-command
+ parameter to open-protocol-stream.
+
+2011-04-01 Julien Danjou <julien@danjou.info>
+
+ * mm-view.el (mm-display-inline-fontify): Do not fontify with
+ fundamental-mode.
+
+2011-04-01 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-start.el (gnus-get-unread-articles): Don't try to contact denied
+ servers.
+
+2011-03-30 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-sum.el (gnus-update-marks): Revert intersection change, which
+ made marks not propagate, again.
+
+2011-03-30 Chong Yidong <cyd@stupidchicken.com>
+
+ * proto-stream.el (open-protocol-stream): Bring back `network' type.
+ Make this the default type.
+ (proto-stream-open-plain): Rename from proto-stream-open-default.
+ (open-protocol-stream, proto-stream-open-starttls)
+ (proto-stream-open-tls, proto-stream-open-shell): Replace `default'
+ with `plain'.
+
+ * nnimap.el (nnimap-stream, nnimap-open-connection-1): Accept `network'
+ value.
+
+ * nntp.el (nntp-open-connection-function): Document the fact that some
+ values are not functions but are instead handled specially.
+ Recognize nntp-open-plain-stream value.
+ (nntp-open-connection): Recognize that value.
+
+2011-03-29 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gssapi.el (open-gssapi-stream): Remove the last mentions of the IMAP
+ stuff.
+
+ * gnus-score.el (gnus-score-string): Fix calling convention of
+ `gnus-simplify-buffer-fuzzy' after last patches.
+
+ * gnus-sum.el (gnus-update-marks): Don't send any marks updates to the
+ server for articles we didn't get any headers for. This is a sanity
+ check.
+
+2011-03-29 Michael Welsh Duggan <md5i@md5i.com>
+
+ * nnimap.el (nnimap-open-connection-1): Is the login responds with a
+ new CAPABILITY, use it.
+
+2011-03-29 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-agent.el (gnus-agent-fetch-headers): Don't message if we're not
+ downloading anything.
+
+ * gnus.el (gnus-splash-svg-color-symbols): Remove superfluous `and'.
+
+2011-03-29 Adam Sjøgren <asjo@koldfront.dk>
+
+ * gnus.el (gnus-group-startup-message): Prefer svg file and replace
+ colors.
+ (gnus-splash-svg-color-symbols): New function.
+
+2011-03-29 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-sum.el (gnus-simplify-buffer-fuzzy): Take the regexp explicitly
+ instead of using the global gnus-simplify-subject-fuzzy-regexp.
+ (gnus-simplify-subject-fuzzy): Use the local
+ gnus-simplify-subject-fuzzy-regex instead of the global one.
+ This makes using this variable in group parameters work.
+
+2011-03-29 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * gnus-registry.el (gnus-registry-unfollowed-groups):
+ Add "archive:sent" to the unfollowed group regex (for the recent Gnus
+ archive:sent-YYYY-MM-DD groups).
+ (gnus-registry-split-fancy-with-parent): Bail out early in sender
+ tracking if there are more than `gnus-registry-max-track-groups'
+ matches.
+
+2011-03-29 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * message.el (message--yank-original-internal): New function to do the
+ insertion cleanly inside eval in `message-yank-original'.
+ (message-yank-original): Use it.
+
+2011-03-29 Julien Danjou <julien@danjou.info>
+
+ * mm-view.el (mm-display-inline-fontify): Use `set-normal-mode' with
+ local variables disabled rather than `normal-mode'.
+
+2011-03-26 Chong Yidong <cyd@stupidchicken.com>
+
+ * proto-stream.el: Changes preparatory to merging open-protocol-stream
+ with open-network-stream.
+ (proto-stream-always-use-starttls): Option removed.
+ (open-protocol-stream): Return a process object by default. Provide a
+ new parameter :return-list specifying a list-type return value, which
+ now has the form (PROP . PLIST) instead of a fixed-length list. Change
+ :type `network' to `try-starttls', and `network-only' to `default'.
+ Make `default' the default, for compatibility with open-network-stream.
+ Handle the no-parameter case exactly as open-network-stream, with no
+ additional stream processing. Search plists using plist-get.
+ Explicitly add :end-of-commend parameter if it is missing.
+ (proto-stream-open-default): Rename from
+ proto-stream-open-network-only. Return 'default as the type.
+ (proto-stream-open-starttls): Rename from proto-stream-open-network.
+ Use plist-get. Don't return `tls' as the type if STARTTLS negotiation
+ failed. Always return a list with a (possibly dead) process as the
+ first element, for compatibility with open-network-stream.
+ (proto-stream-open-tls): Use plist-get. Always return a list.
+ (proto-stream-open-shell): Return `default' as connection type.
+ (proto-stream-capability-open): Use plist-get.
+ (proto-stream-eoc): Function deleted.
+
+ * nnimap.el (nnimap-stream, nnimap-open-connection)
+ (nnimap-open-connection-1): Handle renaming of :type parameter for
+ open-protocol-stream.
+ (nnimap-open-connection-1): Pass a :return-list parameter
+ open-protocol-stream to obtain a list return value. Parse this list
+ using plist-get.
+
+ * nntp.el (nntp-open-connection): Handle renaming of :type parameter
+ for open-protocol-stream. Accept open-protocol-stream return value
+ that is a subprocess object instead of a list. Handle the case of a
+ dead returned process.
+
+2011-03-25 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * mm-util.el (mm-handle-filename): Move to mm-decode.el (bug#8330).
+
+ * mm-decode.el (mm-handle-filename): Move from mm-util.el (bug#8330).
+
+2011-03-21 Julien Danjou <julien@danjou.info>
+
+ * mm-view.el (mm-display-inline-fontify): Make mode optional, and call
+ normal-mode if not set. Set temp buffer unmodified to avoid kill-buffer
+ query.
+ (mm-inline-text): Render normal text with fontification whenever
+ possible.
+
+ * gnus-sum.el (gnus-summary-save-parts-1):
+ * gnus-art.el (gnus-article-browse-html-save-cid-content)
+ (gnus-article-browse-html-parts, gnus-mime-delete-part)
+ (gnus-mime-copy-part, gnus-mime-inline-part, gnus-insert-mime-button):
+ Use `mm-handle-filename'.
+
+ * mm-util.el (mm-handle-filename): New function, return the filename of
+ an handle.
+
+2011-03-18 Julien Danjou <julien@danjou.info>
+
+ * gnus-util.el (gnus-buffer-live-p): Simplify gnus-buffer-live-p.
+ (gnus-buffer-live-p): Check that buffer is not nil.
+
+2011-03-17 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-art.el: Require mouse, which the build bot seems to say is
+ needed.
+
+ * gravatar.el (gravatar-retrieve-synchronously): Use `url-retrieve' on
+ XEmacs, since it doesn't have url-retrieve-synchronously.
+
+2011-03-17 Antoine Levitt <antoine.levitt@gmail.com>
+
+ * gnus-group.el (gnus-group-list-ticked): New function.
+ (gnus-group-make-menu-bar): Provide a menu entry for it.
+ (gnus-group-list-map): Provide a binding for it.
+
+2011-03-17 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-visit-file): New command.
+
+ * nnimap.el (nnimap-fetch-inbox): Rewrite slightly last patch.
+
+2011-03-17 Bjørn Mork <bjorn@mork.no>
+
+ * nnimap.el (nnimap-fetch-inbox): Don't download bodies on ver4-capable
+ servers.
+
+2011-03-16 Julien Danjou <julien@danjou.info>
+
+ * mm-uu.el (mm-uu-dissect-text-parts): Only dissect handle that are
+ inline.
+
+ * gnus-art.el (article-hide-list-identifiers):
+ Use gnus-group-get-list-identifiers.
+
+ * gnus-sum.el (gnus-group-get-list-identifiers): New function.
+ (gnus-summary-remove-list-identifiers):
+ Use gnus-group-get-list-identifiers to get regexp.
+ (gnus-select-newsgroup, gnus-summary-insert-subject)
+ (gnus-summary-insert-articles):
+ Call gnus-summary-remove-list-identifiers unconditionally.
+
+2011-03-15 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-sum.el (gnus-articles-to-read): Revert back to old behaviour if
+ we're selecting a group with unread articles.
+
+ * nnimap.el (nnimap-open-connection-1): Allow `network-only', too.
+
+ * gssapi.el: New file separated out from imap.el to provide a general
+ Kerberos 5 connection facility for Emacs.
+
+ * message.el (message-elide-ellipsis): Document the format spec
+ ellipsis.
+
+2011-03-15 Reiner Steib <Reiner.Steib@gmx.de>
+
+ * message.el (message-elide-region): Allow the ellipsis to say how many
+ lines were removed.
+
+2011-03-15 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-win.el (gnus-configure-frame): Protect against trying to restore
+ window configurations containing buffers that are now dead.
+
+ * nnimap.el (nnimap-parse-flags): Remove all MODSEQ entries before
+ parsing to avoid integer overflows.
+ (nnimap-parse-flags): Simplify the last change.
+ (nnimap-parse-flags): Store HIGHESTMODSEQ as a string, since it may be
+ too large for 32-bit Emacsen.
+
+2011-03-15 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * auth-source.el (auth-source-netrc-create):
+ * message.el (message-yank-original): Fix use of `case'.
+
+2011-03-15 Nelson Ferreira <nelson.ferreira@ieee.org> (tiny change)
+
+ * gnus-art.el (gnus-article-treat-body-boundary): Fix boundary width on
+ XEmacs, which was one character too wide.
+
+2011-03-09 Antoine Levitt <antoine.levitt@gmail.com>
+
+ * gnus-sum.el (gnus-articles-to-read): Use gnus-large-newsgroup as
+ default number of articles to display.
+ (gnus-articles-to-read): Use pretty names for prompt.
+
+2011-03-15 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-int.el (gnus-open-server): Ditto.
+
+ * gnus-start.el (gnus-activate-group): Give a backtrace if
+ debug-on-quit is set and the user hits `C-g'.
+ (gnus-read-active-file): Ditto.
+
+ * gnus-group.el (gnus-group-read-ephemeral-group): Ditto.
+
+2011-03-15 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * message.el (message-yank-original): Use cond instead of CL case.
+
+2011-03-15 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * auth-source.el (auth-source-netrc-create): Use usual format for the
+ default in prompts.
+
+2011-03-13 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * auth-source.el (auth-source-netrc-create): Show the default in the
+ prompt when prompting for token creation.
+
+2011-03-12 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * auth-source.el (auth-source-format-prompt): Always convert the value
+ to a string to avoid evaluating non-string arguments.
+ (auth-source-netrc-create): Offer default properly, not as initial
+ content in `read-string'.
+ (auth-source-netrc-saver): Use a cache keyed by file name and MD5 hash
+ of line to determine if we've been run before. If so, don't run again,
+ but print a trivial message to indicate the cache was hit instead.
+
+2011-03-11 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * gnus-sync.el (gnus-sync-install-hooks, gnus-sync-unload-hook):
+ Don't install `gnus-sync-read' to any hooks by default. It's buggy.
+ The user will have to run `gnus-sync-read' manually and wait for Cloudy
+ Gnus.
+
+2011-03-11 Julien Danjou <julien@danjou.info>
+
+ * mm-uu.el (mm-uu-type-alist): Add support for diff starting with "===
+ modified file".
+
+2011-03-09 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * auth-source.el (auth-source-read-char-choice): New function to read a
+ character choice using `dropdown-list', `read-char-choice', or
+ `read-char'. It appends "[a/b/c] " to the prompt if the choices were
+ '(?a ?b ?c). The `dropdown-list' support is disabled for now. Use
+ `eval-when-compile' to load `dropdown-list'. Remove `dropdown-list'.
+ (auth-source-netrc-saver): Use it.
+ (auth-source-pick-first-password): New convenience function.
+
+2011-03-08 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * nnimap.el (nnimap-credentials): Keep the :save-function as the third
+ parameter in the credentials.
+ (nnimap-open-connection-1): Use it after a successful login.
+ (nnimap-credentials): Add IMAP-specific user and password prompt.
+
+ * auth-source.el (auth-source-search): Add :require parameter, taking a
+ list. Document it and the :save-function return token. Pass :require
+ down. Change the CREATED message from a warning to a debug statement.
+ (auth-source-search-backends): Pass :require down.
+ (auth-source-netrc-search): Pass :require down.
+ (auth-source-netrc-parse): Use :require, if it's given, as a filter.
+ Change save prompt to indicate all modifications saved here are
+ deletions.
+ (auth-source-netrc-create): Take user login name as default in user
+ prompt. Move all the save functionality to a lexically bound function
+ under the :save-function token in the returned list. Set up clearer
+ default prompts for user, host, port, and secret.
+ (auth-source-netrc-saver): New function, intended to be wrapped for
+ :save-function.
+
+2011-03-07 Chong Yidong <cyd@stupidchicken.com>
+
+ * Version 23.3 released.
+
+2011-03-07 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-table-horizontal-line): Change the defaults for the table
+ lines to be spaces instead.
+
+2011-03-07 Julien Danjou <julien@danjou.info>
+
+ * sieve-manage.el (sieve-sasl-auth): Create auth-info if not found.
+ (sieve-sasl-auth): Check that auth-source-search did return something,
+ or just return an empty string.
+
+2011-03-05 Antoine Levitt <antoine.levitt@gmail.com>
+
+ * gnus.el (gnus-interactive): Use read-directory-name.
+
+ * gnus-uu.el (gnus-uu-decode-uu-and-save)
+ (gnus-uu-decode-unshar-and-save, gnus-uu-decode-save)
+ (gnus-uu-decode-binhex, gnus-uu-decode-yenc)
+ (gnus-uu-decode-save-view, gnus-uu-decode-postscript-and-save):
+ Likewise.
+
+ * gnus-group.el (gnus-group-make-directory-group): Likewise.
+
+2011-03-05 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-start.el (gnus-group-change-level): Allow putting foreign groups
+ onto the list of killed groups, too. This makes killed nnimap groups,
+ for instance, more reliably not reappear.
+
+ * nnimap.el (nnimap-request-thread): Don't bug out when we can't find
+ the parent.
+
+ * gnus-sum.el (gnus-update-read-articles): Fix typo.
+
+ * gnus.el (gnus-valid-select-methods): Mark nnimap as a backend that
+ really have server-side marks.
+
+ * gnus-sum.el (gnus-propagate-marks): Change default back to nil again,
+ since most backends do not usefully have server-side marks.
+ (gnus-update-read-articles): Propagate marks to all backends that
+ really have server-side marks.
+
+2011-03-05 Antoine Levitt <antoine.levitt@gmail.com>
+
+ * message.el (message-cite-reply-position, message-cite-style):
+ New variables.
+ (message-yank-original): Use the new citation styles.
+
+2011-03-04 Daiki Ueno <ueno@unixuser.org>
+
+ * message.el (message-options): Revert the change that's a workaround
+ for XEmacs buffer-local issue; don't mark it buffer-local when running
+ under XEmacs.
+
+2011-03-03 Tassilo Horn <tassilo@member.fsf.org>
+
+ * nnimap.el (nnimap-parse-flags): Add a workaround for FETCH lines with
+ numbers too big to be `read'.
+
+2011-03-02 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * message.el (message-options): Make buffer-local two ways to attempt
+ to fix a XEmacs bug.
+
+2011-03-02 Julien Danjou <julien@danjou.info>
+
+ * gnus-art.el (gnus-with-article-buffer): Fix buffer live check.
+
+2011-03-01 Julien Danjou <julien@danjou.info>
+
+ * gnus-art.el (list-identifier): Add list-identifier as a parameter
+ group.
+ (article-hide-list-identifiers): Use list-identifier group parameter.
+
+2011-02-28 Julien Danjou <julien@danjou.info>
+
+ * sieve.el (sieve-buffer-script-name): New local variable to store
+ sieve script name.
+ (sieve-edit-script): Store sieve script name.
+ (sieve-upload): Use sieve script name when uploading.
+ (sieve-upload): Use substitute-command-keys.
+ (sieve-edit-script): Use substitute-command-keys.
+ (sieve-refresh-scriptlist): Use substitute-command-keys.
+ (sieve-manage-mode-map): Define keymap properly.
+ (sieve-manage-mode): Do not set mode name manually, change mode-name to
+ (sieve-refresh-scriptlist): Use substitute-command-keys."Sieve-manage".
+ Remove commented code about cvs.
+ (sieve-manage-quit): New function.
+ (sieve-manage-mode-map): Bind 'q' to sieve-manage-quit.
+
+2011-02-27 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-group.el (gnus-import-other-newsrc-file): New function.
+
+2011-02-25 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * auth-source.el (auth-source-search): Cache empty result sets.
+
+ * auth-source.el (auth-source-save-behavior): New variable to replace
+ `auth-source-never-create'.
+ (auth-source-netrc-create): Use it.
+ (auth-source-never-save): Remove.
+
+2011-02-25 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-stream): Doc fix.
+ (nnimap-open-connection-1): Reverse the order of the ports to that the
+ prompted-for port is first.
+
+ * gnus-start.el (gnus-get-unread-articles): Don't clobber the async
+ retrieval by the no-group selection.
+
+ * gnus-demon.el (gnus-demon-init): run-with-timer should be called with
+ numerical parameters.
+
+2011-02-25 Julien Danjou <julien@danjou.info>
+
+ * gnus-gravatar.el: Use gnus-with-article-buffer.
+
+ * gnus-art.el (gnus-with-article-buffer): Check that the
+ gnus-article-buffer is alive.
+
+2011-02-24 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * auth-source.el (auth-source-creation-prompts): New variable to manage
+ creation-time prompts.
+ (auth-source-search): Document it.
+ (auth-source-format-prompt): Add utility function.
+ (auth-source-netrc-create): Don't default the user name to
+ user-login-name. Use `auth-source-creation-prompts' and some default
+ prompts for user, host, port, and password (the default generic prompt
+ remains ugly).
+ (auth-source-never-save): Add customizable option to never save info.
+ (auth-source-netrc-create): Use it and improve save prompts. Fix help
+ mode excursion.
+
+2011-02-24 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * auth-source.el (auth-source-netrc-create): Use `read-char' with no
+ argument that XEmacs doesn't support.
+
+2011-02-23 Julien Danjou <julien@danjou.info>
+
+ * gnus-art.el (article-make-date-line): Ignore errors if time is
+ invalid and not convertible.
+ (article-make-date-line): Only add lapsed time if time is not nil.
+
+2011-02-23 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * auth-source.el (auth-source-netrc-create): Use `read-char' instead of
+ `read-char-choice' for backwards compatibility.
+ (auth-source-netrc-element-or-first): New function to DTRT for
+ parameter extraction.
+ (auth-source-netrc-create): Use it and fix multiple parameter print
+ bug. Use the default passed from above (given-default) or the
+ built-in (user-login-name for :user).
+
+2011-02-23 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-start.el (gnus-dribble-read-file):
+ Set buffer-save-without-query, since we always want to save the dribble
+ file, probably.
+
+ * nnmail.el (nnmail-article-group): Allow a final "" split to work on
+ nnimap.
+
+ * gnus-sum.el (gnus-user-date-format-alist): Rename back again from
+ -summary- since it's a user-visible variable.
+
+ * nnimap.el (nnimap-retrieve-group-data-early): Don't do QRESYNC the
+ first time you use the new Gnus.
+
+2011-02-22 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * auth-source.el: Don't load netrc.el.
+ (auth-sources): Search ~/.netrc as well by default.
+ (auth-source-debug): Add 'trivia option for extra output.
+ (auth-source-do-trivia): Use it.
+ (auth-source-search): Simplify logic to use
+ `auth-source-search-backends'. Use `auth-source-do-trivia' where
+ appropriate. Don't keep a running count at this level. Layer :create
+ and :delete options appropriately on the first and second passes.
+ Don't track the backend with the search results.
+ (auth-source-search-backends): New function to search a list of
+ backends for a processed spec.
+ (auth-source-netrc-parse): Cache all netrc files, making
+ auth-source-netrc-cache an alist keyed by the file name and using the
+ file mtime as the caching criterion. Keep the obfuscated data secret
+ with a lexical bind.
+ (auth-source-netrc-search): Don't calculate the length of the results
+ unnecessarily.
+ (auth-source-search-backends): Fix bug.
+ (auth-source-netrc-create): Rework prompts.
+
+2011-02-22 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el (nnir-imap-search-arguments,nnir-imap-default-search-key):
+ Lower case names of search constraints.
+ (nnir-run-query): Cache and reuse search constraints for all imap
+ servers.
+
+2011-02-22 Sam Steingold <sds@gnu.org>
+
+ * gnus-msg.el (gnus-setup-message): Also bind `winconf-name'.
+
+2011-02-22 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-msg.el (gnus-inews-add-send-actions): Restore the winconf name
+ after exit.
+ (gnus-setup-message): Define missing variable from last checkin.
+
+ * gnus-sum.el (gnus-summary-show-article): When called with t as the
+ value, show the raw article.
+
+2011-02-21 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-open-connection-1): Revert last change, since
+ auth-source now accepts numbers.
+
+ * auth-source.el (auth-source-netrc-parse): Accept a number as the port
+ spec, too.
+ (auth-source-ensure-strings): New function.
+
+ * gnus-art.el (gnus-article-update-date-headers): Doc fix.
+ (gnus-article-setup-buffer): Always restart the date timer so that user
+ changes to the frequency is respected.
+
+ * nnimap.el (nnimap-open-connection-1): auth-source expects strings as
+ port numbers, so make sure it gets that if nnimap-server-port is
+ explicit.
+
+2011-02-21 Simon Josefsson <simon@josefsson.org>
+
+ * nnimap.el (nnimap-inbox): Doc fix.
+
+2011-02-20 Chong Yidong <cyd@stupidchicken.com>
+
+ * shr-color.el (shr-color->hexadecimal): Use renamed function names
+ color-rgb-to-hex, color-name-to-rgb, color-srgb-to-lab, and
+ color-lab-to-srgb.
+
+2011-02-21 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * nntp.el (nntp-finish-retrieve-group-infos): Add a kludge to use the
+ given method as in the group name if we're using an extended method.
+ (nntp-finish-retrieve-group-infos): Wait for the end of the LIST ACTIVE
+ command, if we're using that, instead of waiting for the beginning.
+
+ * gnus-start.el (gnus-get-unread-articles): Extend the methods so that
+ we're sure to get unique server names, and we don't output two async
+ commands in the same buffer. This fixes an NNTP hang for some users.
+
+2011-02-21 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-sum.el (gnus-summary-next-article): Add a kludge to reselect the
+ summary buffer before reading going to the next buffer. This avoids
+ putting the point in the group buffer if you `C-g' the command.
+
+ * auth-source.el (auth-source-netrc-parse): Add an in-memory netrc
+ cache (for now) to make ~/.authinfo.gpg files usable.
+
+ * nnfolder.el (copyright-update): Define for the compiler.
+
+ * auth-source.el (auth-source-search): Fix unbound variable.
+
+2011-02-19 Glenn Morris <rgm@gnu.org>
* gnus.el (gnus-meta): Doc fix.
-2011-02-17 Chong Yidong <cyd@stupidchicken.com>
+2011-02-19 Chong Yidong <cyd@stupidchicken.com>
* nnfolder.el (nnfolder-save-buffer): Don't let-bind copyright-update,
in case it's not yet loaded.
-2011-01-13 Chong Yidong <cyd@stupidchicken.com>
+2011-02-20 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-wait-for-response): Ensure that we get the entire
+ line we're waiting for.
+
+2011-02-19 Darren Hoo <darren.hoo@gmail.com> (tiny change)
+
+ * gnus-art.el (gnus-article-next-page-1): Because customized mode-line
+ face with line-width greater than zero will cause RET in gnus summary
+ buffer to scroll down article page-wise because auto vscroll happens,
+ it should be temporalily disabled when doing a scroll-up.
+
+2011-02-19 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-parse-copied-articles): Allow for "<foo> OK"
+ outputs from the server.
+
+2011-02-18 Antoine Levitt <antoine.levitt@gmail.com> (tiny change)
+
+ * gnus-art.el (gnus-article-prepare): Run gnus-article-prepare-hook
+ later so that bbdb can hook in easier.
+
+2011-02-18 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * auth-source.el (auth-source-search): Don't try to create credentials
+ if the caller doesn't want that.
+ (auth-source-search): If we don't find a match, don't bug out on
+ non-bound variables.
+ (auth-source-search): Only ask a single backend to create the
+ credentials.
+
+ * nnimap.el (nnimap-log-command): Add a newline to the inhibited
+ logging.
+ (nnimap-credentials): Protect against auth-source-search returning nil.
+ (nnimap-request-list): Protect against not being able to open the
+ server.
+
+2011-02-17 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * auth-source.el (auth-source-search): Do a two-phase search, one with
+ no :create to get the responses from all backends.
+
+ * nnimap.el (nnimap-open-connection-1): Delete duplicate server names
+ when getting credentials.
+
+ * gnus-util.el (gnus-delete-duplicates): New function.
+
+2011-02-17 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * nnimap.el (nnimap-credentials): Instead of picking the first port as
+ a creation default, pass the whole port list down. It will be
+ completed.
+
+ * auth-source.el (auth-source-search): Updated docs to talk about
+ multiple creation choices.
+ (auth-source-netrc-create): Accept a list as a value (from the search
+ parameters) and do completion on that list. Keep a separate netrc line
+ with the password obscured for showing the user.
+
+ * nnimap.el (nnimap-open-connection-1): Make the `nnimap-address' the
+ first choice to `auth-source-search' so it will be used for entry
+ creation instead of the server's Gnus-specific name.
+ (nnimap-credentials): Rely on the auth-source library to select which
+ port is actually wanted in the new netrc entry, so don't override
+ `auth-source-creation-defaults'.
+
+ * auth-source.el (auth-source-netrc-parse): Use :port instead of
+ :protocol and accept a missing user, host, or port as a wildcard match.
+ (auth-source-debug): Default to off.
+
+ (auth-source-netrc-search, auth-source-netrc-create)
+ (auth-source-secrets-search, auth-source-secrets-create)
+ (auth-source-user-or-password, auth-source-backend, auth-sources)
+ (auth-source-backend-parse-parameters, auth-source-search): Use :port
+ instead of :protocol.
+
+ * nnimap.el (nnimap-credentials): Pass a port default to
+ `auth-source-search' in case an entry needs to be created.
+ (nnimap-open-connection-1): Use :port instead of :protocol.
+
+2011-02-17 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * auth-source.el (auth-source-secrets-search): Use mm-delete-duplicates
+ instead of delete-dups that is not available in XEmacs 21.4.
+
+2011-02-16 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-sum.el (gnus-propagate-marks): Change default to t again, since
+ nil means that nnimap doesn't get updated.
+
+2011-02-16 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * auth-source.el (auth-source-netrc-create): Return a synthetic search
+ result when the user doesn't want to write to the file.
+ (auth-source-netrc-search): Expect a synthetic result and proceed
+ accordingly.
+ (auth-source-cache-expiry): New variable to override
+ `password-cache-expiry'.
+ (auth-source-remember): Use it.
+
+ * nnimap.el (nnimap-credentials): Remove the `inhibit-create'
+ parameter. Create entry if necessary by using :create t.
+ (nnimap-open-connection-1): Don't pass `inhibit-create'.
+
+2011-02-15 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * auth-source.el (auth-source-debug): Enable by default and don't
+ mention the obsolete `auth-source-hide-passwords'.
+ (auth-source-do-warn): New function to debug unconditionally.
+ (auth-source-do-debug): Use it.
+ (auth-source-backend-parse): Use it for invalid `auth-sources' entries
+ and for Secrets API entries when the secrets.el library is not
+ available.
+
+2011-02-14 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-sum.el (gnus-propagate-marks): Default to nil.
+ (gnus-summary-exit): Kill the correct article buffer on exit from a
+ `C-d' group.
+
+ * gnus-start.el (gnus-use-backend-marks): Removed, since it duplicates
+ gnus-propagate-marks.
+
+ * gnus-sum.el (gnus-summary-exit-no-update): Restore the group conf
+ before killing the buffers so that a non-full window conf gets handled
+ correctly.
+ (gnus-summary-exit): Ditto.
+ (gnus-summary-read-group-1): Ditto.
+
+ * nntp.el (nntp-retrieve-group-data-early): Reinstate the two-part
+ async code again so that we can debug it properly.
+
+ * message.el (message-reply): Take an optional switch-buffer parameter
+ so that Gnus window confs are respected better.
+
+2011-02-14 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * auth-source.el (auth-source-backend-parse-parameters): Don't rely on
+ `plist-get' to accept non-list parameters (XEmacs issue).
+ Fix docstring.
+ (auth-source-secrets-search): Use `delete-dups', `append mapcar', and
+ `butlast' instead of `remove-duplicates', `mapcan', and `subseq'.
+ (auth-sources, auth-source-backend-parse, auth-source-secrets-search):
+ Login collection is "Login" and not "login".
+
+2011-02-14 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-art.el (article-update-date-lapsed): Don't bug out when updating
+ multiple headers.
+
+ * nnimap.el (nnimap-inhibit-logging): New variable.
+ (nnimap-log-command): Don't log login commands.
+
+ * auth-source.el (auth-source-netrc-search): The asserts seem to want
+ to have more parameters.
+
+ * nnimap.el (nnimap-send-command): Mark the command time for each
+ command, so that we don't get NOOPs stepping on our toes.
+
+ * gnus-art.el (article-date-ut): Get the date from the Date header on
+ `t'.
+
+2011-02-14 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * auth-source.el (auth-source-search): Use copy-sequence instead of
+ the cl.el copy-list.
+
+2011-02-13 Adam Sjøgren <asjo@koldfront.dk>
+
+ * gnus-delay.el (gnus-delay-article) Fix number of seconds per day.
+ Improve prompt.
+
+2011-02-13 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-art.el (gnus-article-mode-line-format): Remove the article
+ washing status from the default format. It isn't very informative.
+
+2011-02-13 Tassilo Horn <tassilo@member.fsf.org> (tiny change)
+
+ * nnimap.el (nnimap-request-accept-article, nnimap-process-quirk):
+ Fix Gcc processing on imap.
- * message.el (message-bury): Add special-case handling for Rmail.
+2011-02-10 Stefan Monnier <monnier@iro.umontreal.ca>
-2011-01-12 Glenn Morris <rgm@gnu.org>
+ * message.el (message-bury): Don't pop up a new window when selected
+ window is dedicated.
+
+2011-02-10 Antoine Levitt <antoine.levitt@gmail.com> (tiny change)
+
+ * gnus-sum.el (gnus-summary-save-parts): Use read-directory-name.
+
+2011-02-10 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * sieve-manage.el: Autoload `auth-source-search'.
+ (sieve-sasl-auth): Use it.
+
+2011-02-09 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * nnimap.el: Autoload `auth-source-forget+'.
+ (nnimap-open-connection-1): Use it if the connection fails.
+
+ * auth-source.el: Require `password-cache'.
+ (auth-source-hide-passwords, auth-source-cache): Remove and mark
+ obsolete.
+ (auth-source-magic): Marker for `password-cache' keys.
+ (auth-source-do-cache): Update docstring.
+ (auth-source-search): Use and check cache.
+ (auth-source-forget-all-cached, auth-source-remember)
+ (auth-source-recall, auth-source-forget, auth-source-forget+)
+ (auth-source-specmatchp): Caching support functions.
+ (auth-source-forget-user-or-password, auth-source-forget-all-cached):
+ Remove and obsolete.
+ (auth-source-user-or-password): Remove caching to further discourage
+ using it. Always hide passwords.
+
+2011-02-09 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * nntp.el (nntp-retrieve-group-data-early-disabled): Disable the async
+ code for now, since it doesn't work for all users.
+
+2011-02-09 Julien Danjou <julien@danjou.info>
+
+ * message.el (message-options): Make message-options really buffer
+ local.
+
+2011-02-08 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * mail-source.el: Autoload `auth-source-search'.
+ (mail-source-keyword-map): Note order matters.
+ (mail-source-set-1): Get all the mail-source source values and
+ defaults and search auth-source on those if needed. This can all
+ probably be simplified.
+
+ * nnimap.el: Autoload `auth-source-search'.
+ (nnimap-credentials): Use it.
+ (nnimap-open-connection-1): Ask for the virtual server and physical
+ address in one shot.
+
+ * nntp.el: Autoload `auth-source-search'.
+ (nntp-send-authinfo): Use it. Note TODO.
+
+2011-02-08 Julien Danjou <julien@danjou.info>
+
+ * shr.el (shr-tag-body): Add support for text attribute in body
+ markups.
+
+ * message.el (message-options): Make message-options a local variable.
+
+2011-02-07 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * auth-source.el (auth-source-secrets-search)
+ (auth-source-user-or-password): Use `append' instead of `nconc'.
+ (auth-source-user-or-password): Build return list better and protect
+ against nil :secret.
+
+2011-02-07 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-update-info): Refactor slightly.
+ (nnimap-update-info): Tell Gnus whether there are any \Recent messages.
+ (nnimap-update-info): Clean up slightly.
+ (nnimap-quirk): Add quirk for Gmail IMAP which bugs out on NUL
+ characters.
+ (nnimap-process-quirk): Rename function to avoid collision.
+ (nnimap-update-info): Fix macrology bug-out.
+ (nnimap-update-info): Simplify split history test.
+
+2011-02-06 Michael Albinus <michael.albinus@gmx.de>
+
+ * auth-source.el (top): Require 'eieio unconditionally.
+ Autoload `secrets-get-attributes' instead of `secrets-get-attribute'.
+ (auth-source-secrets-search): Limit search when `max' is greater than
+ number of results.
+
+2011-02-06 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * nntp.el (nntp-finish-retrieve-group-infos): Protect against the first
+ part not returning any data.
+
+ * proto-stream.el (open-protocol-stream): Document the return value.
+
+2011-02-06 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * auth-source.el (auth-source-secrets-search): Add examples.
+
+2011-02-06 Julien Danjou <julien@danjou.info>
+
+ * message.el (message-setup-1): Handle message-generate-headers-first
+ set to t.
+
+2011-02-06 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * auth-source.el (auth-sources): Allow for simpler defaults for Secrets
+ API with a string "secrets:collection-name" and with 'default.
+ (auth-source-backend-parse): Parse "secrets:collection-name" and
+ 'default. Recurse on parses instead of repeating code. Use the
+ Secrets API is the source is not nil and 'ignore otherwise. Emit a
+ message when ignoring a source.
+ (auth-source-search): List ignored search keys at the top level.
+ (auth-source-netrc-create): Use `case' instead of `cond'.
+ (auth-source-secrets-search): Created with TODOs.
+ (auth-source-secrets-create): Created with TODOs.
+ (auth-source-retrieve, auth-source-create, auth-source-delete)
+ (auth-source-protocol-defaults, auth-source-user-or-password-imap)
+ (auth-source-user-or-password-pop3, auth-source-user-or-password-ssh)
+ (auth-source-user-or-password-sftp)
+ (auth-source-user-or-password-smtp): Remove.
+ (auth-source-user-or-password): Deprecated and modified to be a wrapper
+ around `auth-source-search'. Not tested thoroughly.
+
+2011-02-04 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * auth-source.el: Bring in assoc and eioeio libraries.
+ (secrets-enabled): New variable to track the status of the Secrets API.
+ (auth-source-backend): New EIOEIO class to represent a backend.
+ (auth-source-creation-defaults): New variable to set prompt defaults
+ during token creation (see the `auth-source-search' docstring for
+ details).
+ (auth-sources): Simplify to allow a simple string as a netrc backend
+ spec.
+ (auth-source-backend-parse): Parse a backend from an `auth-sources' spec.
+ (auth-source-backend-parse-parameters): Fill in the backend parameters.
+ (auth-source-search): Main auth-source API entry point.
+ (auth-source-delete): Wrapper around `auth-source-search' for deletion.
+ (auth-source-search-collection): Helper function for searching.
+ (auth-source-netrc-parse, auth-source-netrc-normalize)
+ (auth-source-netrc-search, auth-source-netrc-create): Netrc backend.
+ Supports search, create, and delete.
+ (auth-source-secrets-search, auth-source-secrets-create): Secrets API
+ backend stubs.
+ (auth-source-user-or-password): Call `auth-source-search' but it's not
+ ready yet.
+
+2011-02-04 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * message.el (message-setup-1): Remove the read-only stuff, since it
+ doesn't work under XEmacs, for some reason.
+
+ * gnus-sum.el (gnus-user-date): Rename back from
+ gnus-summary-user-date since user code refers to it.
+
+ * shr.el (shr-render-td): Store the actual background colour used.
+
+ * message.el (message-setup-1): Don't bind the constant
+ -forbidden-properties.
+ (message-setup-1): Revert previous change, since it needs to bind the
+ props to insert them.
+ (message-resend): Allow removing the read-only separator line.
+
+2011-02-03 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-request-accept-article): Give an error message if
+ the APPEND wasn't successful.
+
+2011-02-03 Adam Sjøgren <asjo@koldfront.dk>
+
+ * gnus-start.el (gnus-get-unread-articles): Fix the call to methods
+ that have no groups.
+
+2011-02-03 Julien Danjou <julien@danjou.info>
+
+ * gnus-draft.el: Remove progn around gnus-draft-setup.
+
+2011-02-03 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-start.el (gnus-read-active-for-groups): This function is never
+ called with a nil `infos', so clean that up.
+ (gnus-get-unread-articles): Request active files from primary/secondary
+ methods that have no groups (yet).
+
+2011-02-03 Julien Danjou <julien@danjou.info>
+
+ * message.el (message-setup-1): Always generate References first.
+ (message-mail): Return the return value of message-setup, not always t.
+ (message-setup-1): Insert mail-header-separator with read-only and
+ intangible properties set.
+
+ * gnus.el (gnus-summary-line-format): Add missing semi-colon for
+ user-date in docstring.
+
+ * gnus-art.el (gnus-article-jump-to-part): Remove useless sit-for.
+
+ * gnus.el (gnus-summary-line-format): Mention &user-date format in
+ docstring.
+
+ * gnus.el (gnus-user-date-format-alist): Change default value. Use
+ defcustom, with type and group. Move from gnus-util.el. Rename to
+ gnus-summary-user-date-format-alist.
+
+2011-02-03 Glenn Morris <rgm@gnu.org>
+
+ * nnimap.el (gnus-fetch-headers): Declare.
+
+ * nnheader.el (gnus-range-add, gnus-remove-from-range): Autoload.
+
+2011-02-03 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * message.el (message-forward-make-body-digest-plain)
+ (message-followup, message-reply): Clean up things noted by Stefan.
+
+ * gnus-art.el (gnus-article-setup-buffer): Stop the date timer if
+ gnus-article-update-date-headers is nil.
+ (gnus-article-date-headers): Rip out the old -treat-date-* stuff, since
+ it didn't really work with defcustom.
+ (article-update-date-lapsed): Make sure the window start doesn't move,
+ either.
+
+2011-02-01 Julien Danjou <julien@danjou.info>
+
+ * mm-uu.el (mm-uu-type-alist): Add support for git format-patch diff
+ format.
+
+ * mm-decode.el (mm-inline-media-tests): Do not check for diff-mode it's
+ standard in Emacs nowadays.
+
+2011-02-01 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * message.el (message-expand-name): Don't trust the return value of
+ bbdb-complete-name.
+ (message-check-news-header-syntax): Remove unused var `start'.
+ (message-idna-to-ascii-rhs-1): Remove unused vars `rhs' and `address'.
+ (message-inhibit-body-encoding): Move to before first use.
+ (mail-abbrev-mode-regexp, Expires, User-Agent, Lines, Distribution)
+ (To, References, In-Reply-To, Newsgroups, Subject, Path, From)
+ (Organization, Message-ID, Date, mh-previous-window-config):
+ Defvar the vars using dynamic scoping.
+
+2011-02-01 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-render-td): Only do colours at the final rendering.
+ Should be slightly faster.
+ (shr-insert-table): Fix up TD background colours when doing the
+ vertical padding.
+
+ * gnus-art.el (article-date-ut): Protect against articles with no Date
+ header.
+ (article-update-date-lapsed): Don't use current-column to find the
+ horizontal position. It's fragile in the presence of \003 characters.
+
+ * gnus-start.el (gnus-read-active-file-1): Remove dead parameter infos.
+
+2011-01-31 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-art.el (article-transform-date): Rewrite to still work when
+ there are several rfc2822 parts.
+ (article-transform-date): Fix infinite recursion.
+ (article-date-ut): Replace infinitely many Date headers with a single
+ one when called interactively.
+
+ * nnimap.el (nnimap-wait-for-response): Wait for results in a more
+ secure manner.
+
+ * gnus-art.el (article-update-date-lapsed): Try to avoid having point
+ move around by not using save-window-excursion. It seems to work...
+
+2011-01-31 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-art.el (article-make-date-line): Work for user-defined format.
+
+2011-01-31 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * nntp.el (nntp-retrieve-group-data-early)
+ (nntp-finish-retrieve-group-infos): Implement the asynchronous data
+ fetching functions.
+
+ * gnus-start.el (gnus-read-active-for-groups): Read the active files
+ thoroughly for all backends that have no known groups. This should
+ allow new nnml methods to retrieve mail.
+
+ * gnus-group.el (gnus-group-jump-to-group): Allow jumping to groups
+ that Gnus doesn't know exists again.
+
+ * gnus-art.el (gnus-article-date-lapsed-new-header): Remove.
+ (gnus-treat-date-ut): Ditto.
+ (gnus-article-update-date-header): Rename.
+ (gnus-treat-date-local): Remove.
+ (gnus-treat-date-english): Remove.
+ (gnus-treat-date-lapsed): Remove.
+ (gnus-treat-date-combined-lapsed): Remove.
+ (gnus-treat-date-original): Remove.
+ (gnus-treat-date-iso8601): Remove.
+ (gnus-treat-date-user-defined): Remove.
+ (gnus-article-date-headers): New variable to control all the date
+ header options.
+ (article-date-ut): Rewrite to allow using the new way to format date
+ headers(s).
+
+2011-01-30 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * nnmail.el (nnmail-article-group): Check for a direct fancy split
+ method.
+ (nnmail-article-group): A better test for fanciness.
+
+ * nnimap.el (nnimap-request-head): Protect against not finding the
+ article by Message-ID.
+
+2011-01-29 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-art.el (article-update-date-lapsed): Try a better way to really
+ keep point at the "same place".
+
+2011-01-28 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-sum.el (gnus-select-newsgroup): Don't try to alter the active
+ data if the group is unactivated.
+
+2011-01-28 Julien Danjou <julien@danjou.info>
+
+ * gnus-win.el: Remove dead function gnus-window-configuration-element.
+ (gnus-all-windows-visible-p): Remove old compatibility code.
+ (gnus-window-top-edge): Add docstring.
+
+ * gnus-group.el (gnus-group-jump-to-group): Set must match to t.
+
+2011-01-28 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-int.el (gnus-request-marks): Call *-request-marks instead of the
+ older request-update-info.
+
+ * gnus-art.el (article-make-date-line): Limit the length a bit more.
+
+2011-01-28 Daiki Ueno <ueno@unixuser.org>
+
+ * mml2015.el (mml2015-epg-sign, mml2015-epg-encrypt):
+ Give mml2015-signers higher precedence over mml2015-sign-with-sender.
+
+2011-01-27 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-group.el (gnus-group-refresh-group): Refresh even non-visible
+ groups. This makes the nndraft:queue group pop up if it's not already
+ there.
+
+ * gnus-sum.el (gnus-summary-read-group-1): Fix the "contains no
+ messages" logic, which was reversed.
+
+ * gnus-art.el (article-update-date-lapsed): Ensure that point stays at
+ the "same place" even if point is on the line being replaced.
+ (article-update-date-lapsed): Allow updating both the combined lapsed
+ and the lapsed headers.
+ (article-update-date-lapsed): Skip past all the X-Sent/Date headers.
+ (article-make-date-line): Limit the number of segments dynamically to
+ avoid too-long lines.
+
+2011-01-27 Julien Danjou <julien@danjou.info>
+
+ * mml2015.el (mml2015-epg-sign): Add and use mml2015-sign-with-sender.
+ (mml2015-epg-encrypt): Use mml2015-sign-with-sender.
+
+2011-01-27 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * shr.el (shr-expand-newlines, shr-previous-newline-padding-width):
+ Use plist-get instead of the cl function getf.
+
+2011-01-27 Glenn Morris <rgm@gnu.org>
+
+ * gnus-util.el (float-time): Get rid of compiler warning, again.
+
+2011-01-27 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-put-color): Special-case background colours: Do put them
+ at the blank parts at the front of the lines.
+
+ * gnus-draft.el (gnus-draft-clear-marks): New function to be run as an
+ exit hook to nix out all data on readedness on group exit.
+
+ * gnus-util.el (float-time): If float-time is bound, always use it on
+ all Emacsen. It's unclear why the subrp check was there.
+ (time-date): Require to make some autoload issues on XEmacs go away.
+
+ * shr.el (shr-put-color): Don't do the box padding in tables, since
+ they're already padded.
+
+2011-01-26 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-art.el (gnus-article-next-page): When the last line of the
+ article is displayed, scroll down once more instead of going to the
+ next article at once.
+ (article-lapsed-string): Refactor out and allow specifying how many
+ segments you want.
+ (gnus-article-setup-buffer): Start updating the lapsed header directly.
+ (gnus-article-update-lapsed-header): New variable.
+
+ * shr.el: Revert change that made headings use different-sized faces.
+ The Emacs display engine isn't advanced enough that, for instance,
+ tables can comfortably use differently-sized faces.
+
+2011-01-25 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-open-connection-1): Store the actual stream type
+ used.
+ (nnimap-login): Prefer plain LOGIN if it's enabled (since it requires
+ fewer round trips than CRAM-MD5, and it's less likely to be buggy), and
+ we're using an encrypted connection.
+
+ * proto-stream.el: Alter the interface functions to also return the
+ actual stream type used: network or tls.
+
+2011-01-25 Julien Danjou <julien@danjou.info>
+
+ * mm-view.el (mm-display-shell-script-inline): Fix typo in docstring.
+ (mm-display-javascript-inline): New function.
+
+ * mm-decode.el (mm-inline-media-tests): Add application/javascript
+ viewing function.
+
+2011-01-25 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * shr.el (shr-expand-newlines): Fix variable name.
+
+2011-01-25 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-expand-newlines): Make nested boxes work.
+
+2011-01-24 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-expand-newlines): Proof of concept implemantation of boxy
+ backgrounds.
+ (shr-expand-newlines): Switch to using overlays to enable kill'n'yank
+ in a more sensible manner.
+
+2011-01-24 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * mml-smime.el (mml-smime-use): Make it a defcustom and default to 'epg
+ if EPG is loaded.
+
+2011-01-24 Julien Danjou <julien@danjou.info>
+
+ * shr.el: Use defface to create shr-tag-h[1-6] faces to fontify h[1-6]
+ tags.
+
+2011-01-24 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-art.el (gnus-article-read-summary-keys): Don't call disabled
+ commands.
+
+ * gnus-gravatar.el (gnus-gravatar-insert): Don't move point around
+ in the article buffer.
+ (gnus-gravatar-insert): Use blank space from the current buffer to
+ avoid breaking text properties. This makes X-Sent updating work again.
+
+ * gravatar.el (gravatar-retrieve): Be silent when retrieving.
+
+2011-01-23 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-html.el (gnus-html-image-fetched): Kill the buffer anyway, and
+ fix the bug in url-http.el instead.
+
+ * shr.el (shr-image-fetched): Ditto.
+
+ * shr.el (shr-image-fetched): Avoid having point move in the article
+ buffer.
+
+ * gnus-html.el (gnus-html-image-fetched): Don't kill the temporary
+ buffer after being called. It's apparently being killed by url.el, and
+ killing it made point move to end-of-buffer in a random buffer.
+
+ * shr.el (shr-image-fetched): Ditto.
+
+2011-01-23 Julien Danjou <julien@danjou.info>
+
+ * mm-decode.el (mm-inline-media-tests): Change text/org to text/x-org.
+
+ * mm-uu.el (mm-uu-org-src-code-block-extract): Change text/org to
+ text/x-org.
+
+2011-01-22 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-sum.el (gnus-summary-move-article): Protect against backends
+ (i.e., nnimap) returning nil as the article number.
+
+2011-01-22 Kazuhiro Ito <kzhr@d1.dion.ne.jp> (tiny change)
+
+ * flow-fill.el (fill-flowed): Make `delete-space' option correspond to
+ "DelSp" parameter in RFC3676.
+
+2011-01-22 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * message.el (message-check-recipients): Display the encoded version of
+ the bogus address if they differ.
+
+ * gnus-draft.el (gnus-group-send-queue): Really refresh the queue group
+ after sending.
+
+ * gnus-agent.el (gnus-agent-send-mail): Ditto.
+
+ * gnus-group.el (gnus-group-refresh-group): New convenience function.
+
+ * gnus-draft.el (gnus-group-send-queue): Update the queue group in the
+ group buffer after sending the queue.
+
+ * gnus-agent.el (gnus-agent-send-mail): Ditto.
+
+2011-01-22 Julien Danjou <julien@danjou.info>
+
+ * mailcap.el (mailcap-mime-extensions): Rename text/org to text/x-org.
+
+2011-01-22 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * mm-decode.el (mm-preferred-alternative-precedence): Don't bug out on
+ nested related parts.
+
+ * nnfolder.el (nnfolder-request-expire-articles): Return the list of
+ unexpired articles. This fixes the regression that led expiry marks to
+ disappear from nnfolder groups.
+
+2011-01-21 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * gnus-art.el (gnus-button-alist, gnus-button-handle-info-keystrokes):
+ Don't confuse the "ret" of "retrograde" with RET.
+
+2011-01-21 Julien Danjou <julien@danjou.info>
+
+ * gnus-art.el (gnus-mime-display-single): Use mm-display-inline rather
+ than mm-insert-inline.
+
+2011-01-21 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-art.el (gnus-article-remove-images, gnus-article-show-images):
+ Widen article buffer.
+
+2011-01-20 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * mm-util.el (mm-find-buffer-file-coding-system): Don't forget to kill
+ the temp buffer.
+ * message.el (message-mailer-swallows-blank-line): Use with-temp-buffer.
+
+2011-01-20 Julien Danjou <julien@danjou.info>
+
+ * mm-decode.el (mm-inline-media-tests): Add text/x-sh.
+
+ * gnus-art.el (gnus-mime-inline-part): Use mm-display-inline rather
+ than mm-insert-inline to insert inline part: this respect
+ mm-inline-media-tests displayers.
+
+ * mm-view.el (mm-display-shell-script-inline): New function.
+
+ * mm-decode.el (mm-inline-media-tests): Add x-shellscript and x-sh.
+
+ * mm-uu.el (mm-uu-type-alist): Add org block.
+ (mm-uu-org-src-code-block-extract): New function.
+
+ * mm-view.el (mm-display-org-inline): New function.
+
+ * mm-decode.el (mm-automatic-display): Add text/org.
+
+ * mailcap.el (mailcap-mime-extensions): Add .org.
+
+2011-01-19 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-art.el (gnus-article-highlight): Remove argument passed to
+ gnus-article-add-buttons.
+
+2011-01-19 Tom Rauchenwald <sehnsucht.nach.unendlichkeit@quantentunnel.de> (tiny change)
+
+ * spam.el (spam-spamassassin-register-with-sa-learn): Insert a full
+ From header with a date and "nobody" as the sender.
+
+2011-01-19 Julien Danjou <julien@danjou.info>
+
+ * gnus-art.el (gnus-article-add-buttons): Simplify condition.
+ (gnus-button-push): Remove gnus-button-entry function, it fails heavily
+ if you have the same regexp several times.
+ (gnus-button-push): Fix matching when regexp is symbol.
+
+2011-01-15 Glenn Morris <rgm@gnu.org>
* message.el (message-mail): A compose-mail function should
accept headers as strings.
-2010-11-19 Yuri Karaban <tech@askold.net> (tiny change)
+2011-01-13 Chong Yidong <cyd@stupidchicken.com>
+
+ * message.el (message-tool-bar-gnome): Tweak tool-bar items.
+ Add :vert-only tags.
+ (message-mail): New arg RETURN-ACTION.
+ (message-return-action): New var.
+ (message-bury): Use it.
+ (message-mode): Make it buffer-local.
+ (message-send-and-exit): Always call message-bury.
+
+ * gnus-msg.el (gnus-msg-mail): New arg RETURN-ACTION. Pass it to
+ message-mail.
+
+2011-01-11 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-convert-partial-article): Protect against
+ zero-length body parts.
+
+ * mm-decode.el (mm-preferred-alternative-precedence):
+ Discourage showing empty parts.
+
+ * gnus-int.el (gnus-request-accept-article): Don't try to update marks
+ and stuff if the backend didn't return the article number. This fixes
+ an Exchange-related nnimap bug.
+
+ * gnus-sum.el (gnus-summary-next-article): Remove hack to reselect
+ group window, because it does the wrong thing when a separate frame
+ displays the group buffer.
+
+ * proto-stream.el (open-protocol-stream): Protect against the low-level
+ transport functions returning nil.
+
+2011-01-07 Daiki Ueno <ueno@unixuser.org>
+
+ * mml2015.el (epg-sub-key-fingerprint): Autoload.
+ (mml2015-epg-find-usable-secret-key): New function.
+ (mml2015-epg-sign): Use mml2015-epg-find-usable-secret-key instead of
+ mml2015-epg-find-usable-key (Bug#7797).
+ (mml2015-epg-encrypt): Ditto.
+
+2011-01-03 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * flow-fill.el (fill-flowed-encode): Do encoding citation-aware.
+
+2011-01-03 Glenn Morris <rgm@gnu.org>
+
+ * sieve-manage.el (sieve-manage-open): Correctly set sieve-manage-port.
+
+ * sieve.el (sieve-open-server): Give a more explicit error if
+ sieve-manage-open returns nil. (Bug#7720)
+
+2011-01-02 Karl Fogel <kfogel@red-bean.com>
+
+ * gnus-msg.el (gnus-message-replyencrypt): Default to `t'.
+
+2011-01-02 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-login): Prefer AUTH=CRAM-MD5, if it's available.
+ This avoids sending passwords in plain text over non-encrypted
+ channels.
+
+ * shr.el (shr-rescale-image): Display all GIF images as animated images.
+
+ * nnimap.el (nnimap-login): Refactored out into own function, and
+ implement CRAM-MD5.
+ (nnimap-wait-for-line): Refactored out.
+
+ * mm-view.el (mml-smime): Require.
+
+2010-12-20 David Engster <deng@eml.cc>
+
+ * mm-view.el (mm-view-pkcs7-decrypt): If mml-smime-use is set to 'epg,
+ use EPG to decrypt S/MIME messages instead of openssl.
+
+2011-01-02 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-request-group): Avoid double SELECT on `M-g'.
+
+ * gnus-group.el (gnus-group-kill-group): Don't try to update the group
+ status is the group clearly is unreachable.
+
+ * auth-source.el (auth-source-create): Add the optional second
+ parameter to `local-variable-p' to be compatible with XEmacs.
+
+2011-01-02 Wang Diancheng <dcwang@kingbase.com.cn> (tiny change)
+
+ * nnml.el (nnml-request-article): Allow requesting by Message-ID to
+ work when using a compressed nnml folder.
+
+2011-01-02 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-sum.el (gnus-select-newsgroup): Don't propagate marks to
+ backends after sanitising on entry, because this never makes sense:
+ If the articles have gone missing, then the data no longer exists on
+ the backend, and if they haven't, then Gnus is wrong, and shouldn't
+ overwrite anything anyway.
+
+ * shr.el (shr-insert-document): Bind shr-width dynamically to
+ window-width if it's nil.
+
+2010-12-30 Tassilo Horn <tassilo@member.fsf.org>
+
+ * shr.el (shr-width, shr-insert-document): Allow nil as shr-width value
+ with the meaning of using the full emacs window width for rendering.
+
+2010-12-27 Daiki Ueno <ueno@unixuser.org>
+
+ * mml2015.el (mml2015-epg-sign, mml2015-epg-encrypt): Take care the
+ case when sender is not given.
+
+2010-12-23 Julien Danjou <julien@danjou.info>
+
+ * gnus-gravatar.el (gnus-gravatar-transform-address): Set
+ `mail-extr-ignore-realname-equals-mailbox-name' to nil when extracting
+ the addresses, otherwise we might misplaced the gravatar.
+
+2010-12-21 Daiki Ueno <ueno@unixuser.org>
+
+ * mml1991.el (pgg-sign-region, pgg-encrypt-region):
+ * gnus-art.el (pgg-snarf-keys-region): Autoload since PGG is now
+ obsolete in Emacs.
+
+2010-12-20 Julien Danjou <julien@danjou.info>
+
+ * gnus-util.el (gnus-rescale-image): Revert last change.
+
+2010-12-17 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-group.el (gnus-group-delete-articles): New command.
+
+2010-12-17 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el (nnir-mode): Make sure 'gnus-registry-install is bound.
+
+2010-12-17 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-sum.el (gnus-get-newsgroup-headers): Revert the last change
+ here, since it's up to the backends to do CRLF removal if their
+ protocol has it.
+
+ * nnimap.el (nnimap-retrieve-headers): Remove CRLF from the headers.
+
+2010-12-17 Julien Danjou <julien@danjou.info>
+
+ * gnus-util.el (gnus-rescale-image): Allow to resize images even if
+ they are from file. Can also scale up.
+
+2010-12-17 Andrew Cohen <cohen@andy.bu.edu>
+
+ * gnus-sum.el (gnus-summary-refer-thread): Simplify code. Restore
+ gnus-use-agent.
+ (gnus-get-newsgroup-headers): Avoid unwanted spaces at eol.
+
+ * nnir.el (nnir-get-active): Ignore nnir-ignored-newsgroups if null.
+
+2010-12-17 Julien Danjou <julien@danjou.info>
+
+ * gravatar.el (gravatar-retrieve-synchronously): New function.
+ (gravatar-get-data): Make more robust.
+
+2010-12-16 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-wait-for-response): Fix the end-point calculation
+ to really consider the last line.
+
+2010-12-16 Daiki Ueno <ueno@unixuser.org>
+
+ * auth-source.el (auth-source-gpg-encrypt-to): New variable to set the
+ list of recipient keys, or use symmetric encryption if not a list.
+ (auth-source-create): Use it to make `epa-file-encrypt-to' local for an
+ EPA override, replacing the call to `netrc-store-data'.
+
+2010-12-16 Dan Davison <dandavison7@gmail.com> (tiny change)
+
+ * gnus-srvr.el: Avoid passing nil regexp argument to
+ delete-matching-lines.
+
+2010-12-16 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-html.el (gnus-html-schedule-image-fetching): Make sure the HTML
+ fetching stops when Gnus exits.
+
+ * nnfolder.el (nnfolder-save-all-buffers): Refactor out into its own
+ function.
+ (nnfolder-request-expire-articles): Save all the buffers after doing
+ expiry.
+
+ * nnmail.el (nnmail-expiry-target-group): Revert the "all articles are
+ the last article", since that led to serious performance regressions
+ when expiring nnml groups.
+
+2010-12-16 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el: Improve customizations.
+
+2010-12-16 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-start.el (gnus-subscribe-newsgroup): Notify the backend.
+
+ * gnus-group.el (gnus-group-kill-group): Notify the backend that the
+ group has been killed.
+ (gnus-group-yank-group): Ditto.
+
+ * gnus-srvr.el (gnus-browse-unsubscribe-group): Ditto.
+
+ * nnimap.el (nnimap-request-update-group-status): New function.
+
+ * gnus-int.el (gnus-request-update-group-status): New interface
+ function.
+
+ * gnus-sum.el (gnus-summary-push-marks-to-backend): Fix the logic for
+ copying read-ness to the backends.
+
+ * nnimap.el (nnimap-quirk): New function.
+ (nnimap-retrieve-group-data-early): Use it.
+ (nnimap-quirks): New alist.
+
+2010-12-16 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * shr.el (shr-insert): Set shr-start after deleting trailing space;
+ don't delete it within indentation.
+
+2010-12-16 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-wait-for-response): Always look (at least) at the
+ previous line.
+
+2010-12-15 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-retrieve-group-data-early): Fix the syntax of the
+ QRESYNC command by deleting a superfluous space which broke Cyrus
+ servers. This change will break other servers that are buggy the other
+ way around.
+
+2010-12-14 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * spam.el: Reindent and fix long lines.
+ (spam-copy-or-move-routine): Exclude invalid move destinations.
+
+2010-12-14 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el (nnir-mode): Don't install registry hooks if user hasn't
+ installed the registry.
+
+2010-12-13 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el (nnir-run-gmane): Better check for gmane groups: error out if
+ groupname doesn't contain "gmane".
+
+2010-12-13 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-start.el (gnus-matches-options-n): Fix typo in last change.
+ (gnus-1): Don't create the nndrafts group twice.
+ (gnus-setup-news): There's no need to read the active file here, since
+ that's done again later on a per-backend basis.
+ (gnus-start-draft-setup): Make sure that the new group is started out
+ empty.
+
+ * gnus-agent.el (gnus-agentize): Don't create the queue group
+ automatically on startup. It'll be created later, if needed.
+
+ * gnus-start.el (gnus-auto-subscribed-groups): Add nnimap to the list
+ of automatically subscribed groups.
+ (gnus-auto-subscribed-categories): New variable.
+ (gnus-matches-options-n): Use it.
+ (gnus-default-subscribed-newsgroups): Remove unused variable.
+ (gnus-start-draft-setup): Message a bit less.
+
+2010-12-13 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el (nnir-run-imap): Return article list in order of increasing
+ UID.
+
+2010-12-13 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-sum.el (gnus-summary-enter-digest-group):
+ Mention gnus-auto-select-on-ephemeral-exit.
+
+ * proto-stream.el (proto-stream-open-network-only): Fix the calling
+ convention of the network-only option.
+
+2010-12-10 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * proto-stream.el (proto-stream-open-network-only): New function to
+ have a way to specify non-STARTTLS upgrade connections.
+
+2010-12-10 Julien Danjou <julien@danjou.info>
+
+ * gnus-gravatar.el (gnus-gravatar-transform-address): Fix error when
+ email address is nil.
+
+ * message.el (message-bogus-recipient-p): Set address to "" if nil.
+
+2010-12-10 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el (nnir-request-expire-articles): Ignore expiry except for
+ deletion.
+ (nnir-run-imap): Only need to parse list once.
+
+2010-12-09 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-tag-script): Ignore <script>.
+ (shr-tag-label): Add <label> support.
+
+2010-12-09 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * mm-util.el (mm-ucs-to-char): Use eval-and-compile.
+
+ * shr.el (shr-image-displayer): Work for images lined side by side.
+
+2010-12-08 Robert Pluim <rpluim@gmail.com>
+
+ * gnus-demon.el (gnus-demon-init): Call run-with-timer with an integer
+ parameter, since XEmacs doesn't accept t as a parameter.
+
+2010-12-08 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el (nnir-retrieve-headers): Use rassq when comparing article
+ ids.
+ (nnir-run-gmane): Simplify groupspec formatting.
+ (nnir-request-expire-articles): New function.
+
+2010-12-07 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-parse-flags): Tweak VANISHED regexp to avoid regexp
+ overflow, possibly.
+
+ * shr.el (shr-tag-table-1): Use bg/gfcolor specs on tables.
+ (shr-render-td): Handle td style="" better.
+ (shr-tag-table): Use the color from the style sheet.
+ (shr-render-td): Make sure we copy over all the overlays, too.
+
+2010-12-07 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el (nnir-run-gmane): Restore sub-optimal test for gmane server.
+ (nnir-request-article): Improve article retrieval.
+
+2010-12-07 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * mm-util.el (mm-extra-numeric-entities): New variable.
+
+ * mm-url.el (mm-url-decode-entities):
+ * mm-decode.el (mm-shr): Use it to decode extra numeric entities.
+
+2010-12-07 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * message.el: Use completion-at-point.
+ (message-completion-function): New fun, extracted from message-tab.
+ (message-mode): Use it for completion-at-point-functions.
+ (message-tab): Use it and completion-at-point.
+
+2010-12-07 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * shr.el (shr-find-fill-point): Don't break a line after a kinsoku-bol
+ character if a non-breakable character follows.
+
+2010-12-06 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * proto-stream.el (proto-stream-open-tls): Return nil if we don't get
+ any stream.
+
+ * shr.el (shr-tag-font): Colorize the region.
+ (shr-tag-body): Ditto.
+ (shr-tag-font): Actually let the styles be inherited instead of
+ overwriting them.
+ (shr-tag-font): Get the background color right.
+ (shr-tag-style): Ignore all <style> tags for the moment.
+
+ * gnus-int.el (gnus-request-thread): Rework to take a header instead of
+ a Message-ID to avoid having nnimap depend on gnus-sum.
+
+ * shr.el (shr-descend): Only colorize something if we have a node that
+ sets colors.
+
+2010-12-06 Julien Danjou <julien@danjou.info>
+
+ * shr.el (shr-render-td): Render td content with shr-descend, so style
+ will be applied to <td> too.
+ (shr-colorize-region): Colorize region even if we only have a background.
+ (shr-tag-body): Fix color and background color inheritance.
+ Do not recolorize after shr-generic.
+ (shr-tag-font): Let shr-generic colorize via inheritance.
+
+2010-12-06 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * shr.el (shr-find-fill-point): Don't regard apostrophe as kinsoku-bol.
+
+2010-12-06 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el (nnir-request-move-article): Remove obsolete code.
+
+2010-12-05 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-util.el (gnus-macroexpand-all): Use eval-and-compile.
+
+2010-12-05 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-sum.el (gnus-summary-respool-article): The completion function
+ expects a list instead of an alist.
+
+ * nntp.el (nntp-snarf-error-message): nnheader-report takes a format
+ string as the parameter.
+
+ * gnus.el (gnus-valid-select-methods): Allow nnimap to respool.
+
+ * shr.el (shr-stylesheet): New dynamic variable for cascading the
+ styles.
+ (shr-colorize-region): New function.
+ (shr-insert-background-overlay): Remove.
+ (shr-render-td): Background setting should be taken care of on a higher
+ level.
+ (shr-tag-body): Use post-hoc colorizations.
+ (shr-tag-body): Set up a style sheet based on bgcolor/fgcolor.
+ (shr-put-color-1): Don't overwrite old colors.
+ (shr-colorize-region): When the background color isn't explicit, use
+ a fixed background.
+
+ * gnus-util.el (gnus-output-to-mail): Require nnmail before using
+ nnmail variables.
+
+2010-12-05 Bjørn Mork <bjorn@mork.no>
+
+ * nnimap.el (nnimap-process-expiry-targets): Avoid downloading articles
+ unless necessary.
+
+2010-12-05 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el (nnir-run-gmane): Use more careful test for gmane nntp
+ server.
+
+2010-12-04 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-html.el (gnus-html-put-image): Use widget instead of local maps
+ so that TAB works.
+
+ * gnus-sum.el (gnus-summary-show-article): Reverse the meanings of `C-u
+ C-u g' and `C-u g' so that `C-u g' does what it traditionally did.
+
+ * shr.el (shr-urlify): Show the URL before the title to avoid
+ misleading URLs.
+
+2010-12-04 Adam Sjøgren <asjo@koldfront.dk>
+
+ * shr.el (shr-urlify): Display the title in <a> tags.
+
+2010-12-04 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el (nnir-categorize): Replace mapcar with mapc.
+
+2010-12-03 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el: Rearrange code to allow macros to be autoloaded by
+ gnus-sum.el.
+ (nnir-retrieve-headers-override-function): Make this variable
+ customizable.
+ (nnir-retrieve-headers): Remove obsolete subject-mangling code.
+
+ * gnus-sum.el (nnir-article-group,nnir-article-rsv): Autoload macros
+ from nnir.el.
+
+2010-12-03 Julien Danjou <julien@danjou.info>
+
+ * gnus-demon.el (gnus-demon-init): Fix time computing when time is nil.
+
+2010-12-03 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-util.el (gnus-macroexpand-all): Don't modify argument;
+ allow optional argument `environment'.
+
+2010-12-03 Glenn Morris <rgm@gnu.org>
+
+ * mm-extern.el (message-goto-body): Update declaration.
+
+2010-12-03 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-util.el (gnus-macroexpand-all): New function.
+
+ * gnus-sum.el (gnus-summary-line-format-alist): Use gnus-macroexpand-all
+ instead of macroexpand-all that is unavailable in XEmacs.
+
+2010-12-02 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el (nnir-summary-line-format): New variable.
+ (nnir-mode): Use it.
+ (nnir-artlist-*,nnir-aritem-*): Reimplement as macros.
+ (nnir-article-ids): Reimplement as defsubst.
+ (nnir-retrieve-headers): Don't mangle the subject header.
+ (nnir-run-imap): Use 100 as RSV score.
+ (nnir-run-find-grep): Fix for full server searching.
+ (nnir-run-gmane): Better restriction to gmane groups.
+
+ * gnus-sum.el (gnus-summary-line-format-alist): Add specs for nnir
+ summary buffers.
+
+2010-12-02 Julien Danjou <julien@danjou.info>
+
+ * gnus-win.el (gnus-configure-frame): Remove old compatibility code.
+
+ * gnus-msg.el: Mark gnus-outgoing-message-group as obsolete.
+
+ * gnus-win.el (gnus-configure-windows): Remove Gnus 3.x setting
+ support.
+
+2010-12-01 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el: Update to handle the registry better.
+ (autoload): Silence byte-compiler.
+ (nnir-open-server): Add a hook for nnir groups.
+ (nnir-request-move-article): Don't mangle the header. Better to use
+ formating variables (which will be added in the future).
+ (nnir-registry-action): Update the registry using the original article
+ group name.
+ (nnir-mode): Install nnir-specific hooks for updating the registry.
+
+ * gnus-sum.el
+ (gnus-article-original-subject,gnus-newsgroup-original-name):
+ Remove obsolete variables.
+ (gnus-summary-move-article): Remove use of obsolete variables.
+ (gnus-summary-local-variables): Make move and delete hooks local to
+ summary buffers.
+
+2010-12-01 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * rtree.el: New file.
+
+2010-12-01 Julien Danjou <julien@danjou.info>
+
+ * message.el (message-user-organization): Do not use
+ gnus-local-organization.
+
+ * gnus.el: Remove gnus-local-organization.
+
+ * gnus-msg.el: Remove nastygram thing.
+
+2010-12-01 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * nnmaildir.el (nnmaildir-request-set-mark): Add article to add-mark
+ funcall.
+
+2010-12-01 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-gravatar.el (gnus-gravatar-insert): Allow LWSP in the middle of
+ names.
+
+ * shr.el (shr-find-fill-point): Don't break line between kinsoku-bol
+ characters.
+
+ * gnus-gravatar.el (gnus-gravatar-insert): Delete unnecessary binding
+ to t of inhibit-read-only since it is inside gnus-with-article-headers.
+ Suggested by Štěpán Němec <stepnem@gmail.com>.
+ (gnus-gravatar-transform-address): Use mail-extract-address-components
+ that supports non-ASCII names rather than mail-header-parse-addresses.
+
+2010-11-30 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * proto-stream.el (open-protocol-stream): All starttls connections are
+ handled by the network handler.
+
+2010-11-30 Julien Danjou <julien@danjou.info>
+
+ * nnimap.el (nnimap-open-connection-1): Use gnus-string-match-p.
+ (nnimap-open-connection-1): Fix PREAUTH.
+
+ * gnus-gravatar.el (gnus-gravatar-size): Set gnus-gravatar-size to nil.
+
+2010-11-30 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * shr.el (shr-char-breakable-p, shr-char-nospace-p)
+ (shr-char-kinsoku-bol-p, shr-char-kinsoku-eol-p): New macros.
+ (shr-insert): Use them.
+ (shr-find-fill-point): Work better for kinsoku chars and apostrophes.
+
+2010-11-29 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el (nnir-request-move-article): Bail out if original group
+ doesn't support article moves.
+ (nnir-get-active): Improve active list retrieval.
+
+2010-11-29 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-find-fill-point): Don't break before apostrophes.
+
+2010-11-29 Binjo <binjo.cn@gmail.com> (tiny change)
+
+ * nnimap.el (nnimap-open-connection-1): w32 open-network-stream doesn't
+ seem to accept strings-with-numbers as port numbers,
+
+2010-11-29 Andrew Cohen <cohen@andy.bu.edu>
+
+ * gnus-sum.el (gnus-summary-delete-article): If delete fails don't
+ change the registry.
+
+2010-11-29 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * nnir.el (nnir-run-gmane): Use mm-delete-duplicates instead of
+ delete-dups that is not available in XEmacs 21.4.
+
+ * mm-util.el (mm-delete-duplicates): Add comment.
+
+2010-11-28 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el (nnir-ignored-newsgroups): New variable.
+ (nnir-get-active): Use it.
+
+2010-11-28 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * proto-stream.el (proto-stream-open-network): Add some comments.
+
+ * nntp.el (nntp-open-connection): Provide a :success condition.
+
+ * nnimap.el (nnimap-open-connection-1): Ditto.
+
+ * proto-stream.el (proto-stream-open-network): See what the response to
+ the STARTTLS command is.
+
+ * nnimap.el (nnimap-open-connection-1): Always upgrade to STARTTLS (for
+ backwards compatibility).
+ (nnimap-open-connection-1): Really respect nnimap-server-port.
+
+ * proto-stream.el (proto-stream-open-network): When doing opportunistic
+ TLS upgrades we don't really care about the identity of the peer.
+ (proto-stream-open-network): Force starttls.el to use gnutls-cli, since
+ that what we've checked for.
+ (proto-stream-always-use-starttls): Only default to t if
+ open-gnutls-stream exists.
+ (proto-stream-open-network): If STARTTLS failed, then just open a
+ normal connection.
+ (proto-stream-open-network): Wait until the greeting before doing
+ STARTTLS.
+
+ * nntp.el (nntp-open-connection): Report what the connection error is.
+
+ * proto-stream.el (open-protocol-stream): Rename from
+ open-proto-stream.
+
+2010-11-27 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-stream): Change default to `undecided'.
+ (nnimap-open-connection): If `nnimap-stream' is `undecided', try ssl
+ first, and then network.
+ (nnimap-open-connection-1): Respect nnimap-server-port.
+ (nnimap-open-connection): Be more backwards-compatible.
+
+ * proto-stream.el (proto-stream-always-use-starttls): New variable.
+ (proto-stream-open-starttls): De-duplicate the starttls code.
+ (proto-stream-open-starttls): Folded back into the main function.
+ (proto-stream-open-network): Fix typo in the gnutls path.
+ (proto-stream-command): Refactor out.
+
+ * nntp.el (nntp-open-connection): Fix the STARTTLS command syntax.
+
+ * proto-stream.el (proto-stream-open-starttls): Actually implement the
+ starttls.el STARTTLS.
+
+ * color.el (color-lab->srgb): Fix function call name.
+
+ * proto-stream.el (proto-stream-open-tls): Delete output from openssl
+ if we're using tls.el.
+ (proto-stream-open-network): If we don't have gnutls-cli or gnutls
+ built in, then don't try to establish a STARTTLS connection.
+
+ * nntp.el (nntp-open-connection): Switch on STARTTLS on supported
+ servers.
+
+ * proto-stream.el (open-proto-stream): Use network, not stream.
+ (open-proto-stream): Add a way to specify what the end of a command is.
+
+ * nntp.el (nntp-open-connection): Use proto-streams for the relevant
+ connections types.
+ (nntp-open-network-stream): Remove.
+ (nntp-open-ssl-stream): Remove.
+ (nntp-open-tls-stream): Remove.
+ (nntp-ssl-program): Remove.
+
+ * nnimap.el (nnimap-open-connection): Check for "OK" from the greeting.
+
+2010-11-27 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el: Fix typos.
+ (nnir-retrieve-headers-override-function): Rename variable to reflect
+ new semantics.
+ (nnir-article-group, nnir-article-number, nnir-article-rsv): New helper
+ macros.
+ (nnir-request-article, nnir-request-move-article): Use them.
+ (nnir-categorize): New function.
+ (nnir-run-query): Use it.
+ (nnir-retrieve-headers): Rewrite to batch header retrieval.
+ (nnir-run-gmane): nnir-retrieve-headers now returns the headers already
+ sorted.
+ (nnir-group-full-name): Use gnus-group-full-name instead.
+ (nnir-artlist-artitem-group, nnir-artlist-artitem-number)
+ (nnir-artlist-artitem-rsv, nnir-sort-groups-by-server): Obsolete.
+
+2010-11-27 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-open-connection): Fix typo in STARTTLS command.
+
+ * proto-stream.el: New library to provide protocol-specific
+ TLS/STARTTLS connections for IMAP, NNTP, SMTP, POP3 and similar
+ protocols.
+ (open-proto-stream): Complete the documentation.
+ (proto-stream-open-network): Fix some typos.
+
+ * nnimap.el (nnimap-open-connection): Use it.
+
+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-existent 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 compatibility.
+
+ * 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
@@ -44,22 +6655,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.
@@ -67,6 +6742,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
@@ -133,8 +7001,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>
@@ -728,9 +7596,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>
@@ -757,8 +7625,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>
@@ -940,7 +7808,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)
@@ -1074,8 +7942,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>
@@ -1295,16 +8163,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>
@@ -1337,7 +8205,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.
@@ -1480,7 +8348,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)
@@ -1659,8 +8527,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>
@@ -1686,13 +8554,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)
@@ -1716,8 +8584,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.
@@ -1823,12 +8691,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.
@@ -1860,8 +8728,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
@@ -1925,14 +8793,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>
@@ -2123,8 +8991,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>
@@ -2136,13 +9004,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
@@ -2157,8 +9025,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.
@@ -2252,8 +9120,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>
@@ -2265,8 +9133,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.
@@ -2276,8 +9144,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.
@@ -2385,15 +9253,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>
@@ -2412,8 +9280,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>
@@ -2437,8 +9305,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.
@@ -2497,8 +9365,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>
@@ -2514,8 +9381,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.
@@ -2544,8 +9411,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
@@ -2787,12 +9654,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.
@@ -2873,8 +9740,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>
@@ -2905,8 +9772,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>
@@ -2978,8 +9845,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.
@@ -3012,7 +9879,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>
@@ -3076,8 +9943,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>
@@ -3253,7 +10120,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.
@@ -3375,8 +10242,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>
@@ -3435,8 +10302,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.
@@ -3465,8 +10332,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)
@@ -3475,10 +10342,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.
@@ -3512,8 +10379,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
@@ -3534,8 +10401,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.
@@ -3610,8 +10477,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>
@@ -3630,8 +10497,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.
@@ -3692,8 +10559,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>
@@ -3750,13 +10617,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>
@@ -3810,8 +10677,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.
@@ -3878,9 +10745,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>
@@ -3892,8 +10759,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>
@@ -4053,7 +10920,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>
@@ -4119,8 +10986,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.
@@ -4148,8 +11015,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.
@@ -4191,8 +11058,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.
@@ -4310,8 +11177,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>
@@ -4323,8 +11190,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.
@@ -4376,8 +11243,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
@@ -4452,7 +11319,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>
@@ -4489,8 +11356,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.
@@ -4587,7 +11454,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
@@ -4613,12 +11480,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.
@@ -4646,8 +11513,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>
@@ -4674,8 +11541,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.
@@ -4690,8 +11557,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>
@@ -4721,8 +11588,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>
@@ -4751,8 +11618,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.
@@ -4761,8 +11628,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>
@@ -4800,8 +11667,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'.
@@ -4821,8 +11688,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>
@@ -4986,8 +11854,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>
@@ -5107,8 +11975,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>
@@ -5118,8 +11986,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>
@@ -5163,8 +12031,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>
@@ -5198,8 +12066,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
@@ -5286,17 +12154,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>
@@ -5326,8 +12194,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.
@@ -5354,8 +12222,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
@@ -5420,13 +12288,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
@@ -5442,16 +12311,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.
@@ -5468,8 +12337,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
@@ -5504,8 +12373,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>
@@ -5524,8 +12393,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.
@@ -5582,8 +12451,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.
@@ -5642,8 +12511,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.
@@ -5719,8 +12588,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.
@@ -5758,8 +12627,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.
@@ -5773,8 +12642,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
@@ -5788,7 +12657,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.
@@ -5820,8 +12689,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.
@@ -5861,8 +12730,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
@@ -5873,15 +12742,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.
@@ -5890,8 +12759,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.
@@ -5900,8 +12769,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
@@ -5918,8 +12787,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.
@@ -6026,8 +12895,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>
@@ -6037,8 +12906,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.
@@ -6086,8 +12955,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>
@@ -6213,8 +13082,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>
@@ -6299,8 +13168,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'.
@@ -6345,12 +13214,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>
@@ -6368,8 +13237,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.
@@ -6419,8 +13288,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.
@@ -6433,8 +13302,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.
@@ -6442,8 +13311,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>
@@ -6478,17 +13347,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.
@@ -6541,7 +13410,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'.
@@ -6552,10 +13421,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.
@@ -6572,8 +13441,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'.
@@ -6594,13 +13463,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.
@@ -6692,8 +13561,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.
@@ -6840,8 +13709,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>
@@ -6858,8 +13727,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.
@@ -6909,13 +13778,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.
@@ -7035,8 +13904,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
@@ -7063,8 +13932,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>
@@ -7151,8 +14020,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>
@@ -7181,11 +14050,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>
@@ -7213,8 +14082,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)
@@ -7322,8 +14191,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
@@ -7337,12 +14206,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.
@@ -7547,8 +14416,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'.
@@ -7587,8 +14456,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>
@@ -7615,7 +14484,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>
@@ -7627,14 +14496,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.
@@ -7643,8 +14512,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
@@ -7667,8 +14536,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>
@@ -7722,15 +14591,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.
@@ -7827,20 +14696,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>
@@ -7878,11 +14747,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>
@@ -7931,8 +14800,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.
@@ -8006,13 +14875,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
@@ -8032,8 +14901,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
@@ -8053,20 +14922,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>
@@ -8129,7 +14998,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.
@@ -8186,8 +15055,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.
@@ -8295,8 +15164,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>
@@ -8310,14 +15179,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>
@@ -8635,7 +15504,7 @@
* smime-ldap.el (smime-ldap-search): Add compatibility for XEmacs.
* smime.el (smime-cert-by-ldap-1): Handle certificates distributed
- in PEM format. Adjust to the XEmacs compability.
+ in PEM format. Adjust to the XEmacs compatibility.
2005-05-30 Reiner Steib <Reiner.Steib@gmx.de>
@@ -8878,8 +15747,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>
@@ -8951,7 +15820,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>
@@ -9057,8 +15926,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)
@@ -9074,12 +15943,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
@@ -9088,10 +15957,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>
@@ -9176,13 +16045,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>
@@ -9228,7 +16097,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)
@@ -9286,7 +16155,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.
@@ -9354,8 +16223,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.
@@ -9439,7 +16308,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'.
@@ -9523,8 +16392,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'.
@@ -9736,12 +16605,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.
@@ -9759,8 +16628,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>
@@ -9879,8 +16748,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>
@@ -9935,21 +16804,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.
@@ -10087,8 +16956,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)
@@ -10104,8 +16973,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.
@@ -10202,7 +17071,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>
@@ -10254,8 +17123,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>
@@ -10308,7 +17177,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>.
@@ -10317,8 +17186,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>.
@@ -10377,8 +17246,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>
@@ -10437,7 +17306,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.
@@ -10450,8 +17319,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>
@@ -10460,8 +17329,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>
@@ -10490,11 +17359,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>
@@ -10509,8 +17378,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
@@ -10566,7 +17435,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.
@@ -10583,10 +17452,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.
@@ -10603,7 +17472,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.
@@ -10665,7 +17534,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.
@@ -10879,8 +17748,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>
@@ -10891,27 +17760,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>
@@ -10936,7 +17805,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>
@@ -11075,13 +17944,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>
@@ -11090,8 +17959,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.
@@ -11125,8 +17994,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>
@@ -11135,10 +18004,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
@@ -11168,8 +18037,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>
@@ -11250,8 +18119,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)
@@ -11275,8 +18144,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>.
@@ -11307,15 +18176,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.
@@ -11335,8 +18204,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>
@@ -11391,8 +18260,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.
@@ -11467,8 +18336,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)
@@ -11539,8 +18408,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>
@@ -11574,12 +18443,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>
@@ -11600,21 +18469,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>
@@ -11628,14 +18497,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>
@@ -11681,8 +18550,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.
@@ -11771,8 +18640,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.
@@ -11800,7 +18669,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
@@ -11813,17 +18682,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>
@@ -11836,8 +18705,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.
@@ -11845,8 +18714,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.
@@ -11865,8 +18734,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>
@@ -11876,7 +18745,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.
@@ -11910,9 +18779,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>
@@ -11953,7 +18822,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.
@@ -11972,10 +18841,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>
@@ -11998,7 +18867,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>
@@ -12013,8 +18882,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.
@@ -12029,13 +18898,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.
@@ -12075,8 +18944,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>
@@ -12085,8 +18954,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)
@@ -12136,7 +19005,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>
@@ -12237,7 +19106,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>
@@ -12298,25 +19167,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
@@ -12327,14 +19196,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.
@@ -12350,7 +19219,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.
@@ -12405,8 +19274,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>
@@ -12455,8 +19324,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.
@@ -12524,8 +19393,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
@@ -12540,16 +19409,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,
@@ -12650,7 +19519,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.
@@ -12671,8 +19540,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>.
@@ -12682,8 +19551,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
@@ -12721,8 +19590,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>
@@ -12768,20 +19637,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>
@@ -12789,9 +19658,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
@@ -12853,8 +19721,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>
@@ -12991,8 +19859,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.
@@ -13053,8 +19921,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>
@@ -13094,8 +19962,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.
@@ -13121,29 +19989,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
@@ -13151,10 +20019,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".
@@ -13167,7 +20035,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
@@ -13178,11 +20046,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
@@ -13223,8 +20091,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>
@@ -13288,7 +20156,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>
@@ -13308,11 +20176,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>
@@ -13435,8 +20303,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>
@@ -13473,8 +20341,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>
@@ -13521,10 +20389,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>
@@ -13603,7 +20471,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>
@@ -13636,10 +20504,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)
@@ -13665,8 +20533,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.
@@ -13686,8 +20554,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.
@@ -13707,7 +20575,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>.
@@ -13774,8 +20642,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.
@@ -13812,13 +20680,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.
@@ -13832,8 +20700,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>
@@ -13886,15 +20754,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>
@@ -13915,7 +20783,7 @@
See ChangeLog.2 for earlier changes.
- Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 2004-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -13937,4 +20805,3 @@ See ChangeLog.2 for earlier changes.
;; fill-column: 79
;; add-log-time-zone-rule: t
;; End:
-
diff --git a/lisp/gnus/ChangeLog.1 b/lisp/gnus/ChangeLog.1
index 0338f9a8d1d..7448808b20f 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>
@@ -3708,8 +3708,7 @@
* gnus.el: Quassia Gnus v0.1 is released.
- Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
- 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 1997-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -3725,5 +3724,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: c2f4e9c8-94fb-4c63-bdfd-4ab680cc9db7
diff --git a/lisp/gnus/ChangeLog.2 b/lisp/gnus/ChangeLog.2
index a468c2698a4..4882032f284 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.
@@ -18553,8 +18553,7 @@
See ChangeLog.1 for earlier changes.
- Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
- Free Software Foundation, Inc.
+ Copyright (C) 2000-2002, 2004-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -18574,5 +18573,3 @@ See ChangeLog.1 for earlier changes.
;; Local Variables:
;; coding: iso-2022-7bit
;; End:
-
-;; arch-tag: 956fd310-042f-4fca-8dca-a01dbe06acff
diff --git a/lisp/gnus/auth-source.el b/lisp/gnus/auth-source.el
index 3718f82c796..e0bea324a25 100644
--- a/lisp/gnus/auth-source.el
+++ b/lisp/gnus/auth-source.el
@@ -1,6 +1,6 @@
;;; auth-source.el --- authentication sources for Gnus and Emacs
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Ted Zlatanov <tzz@lifelogs.com>
;; Keywords: news
@@ -29,96 +29,226 @@
;; 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 'password-cache)
+(require 'mm-util)
(require 'gnus-util)
-
+(require 'assoc)
(eval-when-compile (require 'cl))
-(eval-when-compile (require 'netrc))
+(require 'eieio)
+
+(autoload 'secrets-create-item "secrets")
+(autoload 'secrets-delete-item "secrets")
+(autoload 'secrets-get-alias "secrets")
+(autoload 'secrets-get-attributes "secrets")
+(autoload 'secrets-get-secret "secrets")
+(autoload 'secrets-list-collections "secrets")
+(autoload 'secrets-search-items "secrets")
+
+(autoload 'rfc2104-hash "rfc2104")
+
+(defvar secrets-enabled)
(defgroup auth-source nil
"Authentication sources."
:version "23.1" ;; No Gnus
:group 'gnus)
+;;;###autoload
+(defcustom auth-source-cache-expiry 7200
+ "How many seconds passwords are cached, or nil to disable
+expiring. Overrides `password-cache-expiry' through a
+let-binding."
+ :group 'auth-source
+ :type '(choice (const :tag "Never" nil)
+ (const :tag "All Day" 86400)
+ (const :tag "2 Hours" 7200)
+ (const :tag "30 Minutes" 1800)
+ (integer :tag "Seconds")))
+
+(defclass auth-source-backend ()
+ ((type :initarg :type
+ :initform 'netrc
+ :type symbol
+ :custom symbol
+ :documentation "The backend type.")
+ (source :initarg :source
+ :type string
+ :custom string
+ :documentation "The backend source.")
+ (host :initarg :host
+ :initform t
+ :type t
+ :custom string
+ :documentation "The backend host.")
+ (user :initarg :user
+ :initform t
+ :type t
+ :custom string
+ :documentation "The backend user.")
+ (port :initarg :port
+ :initform t
+ :type t
+ :custom string
+ :documentation "The backend protocol.")
+ (create-function :initarg :create-function
+ :initform ignore
+ :type function
+ :custom function
+ :documentation "The create function.")
+ (search-function :initarg :search-function
+ :initform ignore
+ :type function
+ :custom function
+ :documentation "The search function.")))
+
(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-creation-defaults nil
+ "Defaults for creating token values. Usually let-bound.")
-(defvar auth-source-cache (make-hash-table :test 'equal)
- "Cache for auth-source data")
+(defvar auth-source-creation-prompts nil
+ "Default prompts for token values. Usually let-bound.")
+
+(make-obsolete 'auth-source-hide-passwords nil "Emacs 24.1")
+
+(defcustom auth-source-save-behavior 'ask
+ "If set, auth-source will respect it for save behavior."
+ :group 'auth-source
+ :version "23.2" ;; No Gnus
+ :type `(choice
+ :tag "auth-source new token save behavior"
+ (const :tag "Always save" t)
+ (const :tag "Never save" nil)
+ (const :tag "Ask" ask)))
+
+(defvar auth-source-magic "auth-source-magic ")
(defcustom auth-source-do-cache t
- "Whether auth-source should cache information."
+ "Whether auth-source should cache information with `password-cache'."
:group 'auth-source
- :version "23.1" ;; No Gnus
+ :version "23.2" ;; No Gnus
:type `boolean)
(defcustom auth-source-debug nil
"Whether auth-source should log debug messages.
-Also see `auth-source-hide-passwords'.
If the value is nil, debug messages are not logged.
-If the value is t, debug messages are logged with `message'.
- In that case, your authentication data will be in the
- clear (except for passwords, which are always stripped out).
+
+If the value is t, debug messages are logged with `message'. In
+that case, your authentication data will be in the clear (except
+for passwords).
+
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)))
-
-(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
- :type `boolean)
+ :version "23.2" ;; No Gnus
+ :type `(choice
+ :tag "auth-source debugging mode"
+ (const :tag "Log using `message' to the *Messages* buffer" t)
+ (const :tag "Log all trivia with `message' to the *Messages* buffer"
+ trivia)
+ (function :tag "Function that takes arguments like `message'")
+ (const :tag "Don't log anything" nil)))
-(defcustom auth-sources '((:source "~/.authinfo.gpg" :host t :protocol t))
+(defcustom auth-sources '("~/.authinfo.gpg" "~/.authinfo" "~/.netrc")
"List of authentication sources.
-Each entry is the authentication type with optional properties."
+The default will get login and password information from
+\"~/.authinfo.gpg\", which you should set up with the EPA/EPG
+packages to be encrypted. If that file doesn't exist, it will
+try the unencrypted version \"~/.authinfo\" and the famous
+\"~/.netrc\" file.
+
+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 "24.1" ;; 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))))
+ (choice
+ (string :tag "Just a file")
+ (const :tag "Default Secrets API Collection" 'default)
+ (const :tag "Login Secrets API Collection" "secrets:Login")
+ (const :tag "Temp Secrets API Collection" "secrets:session")
+ (list :tag "Source definition"
+ (const :format "" :value :source)
+ (choice :tag "Authentication backend choice"
+ (string :tag "Authentication Source (file)")
+ (list
+ :tag "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"
+ (const :format "" :value :host)
+ (choice :tag "Host (machine) choice"
+ (const :tag "Any" t)
+ (regexp
+ :tag "Regular expression")))
+ (list
+ :tag "Protocol"
+ (const :format "" :value :port)
+ (choice
+ :tag "Protocol"
+ (const :tag "Any" t)
+ ,@auth-source-protocols-customize))
+ (list :tag "User" :inline t
+ (const :format "" :value :user)
+ (choice :tag "Personality/Username"
+ (const :tag "Any" t)
+ (string :tag "Name")))))))))
+
+(defcustom auth-source-gpg-encrypt-to t
+ "List of recipient keys that `authinfo.gpg' encrypted to.
+If the value is not a list, symmetric encryption will be used."
+ :group 'auth-source
+ :version "24.1" ;; No Gnus
+ :type '(choice (const :tag "Symmetric encryption" t)
+ (repeat :tag "Recipient public keys"
+ (string :tag "Recipient public key"))))
;; temp for debugging
;; (unintern 'auth-source-protocols)
@@ -129,115 +259,1167 @@ 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")
;; (auth-source-user-or-password-imap "password" "imap.myhost.com")
;; (auth-source-protocol-defaults 'imap)
-;; (let ((auth-source-debug 'debug)) (auth-source-debug "hello"))
-;; (let ((auth-source-debug t)) (auth-source-debug "hello"))
-;; (let ((auth-source-debug nil)) (auth-source-debug "hello"))
+;; (let ((auth-source-debug 'debug)) (auth-source-do-debug "hello"))
+;; (let ((auth-source-debug t)) (auth-source-do-debug "hello"))
+;; (let ((auth-source-debug nil)) (auth-source-do-debug "hello"))
(defun auth-source-do-debug (&rest msg)
- ;; set logger to either the function in auth-source-debug or 'message
- ;; note that it will be 'message if auth-source-debug is nil, so
- ;; we also check the value
(when auth-source-debug
- (let ((logger (if (functionp auth-source-debug)
- 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)
- (interactive "slogin/password: \nsHost: \nsProtocol: \n") ;for testing
- (remhash (format "%s %s:%s" mode host protocol) auth-source-cache))
+ (apply 'auth-source-do-warn msg)))
+
+(defun auth-source-do-trivia (&rest msg)
+ (when (or (eq auth-source-debug 'trivia)
+ (functionp auth-source-debug))
+ (apply 'auth-source-do-warn msg)))
+
+(defun auth-source-do-warn (&rest msg)
+ (apply
+ ;; set logger to either the function in auth-source-debug or 'message
+ ;; note that it will be 'message if auth-source-debug is nil
+ (if (functionp auth-source-debug)
+ auth-source-debug
+ 'message)
+ msg))
+
+
+;;; (auth-source-read-char-choice "enter choice? " '(?a ?b ?q))
+(defun auth-source-read-char-choice (prompt choices)
+ "Read one of CHOICES by `read-char-choice', or `read-char'.
+`dropdown-list' support is disabled because it doesn't work reliably.
+Only one of CHOICES will be returned. The PROMPT is augmented
+with \"[a/b/c] \" if CHOICES is '\(?a ?b ?c\)."
+ (when choices
+ (let* ((prompt-choices
+ (apply 'concat (loop for c in choices
+ collect (format "%c/" c))))
+ (prompt-choices (concat "[" (substring prompt-choices 0 -1) "] "))
+ (full-prompt (concat prompt prompt-choices))
+ k)
+
+ (while (not (memq k choices))
+ (setq k (cond
+ ((fboundp 'read-char-choice)
+ (read-char-choice full-prompt choices))
+ (t (message "%s" full-prompt)
+ (setq k (read-char))))))
+ k)))
+
+;; (auth-source-pick nil :host "any" :port 'imap :user "joe")
+;; (auth-source-pick t :host "any" :port 'imap :user "joe")
+;; (setq auth-sources '((:source (:secrets default) :host t :port t :user "joe")
+;; (:source (:secrets "session") :host t :port t :user "joe")
+;; (:source (:secrets "Login") :host t :port t)
+;; (:source "~/.authinfo.gpg" :host t :port t)))
+
+;; (setq auth-sources '((:source (:secrets default) :host t :port t :user "joe")
+;; (:source (:secrets "session") :host t :port t :user "joe")
+;; (:source (:secrets "Login") :host t :port t)
+;; ))
+
+;; (setq auth-sources '((:source "~/.authinfo.gpg" :host t :port t)))
+
+;; (auth-source-backend-parse "myfile.gpg")
+;; (auth-source-backend-parse 'default)
+;; (auth-source-backend-parse "secrets:Login")
+
+(defun auth-source-backend-parse (entry)
+ "Creates an auth-source-backend from an ENTRY in `auth-sources'."
+ (auth-source-backend-parse-parameters
+ entry
+ (cond
+ ;; take 'default and recurse to get it as a Secrets API default collection
+ ;; matching any user, host, and protocol
+ ((eq entry 'default)
+ (auth-source-backend-parse '(:source (:secrets default))))
+ ;; take secrets:XYZ and recurse to get it as Secrets API collection "XYZ"
+ ;; matching any user, host, and protocol
+ ((and (stringp entry) (string-match "^secrets:\\(.+\\)" entry))
+ (auth-source-backend-parse `(:source (:secrets ,(match-string 1 entry)))))
+ ;; take just a file name and recurse to get it as a netrc file
+ ;; matching any user, host, and protocol
+ ((stringp entry)
+ (auth-source-backend-parse `(:source ,entry)))
+
+ ;; a file name with parameters
+ ((stringp (plist-get entry :source))
+ (auth-source-backend
+ (plist-get entry :source)
+ :source (plist-get entry :source)
+ :type 'netrc
+ :search-function 'auth-source-netrc-search
+ :create-function 'auth-source-netrc-create))
+
+ ;; the Secrets API. We require the package, in order to have a
+ ;; defined value for `secrets-enabled'.
+ ((and
+ (not (null (plist-get entry :source))) ; the source must not be nil
+ (listp (plist-get entry :source)) ; and it must be a list
+ (require 'secrets nil t) ; and we must load the Secrets API
+ secrets-enabled) ; and that API must be enabled
+
+ ;; the source is either the :secrets key in ENTRY or
+ ;; if that's missing or nil, it's "session"
+ (let ((source (or (plist-get (plist-get entry :source) :secrets)
+ "session")))
+
+ ;; if the source is a symbol, we look for the alias named so,
+ ;; and if that alias is missing, we use "Login"
+ (when (symbolp source)
+ (setq source (or (secrets-get-alias (symbol-name source))
+ "Login")))
+
+ (if (featurep 'secrets)
+ (auth-source-backend
+ (format "Secrets API (%s)" source)
+ :source source
+ :type 'secrets
+ :search-function 'auth-source-secrets-search
+ :create-function 'auth-source-secrets-create)
+ (auth-source-do-warn
+ "auth-source-backend-parse: no Secrets API, ignoring spec: %S" entry)
+ (auth-source-backend
+ (format "Ignored Secrets API (%s)" source)
+ :source ""
+ :type 'ignore))))
+
+ ;; none of them
+ (t
+ (auth-source-do-warn
+ "auth-source-backend-parse: invalid backend spec: %S" entry)
+ (auth-source-backend
+ "Empty"
+ :source ""
+ :type 'ignore)))))
+
+(defun auth-source-backend-parse-parameters (entry backend)
+ "Fills in the extra auth-source-backend parameters of ENTRY.
+Using the plist ENTRY, get the :host, :port, and :user search
+parameters."
+ (let ((entry (if (stringp entry)
+ nil
+ entry))
+ val)
+ (when (setq val (plist-get entry :host))
+ (oset backend host val))
+ (when (setq val (plist-get entry :user))
+ (oset backend user val))
+ (when (setq val (plist-get entry :port))
+ (oset backend port val)))
+ backend)
+
+;; (mapcar 'auth-source-backend-parse auth-sources)
+
+(defun* auth-source-search (&rest spec
+ &key type max host user port secret
+ require create delete
+ &allow-other-keys)
+ "Search or modify authentication backends according to SPEC.
+
+This function parses `auth-sources' for matches of the SPEC
+plist. It can optionally create or update an authentication
+token if requested. A token is just a standard Emacs property
+list with a :secret property that can be a function; all the
+other properties will always hold scalar values.
+
+Typically the :secret property, if present, contains a password.
+
+Common search keys are :max, :host, :port, and :user. In
+addition, :create specifies how tokens will be or created.
+Finally, :type can specify which backend types you want to check.
+
+A string value is always matched literally. A symbol is matched
+as its string value, literally. All the SPEC values can be
+single values (symbol or string) or lists thereof (in which case
+any of the search terms matches).
+
+:create t means to create a token if possible.
+
+A new token will be created if no matching tokens were found.
+The new token will have only the keys the backend requires. For
+the netrc backend, for instance, that's the user, host, and
+port keys.
+
+Here's an example:
+
+\(let ((auth-source-creation-defaults '((user . \"defaultUser\")
+ (A . \"default A\"))))
+ (auth-source-search :host \"mine\" :type 'netrc :max 1
+ :P \"pppp\" :Q \"qqqq\"
+ :create t))
+
+which says:
+
+\"Search for any entry matching host 'mine' in backends of type
+ 'netrc', maximum one result.
+
+ Create a new entry if you found none. The netrc backend will
+ automatically require host, user, and port. The host will be
+ 'mine'. We prompt for the user with default 'defaultUser' and
+ for the port without a default. We will not prompt for A, Q,
+ or P. The resulting token will only have keys user, host, and
+ port.\"
+
+:create '(A B C) also means to create a token if possible.
+
+The behavior is like :create t but if the list contains any
+parameter, that parameter will be required in the resulting
+token. The value for that parameter will be obtained from the
+search parameters or from user input. If any queries are needed,
+the alist `auth-source-creation-defaults' will be checked for the
+default value. If the user, host, or port are missing, the alist
+`auth-source-creation-prompts' will be used to look up the
+prompts IN THAT ORDER (so the 'user prompt will be queried first,
+then 'host, then 'port, and finally 'secret). Each prompt string
+can use %u, %h, and %p to show the user, host, and port.
+
+Here's an example:
+
+\(let ((auth-source-creation-defaults '((user . \"defaultUser\")
+ (A . \"default A\")))
+ (auth-source-creation-prompts
+ '((password . \"Enter IMAP password for %h:%p: \"))))
+ (auth-source-search :host '(\"nonesuch\" \"twosuch\") :type 'netrc :max 1
+ :P \"pppp\" :Q \"qqqq\"
+ :create '(A B Q)))
+
+which says:
+
+\"Search for any entry matching host 'nonesuch'
+ or 'twosuch' in backends of type 'netrc', maximum one result.
+
+ Create a new entry if you found none. The netrc backend will
+ automatically require host, user, and port. The host will be
+ 'nonesuch' and Q will be 'qqqq'. We prompt for the password
+ with the shown prompt. We will not prompt for Q. The resulting
+ token will have keys user, host, port, A, B, and Q. It will not
+ have P with any value, even though P is used in the search to
+ find only entries that have P set to 'pppp'.\"
+
+When multiple values are specified in the search parameter, the
+user is prompted for which one. So :host (X Y Z) would ask the
+user to choose between X, Y, and Z.
+
+This creation can fail if the search was not specific enough to
+create a new token (it's up to the backend to decide that). You
+should `catch' the backend-specific error as usual. Some
+backends (netrc, at least) will prompt the user rather than throw
+an error.
+
+:require (A B C) means that only results that contain those
+tokens will be returned. Thus for instance requiring :secret
+will ensure that any results will actually have a :secret
+property.
+
+:delete t means to delete any found entries. nil by default.
+Use `auth-source-delete' in ELisp code instead of calling
+`auth-source-search' directly with this parameter.
+
+:type (X Y Z) will check only those backend types. 'netrc and
+'secrets are the only ones supported right now.
+
+:max N means to try to return at most N items (defaults to 1).
+When 0 the function will return just t or nil to indicate if any
+matches were found. More than N items may be returned, depending
+on the search and the backend.
+
+:host (X Y Z) means to match only hosts X, Y, or Z according to
+the match rules above. Defaults to t.
+
+:user (X Y Z) means to match only users X, Y, or Z according to
+the match rules above. Defaults to t.
+
+:port (P Q R) means to match only protocols P, Q, or R.
+Defaults to t.
+
+:K (V1 V2 V3) for any other key K will match values V1, V2, or
+V3 (note the match rules above).
+
+The return value is a list with at most :max tokens. Each token
+is a plist with keys :backend :host :port :user, plus any other
+keys provided by the backend (notably :secret). But note the
+exception for :max 0, which see above.
+
+The token can hold a :save-function key. If you call that, the
+user will be prompted to save the data to the backend. You can't
+request that this should happen right after creation, because
+`auth-source-search' has no way of knowing if the token is
+actually useful. So the caller must arrange to call this function.
+
+The token's :secret key can hold a function. In that case you
+must call it to obtain the actual value."
+ (let* ((backends (mapcar 'auth-source-backend-parse auth-sources))
+ (max (or max 1))
+ (ignored-keys '(:require :create :delete :max))
+ (keys (loop for i below (length spec) by 2
+ unless (memq (nth i spec) ignored-keys)
+ collect (nth i spec)))
+ (cached (auth-source-remembered-p spec))
+ ;; note that we may have cached results but found is still nil
+ ;; (there were no results from the search)
+ (found (auth-source-recall spec))
+ filtered-backends accessor-key backend)
+
+ (if (and cached auth-source-do-cache)
+ (auth-source-do-debug
+ "auth-source-search: found %d CACHED results matching %S"
+ (length found) spec)
+
+ (assert
+ (or (eq t create) (listp create)) t
+ "Invalid auth-source :create parameter (must be t or a list): %s %s")
+
+ (assert
+ (listp require) t
+ "Invalid auth-source :require parameter (must be a list): %s")
+
+ (setq filtered-backends (copy-sequence backends))
+ (dolist (backend backends)
+ (dolist (key keys)
+ ;; ignore invalid slots
+ (condition-case signal
+ (unless (eval `(auth-source-search-collection
+ (plist-get spec key)
+ (oref backend ,key)))
+ (setq filtered-backends (delq backend filtered-backends))
+ (return))
+ (invalid-slot-name))))
+
+ (auth-source-do-trivia
+ "auth-source-search: found %d backends matching %S"
+ (length filtered-backends) spec)
+
+ ;; (debug spec "filtered" filtered-backends)
+ ;; First go through all the backends without :create, so we can
+ ;; query them all.
+ (setq found (auth-source-search-backends filtered-backends
+ spec
+ ;; to exit early
+ max
+ ;; create is always nil here
+ nil delete
+ require))
+
+ (auth-source-do-debug
+ "auth-source-search: found %d results (max %d) matching %S"
+ (length found) max spec)
+
+ ;; If we didn't find anything, then we allow the backend(s) to
+ ;; create the entries.
+ (when (and create
+ (not found))
+ (setq found (auth-source-search-backends filtered-backends
+ spec
+ ;; to exit early
+ max
+ create delete
+ require))
+ (auth-source-do-debug
+ "auth-source-search: CREATED %d results (max %d) matching %S"
+ (length found) max spec))
+
+ ;; note we remember the lack of result too, if it's applicable
+ (when auth-source-do-cache
+ (auth-source-remember spec found)))
+
+ found))
+
+(defun auth-source-search-backends (backends spec max create delete require)
+ (let (matches)
+ (dolist (backend backends)
+ (when (> max (length matches)) ; when we need more matches...
+ (let* ((bmatches (apply
+ (slot-value backend 'search-function)
+ :backend backend
+ ;; note we're overriding whatever the spec
+ ;; has for :require, :create, and :delete
+ :require require
+ :create create
+ :delete delete
+ spec)))
+ (when bmatches
+ (auth-source-do-trivia
+ "auth-source-search-backend: got %d (max %d) in %s:%s matching %S"
+ (length bmatches) max
+ (slot-value backend :type)
+ (slot-value backend :source)
+ spec)
+ (setq matches (append matches bmatches))))))
+ matches))
+
+;;; (auth-source-search :max 1)
+;;; (funcall (plist-get (nth 0 (auth-source-search :max 1)) :secret))
+;;; (auth-source-search :host "nonesuch" :type 'netrc :K 1)
+;;; (auth-source-search :host "nonesuch" :type 'secrets)
+
+(defun* auth-source-delete (&rest spec
+ &key delete
+ &allow-other-keys)
+ "Delete entries from the authentication backends according to SPEC.
+Calls `auth-source-search' with the :delete property in SPEC set to t.
+The backend may not actually delete the entries.
+
+Returns the deleted entries."
+ (auth-source-search (plist-put spec :delete t)))
+
+(defun auth-source-search-collection (collection value)
+ "Returns t is VALUE is t or COLLECTION is t or contains VALUE."
+ (when (and (atom collection) (not (eq t collection)))
+ (setq collection (list collection)))
+
+ ;; (debug :collection collection :value value)
+ (or (eq collection t)
+ (eq value t)
+ (equal collection value)
+ (member value collection)))
(defun auth-source-forget-all-cached ()
- "Forget all cached auth-source authentication tokens."
+ "Forget all cached auth-source data."
(interactive)
- (setq auth-source-cache (make-hash-table :test 'equal)))
+ (loop for sym being the symbols of password-data
+ ;; when the symbol name starts with auth-source-magic
+ when (string-match (concat "^" auth-source-magic)
+ (symbol-name sym))
+ ;; remove that key
+ do (password-cache-remove (symbol-name sym))))
+
+(defun auth-source-remember (spec found)
+ "Remember FOUND search results for SPEC."
+ (let ((password-cache-expiry auth-source-cache-expiry))
+ (password-cache-add
+ (concat auth-source-magic (format "%S" spec)) found)))
+
+(defun auth-source-recall (spec)
+ "Recall FOUND search results for SPEC."
+ (password-read-from-cache
+ (concat auth-source-magic (format "%S" spec))))
+
+(defun auth-source-remembered-p (spec)
+ "Check if SPEC is remembered."
+ (password-in-cache-p
+ (concat auth-source-magic (format "%S" spec))))
+
+(defun auth-source-forget (spec)
+ "Forget any cached data matching SPEC exactly.
+
+This is the same SPEC you passed to `auth-source-search'.
+Returns t or nil for forgotten or not found."
+ (password-cache-remove (concat auth-source-magic (format "%S" spec))))
+
+;;; (loop for sym being the symbols of password-data when (string-match (concat "^" auth-source-magic) (symbol-name sym)) collect (symbol-name sym))
+
+;;; (auth-source-remember '(:host "wedd") '(4 5 6))
+;;; (auth-source-remembered-p '(:host "wedd"))
+;;; (auth-source-remember '(:host "xedd") '(1 2 3))
+;;; (auth-source-remembered-p '(:host "xedd"))
+;;; (auth-source-remembered-p '(:host "zedd"))
+;;; (auth-source-recall '(:host "xedd"))
+;;; (auth-source-recall '(:host t))
+;;; (auth-source-forget+ :host t)
+
+(defun* auth-source-forget+ (&rest spec &allow-other-keys)
+ "Forget any cached data matching SPEC. Returns forgotten count.
+
+This is not a full `auth-source-search' spec but works similarly.
+For instance, \(:host \"myhost\" \"yourhost\") would find all the
+cached data that was found with a search for those two hosts,
+while \(:host t) would find all host entries."
+ (let ((count 0)
+ sname)
+ (loop for sym being the symbols of password-data
+ ;; when the symbol name matches with auth-source-magic
+ when (and (setq sname (symbol-name sym))
+ (string-match (concat "^" auth-source-magic "\\(.+\\)")
+ sname)
+ ;; and the spec matches what was stored in the cache
+ (auth-source-specmatchp spec (read (match-string 1 sname))))
+ ;; remove that key
+ do (progn
+ (password-cache-remove sname)
+ (incf count)))
+ count))
+
+(defun auth-source-specmatchp (spec stored)
+ (let ((keys (loop for i below (length spec) by 2
+ collect (nth i spec))))
+ (not (eq
+ (dolist (key keys)
+ (unless (auth-source-search-collection (plist-get stored key)
+ (plist-get spec key))
+ (return 'no)))
+ 'no))))
+
+;;; (auth-source-pick-first-password :host "z.lifelogs.com")
+;;; (auth-source-pick-first-password :port "imap")
+(defun auth-source-pick-first-password (&rest spec)
+ "Pick the first secret found from applying SPEC to `auth-source-search'."
+ (let* ((result (nth 0 (apply 'auth-source-search (plist-put spec :max 1))))
+ (secret (plist-get result :secret)))
+
+ (if (functionp secret)
+ (funcall secret)
+ secret)))
+
+;; (auth-source-format-prompt "test %u %h %p" '((?u "user") (?h "host")))
+(defun auth-source-format-prompt (prompt alist)
+ "Format PROMPT using %x (for any character x) specifiers in ALIST."
+ (dolist (cell alist)
+ (let ((c (nth 0 cell))
+ (v (nth 1 cell)))
+ (when (and c v)
+ (setq prompt (replace-regexp-in-string (format "%%%c" c)
+ (format "%s" v)
+ prompt)))))
+ prompt)
+
+(defun auth-source-ensure-strings (values)
+ (unless (listp values)
+ (setq values (list values)))
+ (mapcar (lambda (value)
+ (if (numberp value)
+ (format "%s" value)
+ value))
+ values))
+
+;;; Backend specific parsing: netrc/authinfo backend
+
+(defvar auth-source-netrc-cache nil)
+
+;;; (auth-source-netrc-parse "~/.authinfo.gpg")
+(defun* auth-source-netrc-parse (&rest
+ spec
+ &key file max host user port delete require
+ &allow-other-keys)
+ "Parse FILE and return a list of all entries in the file.
+Note that the MAX parameter is used so we can exit the parse early."
+ (if (listp file)
+ ;; We got already parsed contents; just return it.
+ file
+ (when (file-exists-p file)
+ (setq port (auth-source-ensure-strings port))
+ (with-temp-buffer
+ (let* ((tokens '("machine" "host" "default" "login" "user"
+ "password" "account" "macdef" "force"
+ "port" "protocol"))
+ (max (or max 5000)) ; sanity check: default to stop at 5K
+ (modified 0)
+ (cached (cdr-safe (assoc file auth-source-netrc-cache)))
+ (cached-mtime (plist-get cached :mtime))
+ (cached-secrets (plist-get cached :secret))
+ alist elem result pair)
+
+ (if (and (functionp cached-secrets)
+ (equal cached-mtime
+ (nth 5 (file-attributes file))))
+ (progn
+ (auth-source-do-trivia
+ "auth-source-netrc-parse: using CACHED file data for %s"
+ file)
+ (insert (funcall cached-secrets)))
+ (insert-file-contents file)
+ ;; cache all netrc files (used to be just .gpg files)
+ ;; Store the contents of the file heavily encrypted in memory.
+ ;; (note for the irony-impaired: they are just obfuscated)
+ (aput 'auth-source-netrc-cache file
+ (list :mtime (nth 5 (file-attributes file))
+ :secret (lexical-let ((v (rot13-string
+ (base64-encode-string
+ (buffer-string)))))
+ (lambda () (base64-decode-string
+ (rot13-string v)))))))
+ (goto-char (point-min))
+ ;; Go through the file, line by line.
+ (while (and (not (eobp))
+ (> max 0))
+
+ (narrow-to-region (point) (point-at-eol))
+ ;; For each line, get the tokens and values.
+ (while (not (eobp))
+ (skip-chars-forward "\t ")
+ ;; Skip lines that begin with a "#".
+ (if (eq (char-after) ?#)
+ (goto-char (point-max))
+ (unless (eobp)
+ (setq elem
+ (if (= (following-char) ?\")
+ (read (current-buffer))
+ (buffer-substring
+ (point) (progn (skip-chars-forward "^\t ")
+ (point)))))
+ (cond
+ ((equal elem "macdef")
+ ;; We skip past the macro definition.
+ (widen)
+ (while (and (zerop (forward-line 1))
+ (looking-at "$")))
+ (narrow-to-region (point) (point)))
+ ((member elem tokens)
+ ;; Tokens that don't have a following value are ignored,
+ ;; except "default".
+ (when (and pair (or (cdr pair)
+ (equal (car pair) "default")))
+ (push pair alist))
+ (setq pair (list elem)))
+ (t
+ ;; Values that haven't got a preceding token are ignored.
+ (when pair
+ (setcdr pair elem)
+ (push pair alist)
+ (setq pair nil)))))))
+
+ (when (and alist
+ (> max 0)
+ (auth-source-search-collection
+ host
+ (or
+ (aget alist "machine")
+ (aget alist "host")
+ t))
+ (auth-source-search-collection
+ user
+ (or
+ (aget alist "login")
+ (aget alist "account")
+ (aget alist "user")
+ t))
+ (auth-source-search-collection
+ port
+ (or
+ (aget alist "port")
+ (aget alist "protocol")
+ t))
+ (or
+ ;; the required list of keys is nil, or
+ (null require)
+ ;; every element of require is in the normalized list
+ (let ((normalized (nth 0 (auth-source-netrc-normalize
+ (list alist)))))
+ (loop for req in require
+ always (plist-get normalized req)))))
+ (decf max)
+ (push (nreverse alist) result)
+ ;; to delete a line, we just comment it out
+ (when delete
+ (goto-char (point-min))
+ (insert "#")
+ (incf modified)))
+ (setq alist nil
+ pair nil)
+ (widen)
+ (forward-line 1))
+
+ (when (< 0 modified)
+ (when auth-source-gpg-encrypt-to
+ ;; (see bug#7487) making `epa-file-encrypt-to' local to
+ ;; this buffer lets epa-file skip the key selection query
+ ;; (see the `local-variable-p' check in
+ ;; `epa-file-write-region').
+ (unless (local-variable-p 'epa-file-encrypt-to (current-buffer))
+ (make-local-variable 'epa-file-encrypt-to))
+ (if (listp auth-source-gpg-encrypt-to)
+ (setq epa-file-encrypt-to auth-source-gpg-encrypt-to)))
+
+ ;; ask AFTER we've successfully opened the file
+ (when (y-or-n-p (format "Save file %s? (%d deletions)"
+ file modified))
+ (write-region (point-min) (point-max) file nil 'silent)
+ (auth-source-do-debug
+ "auth-source-netrc-parse: modified %d lines in %s"
+ modified file)))
+
+ (nreverse result))))))
+
+(defun auth-source-netrc-normalize (alist)
+ (mapcar (lambda (entry)
+ (let (ret item)
+ (while (setq item (pop entry))
+ (let ((k (car item))
+ (v (cdr item)))
+
+ ;; apply key aliases
+ (setq k (cond ((member k '("machine")) "host")
+ ((member k '("login" "account")) "user")
+ ((member k '("protocol")) "port")
+ ((member k '("password")) "secret")
+ (t k)))
+
+ ;; send back the secret in a function (lexical binding)
+ (when (equal k "secret")
+ (setq v (lexical-let ((v v))
+ (lambda () v))))
+
+ (setq ret (plist-put ret
+ (intern (concat ":" k))
+ v))
+ ))
+ ret))
+ alist))
+
+;;; (setq secret (plist-get (nth 0 (auth-source-search :host t :type 'netrc :K 1 :max 1)) :secret))
+;;; (funcall secret)
+
+(defun* auth-source-netrc-search (&rest
+ spec
+ &key backend require create delete
+ type max host user port
+ &allow-other-keys)
+"Given a property list SPEC, return search matches from the :backend.
+See `auth-source-search' for details on SPEC."
+ ;; just in case, check that the type is correct (null or same as the backend)
+ (assert (or (null type) (eq type (oref backend type)))
+ t "Invalid netrc search: %s %s")
+
+ (let ((results (auth-source-netrc-normalize
+ (auth-source-netrc-parse
+ :max max
+ :require require
+ :delete delete
+ :file (oref backend source)
+ :host (or host t)
+ :user (or user t)
+ :port (or port t)))))
+
+ ;; if we need to create an entry AND none were found to match
+ (when (and create
+ (not results))
+
+ ;; create based on the spec and record the value
+ (setq results (or
+ ;; if the user did not want to create the entry
+ ;; in the file, it will be returned
+ (apply (slot-value backend 'create-function) spec)
+ ;; if not, we do the search again without :create
+ ;; to get the updated data.
+
+ ;; the result will be returned, even if the search fails
+ (apply 'auth-source-netrc-search
+ (plist-put spec :create nil)))))
+ results))
-(defun auth-source-user-or-password (mode host protocol)
- "Find MODE (string or list of strings) matching HOST and PROTOCOL.
-MODE can be \"login\" or \"password\" for example."
+(defun auth-source-netrc-element-or-first (v)
+ (if (listp v)
+ (nth 0 v)
+ v))
+
+;;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t)
+;;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t :create-extra-keys '((A "default A") (B)))
+
+(defun* auth-source-netrc-create (&rest spec
+ &key backend
+ secret host user port create
+ &allow-other-keys)
+ (let* ((base-required '(host user port secret))
+ ;; we know (because of an assertion in auth-source-search) that the
+ ;; :create parameter is either t or a list (which includes nil)
+ (create-extra (if (eq t create) nil create))
+ (required (append base-required create-extra))
+ (file (oref backend source))
+ (add "")
+ ;; `valist' is an alist
+ valist
+ ;; `artificial' will be returned if no creation is needed
+ artificial)
+
+ ;; only for base required elements (defined as function parameters):
+ ;; fill in the valist with whatever data we may have from the search
+ ;; we complete the first value if it's a list and use the value otherwise
+ (dolist (br base-required)
+ (when (symbol-value br)
+ (let ((br-choice (cond
+ ;; all-accepting choice (predicate is t)
+ ((eq t (symbol-value br)) nil)
+ ;; just the value otherwise
+ (t (symbol-value br)))))
+ (when br-choice
+ (aput 'valist br br-choice)))))
+
+ ;; for extra required elements, see if the spec includes a value for them
+ (dolist (er create-extra)
+ (let ((name (concat ":" (symbol-name er)))
+ (keys (loop for i below (length spec) by 2
+ collect (nth i spec))))
+ (dolist (k keys)
+ (when (equal (symbol-name k) name)
+ (aput 'valist er (plist-get spec k))))))
+
+ ;; for each required element
+ (dolist (r required)
+ (let* ((data (aget valist r))
+ ;; take the first element if the data is a list
+ (data (auth-source-netrc-element-or-first data))
+ ;; this is the default to be offered
+ (given-default (aget auth-source-creation-defaults r))
+ ;; the default supplementals are simple:
+ ;; for the user, try `given-default' and then (user-login-name);
+ ;; otherwise take `given-default'
+ (default (cond
+ ((and (not given-default) (eq r 'user))
+ (user-login-name))
+ (t given-default)))
+ (printable-defaults (list
+ (cons 'user
+ (or
+ (auth-source-netrc-element-or-first
+ (aget valist 'user))
+ (plist-get artificial :user)
+ "[any user]"))
+ (cons 'host
+ (or
+ (auth-source-netrc-element-or-first
+ (aget valist 'host))
+ (plist-get artificial :host)
+ "[any host]"))
+ (cons 'port
+ (or
+ (auth-source-netrc-element-or-first
+ (aget valist 'port))
+ (plist-get artificial :port)
+ "[any port]"))))
+ (prompt (or (aget auth-source-creation-prompts r)
+ (case r
+ (secret "%p password for %u@%h: ")
+ (user "%p user name for %h: ")
+ (host "%p host name for user %u: ")
+ (port "%p port for %u@%h: "))
+ (format "Enter %s (%%u@%%h:%%p): " r)))
+ (prompt (auth-source-format-prompt
+ prompt
+ `((?u ,(aget printable-defaults 'user))
+ (?h ,(aget printable-defaults 'host))
+ (?p ,(aget printable-defaults 'port))))))
+
+ ;; Store the data, prompting for the password if needed.
+ (setq data
+ (cond
+ ((and (null data) (eq r 'secret))
+ ;; Special case prompt for passwords.
+ (read-passwd prompt))
+ ((null data)
+ (when default
+ (setq prompt
+ (if (string-match ": *\\'" prompt)
+ (concat (substring prompt 0 (match-beginning 0))
+ " (default " default "): ")
+ (concat prompt "(default " default ") "))))
+ (read-string prompt nil nil default))
+ (t (or data default))))
+
+ (when data
+ (setq artificial (plist-put artificial
+ (intern (concat ":" (symbol-name r)))
+ (if (eq r 'secret)
+ (lexical-let ((data data))
+ (lambda () data))
+ data))))
+
+ ;; When r is not an empty string...
+ (when (and (stringp data)
+ (< 0 (length data)))
+ ;; this function is not strictly necessary but I think it
+ ;; makes the code clearer -tzz
+ (let ((printer (lambda ()
+ ;; append the key (the symbol name of r)
+ ;; and the value in r
+ (format "%s%s %S"
+ ;; prepend a space
+ (if (zerop (length add)) "" " ")
+ ;; remap auth-source tokens to netrc
+ (case r
+ (user "login")
+ (host "machine")
+ (secret "password")
+ (port "port") ; redundant but clearer
+ (t (symbol-name r)))
+ ;; the value will be printed in %S format
+ data))))
+ (setq add (concat add (funcall printer)))))))
+
+ (plist-put
+ artificial
+ :save-function
+ (lexical-let ((file file)
+ (add add))
+ (lambda () (auth-source-netrc-saver file add))))
+
+ (list artificial)))
+
+;;(funcall (plist-get (nth 0 (auth-source-search :host '("nonesuch2") :user "tzz" :port "imap" :create t :max 1)) :save-function))
+(defun auth-source-netrc-saver (file add)
+ "Save a line ADD in FILE, prompting along the way.
+Respects `auth-source-save-behavior'. Uses
+`auth-source-netrc-cache' to avoid prompting more than once."
+ (let* ((key (format "%s %s" file (rfc2104-hash 'md5 64 16 file add)))
+ (cached (assoc key auth-source-netrc-cache)))
+
+ (if cached
+ (auth-source-do-trivia
+ "auth-source-netrc-saver: found previous run for key %s, returning"
+ key)
+ (with-temp-buffer
+ (when (file-exists-p file)
+ (insert-file-contents file))
+ (when auth-source-gpg-encrypt-to
+ ;; (see bug#7487) making `epa-file-encrypt-to' local to
+ ;; this buffer lets epa-file skip the key selection query
+ ;; (see the `local-variable-p' check in
+ ;; `epa-file-write-region').
+ (unless (local-variable-p 'epa-file-encrypt-to (current-buffer))
+ (make-local-variable 'epa-file-encrypt-to))
+ (if (listp auth-source-gpg-encrypt-to)
+ (setq epa-file-encrypt-to auth-source-gpg-encrypt-to)))
+ ;; we want the new data to be found first, so insert at beginning
+ (goto-char (point-min))
+
+ ;; Ask AFTER we've successfully opened the file.
+ (let ((prompt (format "Save auth info to file %s? " file))
+ (done (not (eq auth-source-save-behavior 'ask)))
+ (bufname "*auth-source Help*")
+ k)
+ (while (not done)
+ (setq k (auth-source-read-char-choice prompt '(?y ?n ?N ?e ??)))
+ (case k
+ (?y (setq done t))
+ (?? (save-excursion
+ (with-output-to-temp-buffer bufname
+ (princ
+ (concat "(y)es, save\n"
+ "(n)o but use the info\n"
+ "(N)o and don't ask to save again\n"
+ "(e)dit the line\n"
+ "(?) for help as you can see.\n"))
+ ;; Why? Doesn't with-output-to-temp-buffer already do
+ ;; the exact same thing anyway? --Stef
+ (set-buffer standard-output)
+ (help-mode))))
+ (?n (setq add ""
+ done t))
+ (?N (setq add ""
+ done t
+ auth-source-save-behavior nil))
+ (?e (setq add (read-string "Line to add: " add)))
+ (t nil)))
+
+ (when (get-buffer-window bufname)
+ (delete-window (get-buffer-window bufname)))
+
+ ;; Make sure the info is not saved.
+ (when (null auth-source-save-behavior)
+ (setq add ""))
+
+ (when (< 0 (length add))
+ (progn
+ (unless (bolp)
+ (insert "\n"))
+ (insert add "\n")
+ (write-region (point-min) (point-max) file nil 'silent)
+ (auth-source-do-debug
+ "auth-source-netrc-create: wrote 1 new line to %s"
+ file)
+ (message "Saved new authentication information to %s" file)
+ nil))))
+ (aput 'auth-source-netrc-cache key "ran"))))
+
+;;; Backend specific parsing: Secrets API backend
+
+;;; (let ((auth-sources '(default))) (auth-source-search :max 1 :create t))
+;;; (let ((auth-sources '(default))) (auth-source-search :max 1 :delete t))
+;;; (let ((auth-sources '(default))) (auth-source-search :max 1))
+;;; (let ((auth-sources '(default))) (auth-source-search))
+;;; (let ((auth-sources '("secrets:Login"))) (auth-source-search :max 1))
+;;; (let ((auth-sources '("secrets:Login"))) (auth-source-search :max 1 :signon_realm "https://git.gnus.org/Git"))
+
+(defun* auth-source-secrets-search (&rest
+ spec
+ &key backend create delete label
+ type max host user port
+ &allow-other-keys)
+ "Search the Secrets API; spec is like `auth-source'.
+
+The :label key specifies the item's label. It is the only key
+that can specify a substring. Any :label value besides a string
+will allow any label.
+
+All other search keys must match exactly. If you need substring
+matching, do a wider search and narrow it down yourself.
+
+You'll get back all the properties of the token as a plist.
+
+Here's an example that looks for the first item in the 'Login'
+Secrets collection:
+
+ \(let ((auth-sources '(\"secrets:Login\")))
+ (auth-source-search :max 1)
+
+Here's another that looks for the first item in the 'Login'
+Secrets collection whose label contains 'gnus':
+
+ \(let ((auth-sources '(\"secrets:Login\")))
+ (auth-source-search :max 1 :label \"gnus\")
+
+And this one looks for the first item in the 'Login' Secrets
+collection that's a Google Chrome entry for the git.gnus.org site
+authentication tokens:
+
+ \(let ((auth-sources '(\"secrets:Login\")))
+ (auth-source-search :max 1 :signon_realm \"https://git.gnus.org/Git\"))
+"
+
+ ;; TODO
+ (assert (not create) nil
+ "The Secrets API auth-source backend doesn't support creation yet")
+ ;; TODO
+ ;; (secrets-delete-item coll elt)
+ (assert (not delete) nil
+ "The Secrets API auth-source backend doesn't support deletion yet")
+
+ (let* ((coll (oref backend source))
+ (max (or max 5000)) ; sanity check: default to stop at 5K
+ (ignored-keys '(:create :delete :max :backend :label))
+ (search-keys (loop for i below (length spec) by 2
+ unless (memq (nth i spec) ignored-keys)
+ collect (nth i spec)))
+ ;; build a search spec without the ignored keys
+ ;; if a search key is nil or t (match anything), we skip it
+ (search-spec (apply 'append (mapcar
+ (lambda (k)
+ (if (or (null (plist-get spec k))
+ (eq t (plist-get spec k)))
+ nil
+ (list k (plist-get spec k))))
+ search-keys)))
+ ;; needed keys (always including host, login, port, and secret)
+ (returned-keys (mm-delete-duplicates (append
+ '(:host :login :port :secret)
+ search-keys)))
+ (items (loop for item in (apply 'secrets-search-items coll search-spec)
+ unless (and (stringp label)
+ (not (string-match label item)))
+ collect item))
+ ;; TODO: respect max in `secrets-search-items', not after the fact
+ (items (butlast items (- (length items) max)))
+ ;; convert the item name to a full plist
+ (items (mapcar (lambda (item)
+ (append
+ ;; make an entry for the secret (password) element
+ (list
+ :secret
+ (lexical-let ((v (secrets-get-secret coll item)))
+ (lambda () v)))
+ ;; rewrite the entry from ((k1 v1) (k2 v2)) to plist
+ (apply 'append
+ (mapcar (lambda (entry)
+ (list (car entry) (cdr entry)))
+ (secrets-get-attributes coll item)))))
+ items))
+ ;; ensure each item has each key in `returned-keys'
+ (items (mapcar (lambda (plist)
+ (append
+ (apply 'append
+ (mapcar (lambda (req)
+ (if (plist-get plist req)
+ nil
+ (list req nil)))
+ returned-keys))
+ plist))
+ items)))
+ items))
+
+(defun* auth-source-secrets-create (&rest
+ spec
+ &key backend type max host user port
+ &allow-other-keys)
+ ;; TODO
+ ;; (apply 'secrets-create-item (auth-get-source entry) name passwd spec)
+ (debug spec))
+
+;;; older API
+
+;;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" t "tzz")
+
+;; deprecate the old interface
+(make-obsolete 'auth-source-user-or-password
+ 'auth-source-search "Emacs 24.1")
+(make-obsolete 'auth-source-forget-user-or-password
+ 'auth-source-forget "Emacs 24.1")
+
+(defun auth-source-user-or-password
+ (mode host port &optional username create-missing delete-existing)
+ "Find MODE (string or list of strings) matching HOST and PORT.
+
+DEPRECATED in favor of `auth-source-search'!
+
+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: DEPRECATED get %s for %s (%s) + user=%s"
+ mode host port 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 port username)
+ (format "%s %s:%s" mode host port)))
+ (search (list :host host :port port))
+ (search (if username (append search (list :user username)) search))
+ (search (if create-missing
+ (append search (list :create t))
+ search))
+ (search (if delete-existing
+ (append search (list :delete t))
+ search))
+ ;; (found (if (not delete-existing)
+ ;; (gethash cname auth-source-cache)
+ ;; (remhash cname auth-source-cache)
+ ;; nil)))
+ (found 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)))))
-
-(defun auth-source-protocol-defaults (protocol)
- "Return a list of default ports and names for PROTOCOL."
- (cdr-safe (assoc protocol auth-source-protocols)))
-
-(defun auth-source-user-or-password-imap (mode host)
- (auth-source-user-or-password mode host 'imap))
-
-(defun auth-source-user-or-password-pop3 (mode host)
- (auth-source-user-or-password mode host 'pop3))
-
-(defun auth-source-user-or-password-ssh (mode host)
- (auth-source-user-or-password mode host 'ssh))
-
-(defun auth-source-user-or-password-sftp (mode host)
- (auth-source-user-or-password mode host 'sftp))
-
-(defun auth-source-user-or-password-smtp (mode host)
- (auth-source-user-or-password mode host 'smtp))
+ (progn
+ (auth-source-do-debug
+ "auth-source-user-or-password: DEPRECATED cached %s=%s for %s (%s) + %s"
+ mode
+ ;; don't show the password
+ (if (and (member "password" mode) t)
+ "SECRET"
+ found)
+ host port username)
+ found) ; return the found data
+ ;; else, if not found, search with a max of 1
+ (let ((choice (nth 0 (apply 'auth-source-search
+ (append '(:max 1) search)))))
+ (when choice
+ (dolist (m mode)
+ (cond
+ ((equal "password" m)
+ (push (if (plist-get choice :secret)
+ (funcall (plist-get choice :secret))
+ nil) found))
+ ((equal "login" m)
+ (push (plist-get choice :user) found)))))
+ (setq found (nreverse found))
+ (setq found (if listy found (car-safe found)))))
+
+ found))
(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 008ef19cfec..5727bef37ef 100644
--- a/lisp/gnus/canlock.el
+++ b/lisp/gnus/canlock.el
@@ -1,7 +1,6 @@
;;; canlock.el --- functions for Cancel-Lock feature
-;; Copyright (C) 1998, 1999, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-1999, 2001-2011 Free Software Foundation, Inc.
;; Author: Katsumi Yamaoka <yamaoka@jpl.org>
;; Keywords: news, cancel-lock, hmac, sha1, rfc2104
@@ -247,5 +246,4 @@ it fails."
(provide 'canlock)
-;; arch-tag: 033c4f09-b9f1-459d-bd0d-254430283f78
;;; canlock.el ends here
diff --git a/lisp/gnus/compface.el b/lisp/gnus/compface.el
index 5a74561ae95..2a2383777cb 100644
--- a/lisp/gnus/compface.el
+++ b/lisp/gnus/compface.el
@@ -1,6 +1,6 @@
;;; compface.el --- functions for converting X-Face headers
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -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 d6f1624795a..1e2a566f72d 100644
--- a/lisp/gnus/deuglify.el
+++ b/lisp/gnus/deuglify.el
@@ -1,7 +1,6 @@
;;; deuglify.el --- deuglify broken Outlook (Express) articles
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;; Author: Raymond Scholz <rscholz@zonix.de>
;; Thomas Steffen
@@ -476,5 +475,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 3299d167d1e..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, 2011 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 993f1367397..6a47b119f10 100644
--- a/lisp/gnus/ecomplete.el
+++ b/lisp/gnus/ecomplete.el
@@ -1,6 +1,6 @@
;;; ecomplete.el --- electric completion of addresses and the like
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: mail
@@ -27,11 +27,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 +56,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 +89,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 +150,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 2171c0b3aed..cdaebbd6837 100644
--- a/lisp/gnus/flow-fill.el
+++ b/lisp/gnus/flow-fill.el
@@ -1,7 +1,6 @@
;;; flow-fill.el --- interpret RFC2646 "flowed" text
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Author: Simon Josefsson <jas@pdc.kth.se>
;; Keywords: mail
@@ -82,23 +81,41 @@ RFC 2646 suggests 66 characters for readability."
;; Go through each paragraph, filling it and adding SPC
;; as the last character on each line.
(while (setq end (text-property-any start (point-max) 'hard 't))
- (let ((fill-column (eval fill-flowed-encode-column)))
- (fill-region start end t 'nosqueeze 'to-eop))
- (goto-char start)
- ;; `fill-region' probably distorted end.
- (setq end (text-property-any start (point-max) 'hard 't))
- (while (and (< (point) end)
- (re-search-forward "$" (1- end) t))
- (insert " ")
- (setq end (1+ end))
- (forward-char))
- (goto-char (setq start (1+ end)))))
+ (save-restriction
+ (narrow-to-region start end)
+ (let ((fill-column (eval fill-flowed-encode-column)))
+ (fill-flowed-fill-buffer))
+ (goto-char (point-min))
+ (while (re-search-forward "\n" nil t)
+ (replace-match " \n" t t))
+ (goto-char (setq start (1+ (point-max)))))))
t)))
+(defun fill-flowed-fill-buffer ()
+ (let ((prefix nil)
+ (prev-prefix nil)
+ (start (point-min)))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (setq prefix (and (looking-at "[> ]+")
+ (match-string 0)))
+ (if (equal prefix prev-prefix)
+ (forward-line 1)
+ (save-restriction
+ (narrow-to-region start (point))
+ (let ((fill-prefix prev-prefix))
+ (fill-region (point-min) (point-max) t 'nosqueeze 'to-eop))
+ (goto-char (point-max)))
+ (setq prev-prefix prefix
+ start (point))))
+ (save-restriction
+ (narrow-to-region start (point))
+ (let ((fill-prefix prev-prefix))
+ (fill-region (point-min) (point-max) t 'nosqueeze 'to-eop)))))
+
;;;###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)
@@ -106,8 +123,6 @@ RFC 2646 suggests 66 characters for readability."
(forward-line 1))
(goto-char (point-min))
(while (re-search-forward " $" nil t)
- (when delete-space
- (delete-char -1))
(when (save-excursion
(beginning-of-line)
(looking-at "^\\(>*\\)\\( ?\\)"))
@@ -135,6 +150,8 @@ RFC 2646 suggests 66 characters for readability."
(replace-match (if (string= (match-string 2) " ")
"" "\\2")))
(backward-delete-char -1)
+ (when delete-space
+ (delete-char -1))
(end-of-line))
(unless sig
(condition-case nil
@@ -221,5 +238,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 cb0b6c27bd1..8deb27379a3 100644
--- a/lisp/gnus/gmm-utils.el
+++ b/lisp/gnus/gmm-utils.el
@@ -1,6 +1,6 @@
;;; gmm-utils.el --- Utility functions for Gnus, Message and MML
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
;; Author: Reiner Steib <reiner.steib@gmx.de>
;; Keywords: news
@@ -28,8 +28,6 @@
;;; Code:
-(require 'wid-edit)
-
(defgroup gmm nil
"Utility functions for Gnus, Message and MML."
:prefix "gmm-"
@@ -95,6 +93,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 +267,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 +411,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 b03274d8cdf..b4f0dc38e7e 100644
--- a/lisp/gnus/gnus-agent.el
+++ b/lisp/gnus/gnus-agent.el
@@ -1,7 +1,6 @@
;;; gnus-agent.el --- unplugged support for Gnus
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; This file is part of GNU Emacs.
@@ -184,7 +183,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'."
@@ -203,8 +202,7 @@ queue. Otherwise, queue if and only if unplugged."
(const :format "When unplugged" t)))
(defcustom gnus-agent-prompt-send-queue nil
- "If non-nil, `gnus-group-send-queue' will prompt if called when
-unplugged."
+ "If non-nil, `gnus-group-send-queue' will prompt if called when unplugged."
:version "22.1"
:group 'gnus-agent
:type 'boolean)
@@ -305,8 +303,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 +457,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 +468,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 +511,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 +601,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)
@@ -693,7 +683,6 @@ This will modify the `gnus-setup-news-hook', and
minor mode in all Gnus buffers."
(interactive)
(gnus-open-agent)
- (add-hook 'gnus-setup-news-hook 'gnus-agent-queue-setup)
(unless gnus-agent-send-mail-function
(setq gnus-agent-send-mail-function
(or message-send-mail-real-function
@@ -703,7 +692,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)
@@ -738,7 +729,8 @@ Optional arg GROUP-NAME allows to specify another group."
(concat "^" (regexp-quote mail-header-separator) "\n"))
(replace-match "\n")
(gnus-agent-insert-meta-information 'mail)
- (gnus-request-accept-article "nndraft:queue" nil t t)))
+ (gnus-request-accept-article "nndraft:queue" nil t t)
+ (gnus-group-refresh-group "nndraft:queue")))
(defun gnus-agent-insert-meta-information (type &optional method)
"Insert meta-information into the message that says how it's to be posted.
@@ -809,23 +801,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 +1024,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))))
@@ -1519,7 +1512,7 @@ downloaded into the agent."
"Fetch ARTICLES from GROUP and put them into the Agent."
(when articles
(gnus-agent-load-alist group)
- (let* ((alist gnus-agent-article-alist)
+ (let* ((alist gnus-agent-article-alist)
(headers (if (< (length articles) 2) nil gnus-newsgroup-headers))
(selected-sets (list nil))
(current-set-size 0)
@@ -1561,9 +1554,9 @@ downloaded into the agent."
;; 65 char/line. If the line count
;; is missing, arbitrarily assume a
;; size of 1000 characters.
- (max (* 65 (mail-header-lines
- (car headers)))
- 1000)
+ (max (* 65 (mail-header-lines
+ (car headers)))
+ 1000)
char-size))
0))))
(setcar selected-sets (nreverse (car selected-sets)))
@@ -1583,7 +1576,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 +1588,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 +1601,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 +1685,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 +1696,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 +1778,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
@@ -1933,16 +1925,16 @@ article numbers will be returned."
(setq articles (gnus-list-range-intersection
articles (list (cons low high)))))))
- (gnus-message
- 10 "gnus-agent-fetch-headers: undownloaded articles are '%s'"
- (gnus-compress-sequence articles t))
-
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (when articles
+ (gnus-message
+ 10 "gnus-agent-fetch-headers: undownloaded articles are '%s'"
+ (gnus-compress-sequence articles t)))
+ (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 +2097,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 +2153,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 +2221,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 +2349,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 +2373,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 +2639,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 +2755,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 +3119,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 +3252,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 +3544,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 +3628,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 +3751,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
@@ -3878,6 +3876,15 @@ has been fetched."
(insert-file-contents file))
t))))
+(defun gnus-agent-store-article (article group)
+ (let* ((gnus-command-method (gnus-find-method-for-group group))
+ (file (gnus-agent-article-name (number-to-string article) group))
+ (file-name-coding-system nnmail-pathname-coding-system)
+ (coding-system-for-write gnus-cache-coding-system))
+ (when (not (file-exists-p file))
+ (gnus-make-directory (file-name-directory file))
+ (write-region (point-min) (point-max) file nil 'silent))))
+
(defun gnus-agent-regenerate-group (group &optional reread)
"Regenerate GROUP.
If REREAD is t, all articles in the .overview are marked as unread.
@@ -3904,7 +3911,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 +3988,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 +4230,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 dcf7ab16e6e..5ba962d1d39 100644
--- a/lisp/gnus/gnus-art.el
+++ b/lisp/gnus/gnus-art.el
@@ -1,7 +1,6 @@
;;; gnus-art.el --- article mode commands for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -25,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))))
(eval-when-compile
@@ -34,10 +33,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)
@@ -48,6 +44,7 @@
(require 'wid-edit)
(require 'mm-uu)
(require 'message)
+(require 'mouse)
(autoload 'gnus-msg-mail "gnus-msg" nil t)
(autoload 'gnus-button-mailto "gnus-msg")
@@ -172,7 +169,7 @@ If `gnus-visible-headers' is non-nil, this variable will be ignored."
:group 'gnus-article-hiding)
(defcustom gnus-visible-headers
- "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Mail-Followup-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|^X-Sent:"
+ "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Mail-Followup-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:"
"*All headers that do not match this regexp will be hidden.
This variable can also be a list of regexp of headers to remain visible.
If this variable is non-nil, `gnus-ignored-headers' will be ignored."
@@ -687,7 +684,7 @@ beginning of a line."
:type 'regexp
:group 'gnus-article-various)
-(defcustom gnus-article-mode-line-format "Gnus: %g [%w] %S%m"
+(defcustom gnus-article-mode-line-format "Gnus: %g %S%m"
"*The format specification for the article mode line.
See `gnus-summary-mode-line-format' for a closer description.
@@ -695,6 +692,7 @@ The following additional specs are available:
%w The article washing status.
%m The number of MIME parts in the article."
+ :version "24.1"
:type 'string
:group 'gnus-article-various)
@@ -728,7 +726,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 +917,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
@@ -1018,14 +1016,38 @@ on parts -- for instance, adding Vcard info to a database."
:group 'gnus-article-mime
:type '(repeat (cons :format "%v" (string :tag "MIME type") function)))
-(defcustom gnus-article-date-lapsed-new-header nil
- "Whether the X-Sent and Date headers can coexist.
-When using `gnus-treat-date-lapsed', the \"X-Sent:\" header will
-either replace the old \"Date:\" header (if this variable is nil), or
-be added below it (otherwise)."
- :version "21.1"
+(defcustom gnus-article-date-headers '(combined-lapsed)
+ "A list of Date header formats to display.
+Valid formats are `ut' (universal time), `local' (local time
+zone), `english' (readable English), `lapsed' (elapsed time),
+`combined-lapsed' (both the original date and the elapsed time),
+`original' (the original date header), `iso8601' (ISO8601
+format), and `user-defined' (a user-defined format defined by the
+`gnus-article-time-format' variable).
+
+You have as many date headers as you want in the article buffer.
+Some of these headers are updated automatically. See
+`gnus-article-update-date-headers' for details."
+ :version "24.1"
:group 'gnus-article-headers
- :type 'boolean)
+ :type '(repeat
+ (item :tag "Universal time (UT)" :value 'ut)
+ (item :tag "Local time zone" :value 'local)
+ (item :tag "Readable English" :value 'english)
+ (item :tag "Elapsed time" :value 'lapsed)
+ (item :tag "Original and elapsed time" :value 'combined-lapsed)
+ (item :tag "Original date header" :value 'original)
+ (item :tag "ISO8601 format" :value 'iso8601)
+ (item :tag "User-defined" :value 'user-defined)))
+
+(defcustom gnus-article-update-date-headers 1
+ "A number that says how often to update the date header (in seconds).
+If nil, don't update it at all."
+ :version "24.1"
+ :group 'gnus-article-headers
+ :type '(choice
+ (item :tag "Don't update" :value nil)
+ integer))
(defcustom gnus-article-mime-match-handle-function 'undisplayed-alternative
"Function called with a MIME handle as the argument.
@@ -1130,6 +1152,15 @@ predicate. See Info node `(gnus)Customizing Articles'."
:type gnus-article-treat-head-custom)
(put 'gnus-treat-buttonize-head 'highlight t)
+(defcustom gnus-treat-date 'head
+ "Display dates according to the `gnus-article-date-headers' variable.
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
+ :version "24.1"
+ :group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
+ :type gnus-article-treat-head-custom)
+
(defcustom gnus-treat-emphasize 50000
"Emphasize text.
Valid values are nil, t, `head', `first', `last', an integer or a
@@ -1223,6 +1254,24 @@ predicate. See Info node `(gnus)Customizing Articles'."
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
+(gnus-define-group-parameter
+ list-identifier
+ :variable-document
+ "Alist of regexps and correspondent identifiers."
+ :variable-group gnus-article-washing
+ :parameter-type
+ '(choice :tag "Identifier"
+ :value nil
+ (symbol :tag "Item in `gnus-list-identifiers'" none)
+ regexp
+ (const :tag "None" nil))
+ :parameter-document
+ "If non-nil, specify how to remove `identifiers' from articles' subject.
+
+Any symbol is used to look up a regular expression to match the
+banner in `gnus-list-identifiers'. A string is used as a regular
+expression to match the identifier directly.")
+
(make-obsolete-variable 'gnus-treat-strip-pgp nil
"Gnus 5.10 (Emacs 22.1)")
@@ -1261,65 +1310,6 @@ predicate. See Info node `(gnus)Customizing Articles'."
:type gnus-article-treat-custom)
(put 'gnus-treat-highlight-citation 'highlight t)
-(defcustom gnus-treat-date-ut nil
- "Display the Date in UT (GMT).
-Valid values are nil, t, `head', `first', `last', an integer or a
-predicate. See Info node `(gnus)Customizing Articles'."
- :group 'gnus-article-treat
- :link '(custom-manual "(gnus)Customizing Articles")
- :type gnus-article-treat-head-custom)
-
-(defcustom gnus-treat-date-local nil
- "Display the Date in the local timezone.
-Valid values are nil, t, `head', `first', `last', an integer or a
-predicate. See Info node `(gnus)Customizing Articles'."
- :group 'gnus-article-treat
- :link '(custom-manual "(gnus)Customizing Articles")
- :type gnus-article-treat-head-custom)
-
-(defcustom gnus-treat-date-english nil
- "Display the Date in a format that can be read aloud in English.
-Valid values are nil, t, `head', `first', `last', an integer or a
-predicate. See Info node `(gnus)Customizing Articles'."
- :version "22.1"
- :group 'gnus-article-treat
- :link '(custom-manual "(gnus)Customizing Articles")
- :type gnus-article-treat-head-custom)
-
-(defcustom gnus-treat-date-lapsed nil
- "Display the Date header in a way that says how much time has elapsed.
-Valid values are nil, t, `head', `first', `last', an integer or a
-predicate. See Info node `(gnus)Customizing Articles'."
- :group 'gnus-article-treat
- :link '(custom-manual "(gnus)Customizing Articles")
- :type gnus-article-treat-head-custom)
-
-(defcustom gnus-treat-date-original nil
- "Display the date in the original timezone.
-Valid values are nil, t, `head', `first', `last', an integer or a
-predicate. See Info node `(gnus)Customizing Articles'."
- :group 'gnus-article-treat
- :link '(custom-manual "(gnus)Customizing Articles")
- :type gnus-article-treat-head-custom)
-
-(defcustom gnus-treat-date-iso8601 nil
- "Display the date in the ISO8601 format.
-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-head-custom)
-
-(defcustom gnus-treat-date-user-defined nil
- "Display the date in a user-defined format.
-The format is defined by the `gnus-article-time-format' variable.
-Valid values are nil, t, `head', `first', `last', an integer or a
-predicate. See Info node `(gnus)Customizing Articles'."
- :group 'gnus-article-treat
- :link '(custom-manual "(gnus)Customizing Articles")
- :type gnus-article-treat-head-custom)
-
(defcustom gnus-treat-strip-headers-in-body t
"Strip the X-No-Archive header line from the beginning of the body.
Valid values are nil, t, `head', `first', `last', an integer or a
@@ -1415,7 +1405,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 +1522,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,28 +1583,11 @@ 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'."
- :group 'gnus-article-treat
- :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"
+ :version "24.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
@@ -1614,9 +1615,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 +1630,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,16 +1664,9 @@ 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)
- (gnus-treat-date-local gnus-article-date-local)
- (gnus-treat-date-english gnus-article-date-english)
- (gnus-treat-date-original gnus-article-date-original)
- (gnus-treat-date-user-defined gnus-article-date-user)
- (gnus-treat-date-iso8601 gnus-article-date-iso8601)
- (gnus-treat-date-lapsed gnus-article-date-lapsed)
(gnus-treat-display-x-face gnus-article-display-x-face)
(gnus-treat-display-face gnus-article-display-face)
(gnus-treat-hide-headers gnus-article-maybe-hide-headers)
@@ -1668,10 +1674,13 @@ 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-date gnus-article-treat-date)
+ (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 +1702,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)
@@ -1736,9 +1744,10 @@ Initialized from `text-mode-syntax-table.")
(put 'gnus-with-article-headers 'edebug-form-spec '(body))
(defmacro gnus-with-article-buffer (&rest forms)
- `(with-current-buffer gnus-article-buffer
- (let ((inhibit-read-only t))
- ,@forms)))
+ `(when (buffer-live-p (get-buffer gnus-article-buffer))
+ (with-current-buffer gnus-article-buffer
+ (let ((inhibit-read-only t))
+ ,@forms))))
(put 'gnus-with-article-buffer 'lisp-indent-function 0)
(put 'gnus-with-article-buffer 'edebug-form-spec '(body))
@@ -2100,6 +2109,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 +2162,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."
@@ -2216,8 +2263,23 @@ unfolded."
"Remove all images from the article buffer."
(interactive)
(gnus-with-article-buffer
- (dolist (elem gnus-article-image-alist)
- (gnus-delete-images (car elem)))))
+ (save-restriction
+ (widen)
+ (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
+ (save-restriction
+ (widen)
+ (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.
@@ -2276,10 +2338,12 @@ long lines if and only if arg is positive."
(let ((start (point)))
(insert "X-Boundary: ")
(gnus-add-text-properties start (point) '(invisible t intangible t))
- (insert (let (str)
- (while (>= (1- (window-width)) (length str))
+ (insert (let (str (max (window-width)))
+ (if (featurep 'xemacs)
+ (setq max (1- max)))
+ (while (>= max (length str))
(setq str (concat str gnus-body-boundary-delimiter)))
- (substring str 0 (1- (window-width))))
+ (substring str 0 max))
"\n")
(gnus-put-text-property start (point) 'gnus-decoration 'header)))))
@@ -2671,118 +2735,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 +2768,63 @@ 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 (mm-handle-filename handle)
+ (concat
+ (make-temp-name "cid")
+ (car (rassoc (car (mm-handle-type handle)) 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:
@@ -2838,10 +2832,7 @@ message header will be added to the bodies of the \"text/html\" parts."
((or (equal (car (setq type (mm-handle-type handle))) "text/html")
(and (equal (car type) "message/external-body")
(or header
- (setq file (or (mail-content-type-get type 'name)
- (mail-content-type-get
- (mm-handle-disposition handle)
- 'filename))))
+ (setq file (mm-handle-filename handle)))
(or (mm-handle-cache handle)
(condition-case code
(progn (mm-extern-cache-contents handle) t)
@@ -2853,16 +2844,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 +2902,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 +2924,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 +2933,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 +2966,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 +3015,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
@@ -3048,10 +3071,8 @@ If you always want to display HTML parts in the browser, set
The `gnus-list-identifiers' variable specifies what to do."
(interactive)
(let ((inhibit-point-motion-hooks t)
- (regexp (if (consp gnus-list-identifiers)
- (mapconcat 'identity gnus-list-identifiers " *\\|")
- gnus-list-identifiers))
- (inhibit-read-only t))
+ (regexp (gnus-group-get-list-identifiers gnus-newsgroup-name))
+ (inhibit-read-only t))
(when regexp
(save-excursion
(save-restriction
@@ -3385,87 +3406,82 @@ lines forward."
(forward-line 1)
(setq ended t)))))
-(defun article-date-ut (&optional type highlight)
- "Convert DATE date to universal time in the current article.
-If TYPE is `local', convert to local time; if it is `lapsed', output
-how much time has lapsed since DATE. For `lapsed', the value of
-`gnus-article-date-lapsed-new-header' says whether the \"X-Sent:\" header
-should replace the \"Date:\" one, or should be added below it."
+(defun article-treat-date ()
+ (article-date-ut (if (gnus-buffer-live-p gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
+ gnus-article-date-headers)
+ gnus-article-date-headers)
+ t))
+
+(defun article-date-ut (&optional type highlight date-position)
+ "Convert DATE date to TYPE in the current article.
+The default type is `ut'. See `gnus-article-date-headers' for
+possible values."
(interactive (list 'ut t))
- (let* ((tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
- (date-regexp (cond ((not gnus-article-date-lapsed-new-header)
- tdate-regexp)
- ((eq type 'lapsed)
- "^X-Sent:[ \t]")
- (article-lapsed-timer
- "^Date:[ \t]")
- (t
- tdate-regexp)))
- (case-fold-search t)
+ (let* ((case-fold-search t)
(inhibit-read-only t)
(inhibit-point-motion-hooks t)
+ (first t)
+ (visible-date (mail-fetch-field "Date"))
pos date bface eface)
(save-excursion
(save-restriction
- (widen)
(goto-char (point-min))
- (while (or (setq date (get-text-property (setq pos (point))
- 'original-date))
- (when (setq pos (next-single-property-change
- (point) 'original-date))
- (setq date (get-text-property pos 'original-date))
- t))
- (narrow-to-region
- pos (if (setq pos (text-property-any pos (point-max)
- 'original-date nil))
- (progn
- (goto-char pos)
- (if (or (bolp) (eobp))
- (point)
- (1+ (point))))
- (point-max)))
- (goto-char (point-min))
- (when (re-search-forward tdate-regexp nil t)
- (setq bface (get-text-property (point-at-bol) 'face)
- eface (get-text-property (1- (point-at-eol)) 'face)))
- (goto-char (point-min))
- (setq pos nil)
- ;; Delete any old Date headers.
- (while (re-search-forward date-regexp nil t)
- (if pos
- (delete-region (point-at-bol) (progn
- (gnus-article-forward-header)
- (point)))
- (delete-region (point-at-bol) (progn
- (gnus-article-forward-header)
- (forward-char -1)
- (point)))
- (setq pos (point))))
- (when (and (not pos)
- (re-search-forward tdate-regexp nil t))
- (forward-line 1))
- (gnus-goto-char pos)
- (insert (article-make-date-line date (or type 'ut)))
- (unless pos
- (insert "\n")
- (forward-line -1))
- ;; Do highlighting.
- (beginning-of-line)
- (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
- (put-text-property (match-beginning 1) (1+ (match-end 1))
- 'face bface)
- (put-text-property (match-beginning 2) (match-end 2)
- 'face eface))
- (put-text-property (point-min) (1- (point-max)) 'original-date date)
- (goto-char (point-max))
- (widen))))))
+ (when (re-search-forward "^Date:" nil t)
+ (setq bface (get-text-property (point-at-bol) 'face)
+ eface (get-text-property (1- (point-at-eol)) 'face)))
+ (goto-char (point-min))
+ ;; Delete any old Date headers.
+ (if date-position
+ (progn
+ (goto-char date-position)
+ (setq date (get-text-property (point) 'original-date))
+ (delete-region (point)
+ (progn
+ (gnus-article-forward-header)
+ (point)))
+ (article-transform-date date type bface eface))
+ (while (re-search-forward "^Date:" nil t)
+ (setq date (get-text-property (match-beginning 0) 'original-date))
+ (delete-region (point-at-bol) (progn
+ (gnus-article-forward-header)
+ (point))))
+ (when (and (not date)
+ visible-date)
+ (setq date visible-date))
+ (when date
+ (article-transform-date date type bface eface)))))))
+
+(defun article-transform-date (date type bface eface)
+ (dolist (this-type (cond
+ ((null type)
+ (list 'ut))
+ ((atom type)
+ (list type))
+ (t
+ type)))
+ (insert (article-make-date-line date (or this-type 'ut)) "\n")
+ (forward-line -1)
+ (beginning-of-line)
+ (put-text-property (point) (1+ (point))
+ 'original-date date)
+ (put-text-property (point) (1+ (point))
+ 'gnus-date-type this-type)
+ ;; Do highlighting.
+ (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
+ (put-text-property (match-beginning 1) (1+ (match-end 1))
+ 'face bface)
+ (put-text-property (match-beginning 2) (match-end 2)
+ 'face eface))
+ (forward-line 1)))
(defun article-make-date-line (date type)
"Return a DATE line of TYPE."
- (unless (memq type '(local ut original user iso8601 lapsed english))
+ (unless (memq type '(local ut original user-defined iso8601 lapsed english
+ combined-lapsed))
(error "Unknown conversion type: %s" type))
(condition-case ()
- (let ((time (date-to-time date)))
+ (let ((time (ignore-errors (date-to-time date))))
(cond
;; Convert to the local timezone.
((eq type 'local)
@@ -3490,7 +3506,7 @@ should replace the \"Date:\" one, or should be added below it."
(substring date 0 (match-beginning 0))
date)))
;; Let the user define the format.
- ((eq type 'user)
+ ((eq type 'user-defined)
(let ((format (or (condition-case nil
(with-current-buffer gnus-summary-buffer
gnus-article-time-format)
@@ -3508,49 +3524,26 @@ should replace the \"Date:\" one, or should be added below it."
(format "%s%02d%02d"
(if (> tz 0) "+" "-") (/ (abs tz) 3600)
(/ (% (abs tz) 3600) 60)))))
- ;; Do an X-Sent lapsed format.
+ ;; Do a lapsed format.
((eq type 'lapsed)
- ;; If the date is seriously mangled, the timezone functions are
- ;; liable to bug out, so we ignore all errors.
- (let* ((now (current-time))
- (real-time (subtract-time now time))
- (real-sec (and real-time
- (+ (* (float (car real-time)) 65536)
- (cadr real-time))))
- (sec (and real-time (abs real-sec)))
- num prev)
- (cond
- ((null real-time)
- "X-Sent: Unknown")
- ((zerop sec)
- "X-Sent: Now")
- (t
- (concat
- "X-Sent: "
- ;; This is a bit convoluted, but basically we go
- ;; through the time units for years, weeks, etc,
- ;; and divide things to see whether that results
- ;; in positive answers.
- (mapconcat
- (lambda (unit)
- (if (zerop (setq num (ffloor (/ sec (cdr unit)))))
- ;; The (remaining) seconds are too few to
- ;; be divided into this time unit.
- ""
- ;; It's big enough, so we output it.
- (setq sec (- sec (* num (cdr unit))))
- (prog1
- (concat (if prev ", " "") (int-to-string
- (floor num))
- " " (symbol-name (car unit))
- (if (> num 1) "s" ""))
- (setq prev t))))
- article-time-units "")
- ;; If dates are odd, then it might appear like the
- ;; article was sent in the future.
- (if (> real-sec 0)
- " ago"
- " in the future"))))))
+ (concat "Date: " (article-lapsed-string time)))
+ ;; A combined date/lapsed format.
+ ((eq type 'combined-lapsed)
+ (let ((date-string (article-make-date-line date 'original))
+ (segments 3)
+ lapsed-string)
+ (while (and
+ time
+ (setq lapsed-string
+ (concat " (" (article-lapsed-string time segments) ")"))
+ (> (+ (length date-string)
+ (length lapsed-string))
+ (+ fill-column 6))
+ (> segments 0))
+ (setq segments (1- segments)))
+ (if (> segments 0)
+ (concat date-string lapsed-string)
+ date-string)))
;; Display the date in proper English
((eq type 'english)
(let ((dtime (decode-time time)))
@@ -3572,9 +3565,56 @@ should replace the \"Date:\" one, or should be added below it."
(format "%02d" (nth 2 dtime))
":"
(format "%02d" (nth 1 dtime)))))))
- (error
+ (foo
(format "Date: %s (from Gnus)" date))))
+(defun article-lapsed-string (time &optional max-segments)
+ ;; If the date is seriously mangled, the timezone functions are
+ ;; liable to bug out, so we ignore all errors.
+ (let* ((now (current-time))
+ (real-time (subtract-time now time))
+ (real-sec (and real-time
+ (+ (* (float (car real-time)) 65536)
+ (cadr real-time))))
+ (sec (and real-time (abs real-sec)))
+ (segments 0)
+ num prev)
+ (unless max-segments
+ (setq max-segments (length article-time-units)))
+ (cond
+ ((null real-time)
+ "Unknown")
+ ((zerop sec)
+ "Now")
+ (t
+ (concat
+ ;; This is a bit convoluted, but basically we go
+ ;; through the time units for years, weeks, etc,
+ ;; and divide things to see whether that results
+ ;; in positive answers.
+ (mapconcat
+ (lambda (unit)
+ (if (or (zerop (setq num (ffloor (/ sec (cdr unit)))))
+ (>= segments max-segments))
+ ;; The (remaining) seconds are too few to
+ ;; be divided into this time unit.
+ ""
+ ;; It's big enough, so we output it.
+ (setq sec (- sec (* num (cdr unit))))
+ (prog1
+ (concat (if prev ", " "") (int-to-string
+ (floor num))
+ " " (symbol-name (car unit))
+ (if (> num 1) "s" ""))
+ (setq prev t
+ segments (1+ segments)))))
+ article-time-units "")
+ ;; If dates are odd, then it might appear like the
+ ;; article was sent in the future.
+ (if (> real-sec 0)
+ " ago"
+ " in the future"))))))
+
(defun article-date-local (&optional highlight)
"Convert the current article date to the local timezone."
(interactive (list t))
@@ -3597,26 +3637,54 @@ function and want to see what the date was before converting."
(interactive (list t))
(article-date-ut 'lapsed highlight))
+(defun article-date-combined-lapsed (&optional highlight)
+ "Convert the current article date to time lapsed since it was sent."
+ (interactive (list t))
+ (article-date-ut 'combined-lapsed highlight))
+
(defun article-update-date-lapsed ()
"Function to be run from a timer to update the lapsed time line."
(save-match-data
- (let (deactivate-mark)
- (save-excursion
- (ignore-errors
- (walk-windows
- (lambda (w)
- (set-buffer (window-buffer w))
- (when (eq major-mode 'gnus-article-mode)
- (let ((mark (point-marker)))
- (goto-char (point-min))
- (when (re-search-forward "^X-Sent:" nil t)
- (article-date-lapsed t))
- (goto-char (marker-position mark))
- (move-marker mark nil))))
- nil 'visible))))))
+ (let ((buffer (current-buffer)))
+ (ignore-errors
+ (walk-windows
+ (lambda (w)
+ (set-buffer (window-buffer w))
+ (when (eq major-mode 'gnus-article-mode)
+ (let ((old-line (count-lines (point-min) (point)))
+ (old-column (- (point) (line-beginning-position)))
+ (window-start
+ (window-start (get-buffer-window (current-buffer)))))
+ (goto-char (point-min))
+ (while (re-search-forward "^Date:" nil t)
+ (let ((type (get-text-property (match-beginning 0)
+ 'gnus-date-type)))
+ (when (memq type '(lapsed combined-lapsed user-format))
+ (when (and window-start
+ (not (= window-start
+ (save-excursion
+ (forward-line 1)
+ (point)))))
+ (setq window-start nil))
+ (save-excursion
+ (article-date-ut type t (match-beginning 0)))
+ (forward-line 1)
+ (when window-start
+ (set-window-start (get-buffer-window (current-buffer))
+ (point))))))
+ (goto-char (point-min))
+ (when (> old-column 0)
+ (setq old-line (1- old-line)))
+ (forward-line old-line)
+ (end-of-line)
+ (when (> (current-column) old-column)
+ (beginning-of-line)
+ (forward-char old-column)))))
+ nil 'visible))
+ (set-buffer buffer))))
(defun gnus-start-date-timer (&optional n)
- "Start a timer to update the X-Sent header in the article buffers.
+ "Start a timer to update the Date headers in the article buffers.
The numerical prefix says how frequently (in seconds) the function
is to run."
(interactive "p")
@@ -3627,7 +3695,7 @@ is to run."
(run-at-time 1 n 'article-update-date-lapsed)))
(defun gnus-stop-date-timer ()
- "Stop the X-Sent timer."
+ "Stop the Date timer."
(interactive)
(when article-lapsed-timer
(nnheader-cancel-timer article-lapsed-timer)
@@ -3883,7 +3951,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 +3969,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 +3990,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 +4022,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 +4101,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 +4260,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)
@@ -4250,14 +4320,17 @@ If variable `gnus-use-long-file-name' is non-nil, it is
article-date-english
article-date-iso8601
article-date-original
+ article-treat-date
article-date-ut
article-decode-mime-words
article-decode-charset
article-decode-encoded-words
article-date-user
article-date-lapsed
+ article-date-combined-lapsed
article-emphasize
article-treat-dumbquotes
+ article-treat-non-ascii
article-normalize-headers
;;(article-show-all . gnus-article-show-all-headers)
)))
@@ -4310,7 +4383,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 +4417,9 @@ If variable `gnus-use-long-file-name' is non-nil, it is
(gnus-run-hooks 'gnus-article-menu-hook)))
+(defvar bookmark-make-record-function)
+(defvar shr-put-image-function)
+
(defun gnus-article-mode ()
"Major mode for displaying an article.
@@ -4374,7 +4449,6 @@ commands:
(gnus-update-format-specifications nil 'article-mode)
(set (make-local-variable 'page-delimiter) gnus-page-delimiter)
(set (make-local-variable 'gnus-page-broken) nil)
- (make-local-variable 'gnus-button-marker-list)
(make-local-variable 'gnus-article-current-summary)
(make-local-variable 'gnus-article-mime-handles)
(make-local-variable 'gnus-article-decoded-p)
@@ -4383,11 +4457,14 @@ 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)
+ ;; Enable `gnus-article-remove-images' to delete images shr.el renders.
+ (set (make-local-variable 'shr-put-image-function) 'gnus-shr-put-image)
(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
@@ -4396,10 +4473,6 @@ commands:
(mm-enable-multibyte)
(gnus-run-mode-hooks 'gnus-article-mode-hook))
-(defvar gnus-button-marker-list nil
- "Regexp matching any of the regexps from `gnus-button-alist'.
-Internal variable.")
-
(defun gnus-article-setup-buffer ()
"Initialize the article buffer."
(let* ((name (if gnus-single-article-buffer "*Article*"
@@ -4443,17 +4516,21 @@ Internal variable.")
(setq gnus-article-mime-handle-alist nil)
(buffer-disable-undo)
(setq buffer-read-only t)
- ;; This list just keeps growing if we don't reset it.
- (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))
(gnus-summary-set-local-parameters gnus-newsgroup-name)
+ (when article-lapsed-timer
+ (gnus-stop-date-timer))
+ (when gnus-article-update-date-headers
+ (gnus-start-date-timer gnus-article-update-date-headers))
(current-buffer)))))
;; Set article window start at LINE, where LINE is the number of lines
@@ -4579,6 +4656,7 @@ If ALL-HEADERS is non-nil, no headers are hidden."
(forward-line -1))
(set-window-point (get-buffer-window (current-buffer)) (point))
(gnus-configure-windows 'article)
+ (gnus-run-hooks 'gnus-article-prepare-hook)
t))))))
;;;###autoload
@@ -4596,8 +4674,7 @@ If ALL-HEADERS is non-nil, no headers are hidden."
gnus-article-image-alist nil)
(gnus-run-hooks 'gnus-tmp-internal-hook)
(when gnus-display-mime-function
- (funcall gnus-display-mime-function))
- (gnus-run-hooks 'gnus-article-prepare-hook)))
+ (funcall gnus-display-mime-function))))
;;;
;;; Gnus Sticky Article Mode
@@ -4750,6 +4827,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 +4852,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 +4894,15 @@ 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)
+ (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 +4921,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 +4967,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."
@@ -4937,19 +5044,16 @@ Deleting parts may malfunction or destroy the article; continue? "))
(let* ((data (get-text-property (point) 'gnus-data))
(id (get-text-property (point) 'gnus-part))
(handles gnus-article-mime-handles)
- (none "(none)")
(description
(let ((desc (mm-handle-description data)))
(when desc
(mail-decode-encoded-word-string desc))))
- (filename
- (or (mail-content-type-get (mm-handle-disposition data) 'filename)
- none))
+ (filename (or (mm-handle-filename (mm-handle-disposition data)) "(none)"))
(type (mm-handle-media-type data)))
(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 +5062,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 +5085,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 +5128,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)))
@@ -5057,10 +5166,7 @@ are decompressed."
(unless handle
(setq handle (get-text-property (point) 'gnus-data)))
(when handle
- (let ((filename (or (mail-content-type-get (mm-handle-type handle)
- 'name)
- (mail-content-type-get (mm-handle-disposition handle)
- 'filename)))
+ (let ((filename (mm-handle-filename handle))
contents dont-decode charset coding-system)
(mm-with-unibyte-buffer
(mm-insert-part handle)
@@ -5090,7 +5196,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))
@@ -5150,12 +5256,7 @@ Compressed files like .gz and .bz2 are decompressed."
(mm-with-unibyte-buffer
(mm-insert-part handle)
(setq contents
- (or (mm-decompress-buffer
- (or (mail-content-type-get (mm-handle-type handle)
- 'name)
- (mail-content-type-get (mm-handle-disposition handle)
- 'filename))
- nil t)
+ (or (mm-decompress-buffer (mm-handle-filename handle) nil t)
(buffer-string))))
(cond
((not arg)
@@ -5177,15 +5278,7 @@ Compressed files like .gz and .bz2 are decompressed."
(if (mm-handle-undisplayer handle)
(mm-remove-part handle))))
(forward-line 2)
- (mm-insert-inline
- handle
- (if (or coding-system
- (and charset
- (setq coding-system
- (mm-charset-to-coding-system charset))
- (not (eq coding-system 'ascii))))
- (mm-decode-coding-string contents coding-system)
- (mm-string-to-multibyte contents)))
+ (mm-display-inline handle)
(goto-char b)))))
(defun gnus-mime-set-charset-parameters (handle charset)
@@ -5263,11 +5356,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 +5375,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 +5440,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 +5455,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 +5554,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,12 +5623,45 @@ 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
- (or (mail-content-type-get (mm-handle-type handle) 'name)
- (mail-content-type-get (mm-handle-disposition handle) 'filename)
+ (or (mm-handle-filename handle)
(mail-content-type-get (mm-handle-type handle) 'url)
""))
(gnus-tmp-type (mm-handle-media-type handle))
@@ -5576,7 +5703,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 +5711,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 +5765,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 +5865,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 +5895,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)
@@ -5795,18 +5921,7 @@ If displaying \"text/html\" is discouraged \(see
(forward-line -1)
(setq beg (point)))
(gnus-article-insert-newline)
- (mm-insert-inline
- handle
- (let ((charset (or (mail-content-type-get (mm-handle-type handle)
- 'charset)
- (and (equal type "text/calendar") 'utf-8))))
- (cond ((not charset)
- (mm-string-as-multibyte (mm-get-part handle)))
- ((eq charset 'gnus-decoded)
- (with-current-buffer (mm-handle-buffer handle)
- (buffer-string)))
- (t
- (mm-decode-string (mm-get-part handle) charset)))))
+ (mm-display-inline handle)
(goto-char (point-max))))
;; Do highlighting.
(save-excursion
@@ -5932,7 +6047,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
@@ -6027,6 +6142,15 @@ Provided for backwards compatibility."
(not gnus-inhibit-hiding))
(gnus-article-hide-headers)))
+(declare-function shr-put-image "shr" (data alt))
+
+(defun gnus-shr-put-image (data alt)
+ "Put image DATA with a string ALT. Enable image to be deleted."
+ (let ((image (shr-put-image data (propertize (or alt "*")
+ 'gnus-image-category 'shr))))
+ (when image
+ (gnus-add-image 'shr image))))
+
;;; Article savers.
(defun gnus-output-to-file (file-name)
@@ -6177,7 +6301,7 @@ Argument LINES specifies lines to be scrolled up."
(save-excursion
(end-of-line)
(and (pos-visible-in-window-p) ;Not continuation line.
- (>= (1+ (point)) (point-max))))) ;Allow for trailing newline.
+ (>= (point) (point-max)))))
;; Nothing in this page.
(if (or (not gnus-page-broken)
(save-excursion
@@ -6195,31 +6319,27 @@ 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))
+ (let ((scroll-in-place nil)
+ (auto-window-vscroll nil))
(scroll-up lines))
(end-of-buffer
;; Long lines may cause an end-of-buffer error.
@@ -6296,7 +6416,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."
@@ -6346,6 +6466,8 @@ not have a face in `gnus-article-boring-faces'."
(ding)
(unless (member keys nosave-in-article)
(set-buffer gnus-article-current-summary))
+ (when (get func 'disabled)
+ (error "Function %s disabled" func))
(call-interactively func)
(setq new-sum-point (point)))
(when (member keys nosave-but-article)
@@ -6374,8 +6496,11 @@ not have a face in `gnus-article-boring-faces'."
(select-window win))))
(setq in-buffer (current-buffer))
;; We disable the pick minor mode commands.
- (if (and (setq func (let (gnus-pick-mode)
- (key-binding keys t)))
+ (setq func (let (gnus-pick-mode)
+ (key-binding keys t)))
+ (when (get func 'disabled)
+ (error "Function %s disabled" func))
+ (if (and func
(functionp func)
(condition-case code
(progn
@@ -6471,6 +6596,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 +6649,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)
@@ -6727,7 +6853,10 @@ If given a prefix, show the hidden text instead."
gnus-summary-buffer)
(when gnus-keep-backlog
(gnus-backlog-enter-article
- group article (current-buffer))))
+ group article (current-buffer)))
+ (when (and gnus-agent
+ (gnus-agent-group-covered-p group))
+ (gnus-agent-store-article article group)))
(setq result 'article))
(methods
(setq gnus-override-method (pop methods)))
@@ -6777,6 +6906,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 +7061,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 +7075,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 +7168,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
@@ -7258,9 +7362,6 @@ as a symbol to FUN."
(defvar gnus-button-handle-describe-prefix "^\\(C-h\\|<?[Ff]1>?\\)")
-;; FIXME: Maybe we should merge some of the functions that do quite similar
-;; stuff?
-
(defun gnus-button-handle-describe-function (url)
"Call `describe-function' when pushing the corresponding URL button."
(describe-function
@@ -7321,26 +7422,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 +7488,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]+\\)"
@@ -7440,17 +7507,17 @@ positives are possible."
;; Info links like `C-h i d m Gnus RET' or `C-h i d m Gnus RET i partial RET'
0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-keystrokes 0)
;; This is custom
- ("M-x[ \t\n]\\(customize-[^ ]+\\)[ \t\n]RET[ \t\n]\\([^ ]+\\)[ \t\n]RET" 0
+ ("M-x[ \t\n]\\(customize-[^ ]+\\)[ \t\n]RET[ \t\n]\\([^ ]+\\)[ \t\n]RET\\>" 0
(>= gnus-button-emacs-level 1) gnus-button-handle-custom 1 2)
;; Emacs help commands
- ("M-x[ \t\n]+apropos[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ ("M-x[ \t\n]+apropos[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
;; regexp doesn't match arguments containing ` '.
0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos 1)
- ("M-x[ \t\n]+apropos-command[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ ("M-x[ \t\n]+apropos-command[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-command 1)
- ("M-x[ \t\n]+apropos-variable[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ ("M-x[ \t\n]+apropos-variable[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-variable 1)
- ("M-x[ \t\n]+apropos-documentation[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ ("M-x[ \t\n]+apropos-documentation[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-documentation 1)
;; The following entries may lead to many false positives so don't enable
;; them by default (use a high button level).
@@ -7465,11 +7532,11 @@ positives are possible."
0 (>= gnus-button-emacs-level 9) gnus-button-handle-symbol 1)
("(setq[ \t\n]+\\([a-z][a-z0-9]+-[-a-z0-9]+\\)[ \t\n]+.+)"
1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-variable 1)
- ("\\bM-x[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ ("\\bM-x[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-function 1)
- ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+f[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+f[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-function 2)
- ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+v[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+v[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-variable 2)
("`\\(\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+k[ \t\n]+\\([^']+\\)\\)'"
;; Unlike the other regexps we really have to require quoting
@@ -7608,7 +7675,7 @@ do the highlighting. See the documentation for those functions."
(gnus-article-highlight-headers)
(gnus-article-highlight-citation force)
(gnus-article-highlight-signature)
- (gnus-article-add-buttons force)
+ (gnus-article-add-buttons)
(gnus-article-add-buttons-to-head))
(defun gnus-article-highlight-some (&optional force)
@@ -7676,28 +7743,16 @@ It does this by highlighting everything after
"Say whether PROP exists in the region."
(text-property-not-all b e prop nil))
-(defun gnus-article-add-buttons (&optional force)
+(defun gnus-article-add-buttons ()
"Find external references in the article and make buttons of them.
\"External references\" are things like Message-IDs and URLs, as
specified by `gnus-button-alist'."
- (interactive (list 'force))
+ (interactive)
(gnus-with-article-buffer
(let ((inhibit-point-motion-hooks t)
(case-fold-search t)
(alist gnus-button-alist)
beg entry regexp)
- ;; Remove all old markers.
- (let (marker entry new-list)
- (while (setq marker (pop gnus-button-marker-list))
- (if (or (< marker (point-min)) (>= marker (point-max)))
- (push marker new-list)
- (goto-char marker)
- (when (setq entry (gnus-button-entry))
- (put-text-property (match-beginning (nth 1 entry))
- (match-end (nth 1 entry))
- 'gnus-callback nil))
- (set-marker marker nil)))
- (setq gnus-button-marker-list new-list))
;; We skip the headers.
(article-goto-body)
(setq beg (point))
@@ -7708,18 +7763,20 @@ specified by `gnus-button-alist'."
(let ((start (match-beginning (nth 1 entry)))
(end (match-end (nth 1 entry)))
(from (match-beginning 0)))
- (when (and (or (eq t (nth 2 entry))
- (eval (nth 2 entry)))
+ (when (and (eval (nth 2 entry))
(not (gnus-button-in-region-p
start end 'gnus-callback)))
;; That optional form returned non-nil, so we add the
;; button.
(setq from (set-marker (make-marker) from))
- (push from gnus-button-marker-list)
(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 (list from entry))
+ (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 +7868,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 +7880,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 ()
@@ -7849,41 +7919,38 @@ url is put as the `gnus-button-url' overlay property on the button."
(let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist))
(gnus-set-mode-line 'article))))
-(defun gnus-button-entry ()
- ;; Return the first entry in `gnus-button-alist' matching this place.
- (let ((alist gnus-button-alist)
- (entry nil))
- (while alist
- (setq entry (pop alist))
- (if (looking-at (eval (car entry)))
- (setq alist nil)
- (setq entry nil)))
- entry))
-
-(defun gnus-button-push (marker)
+(defun gnus-button-push (marker-and-entry)
;; Push button starting at MARKER.
(save-excursion
- (goto-char marker)
- (let* ((entry (gnus-button-entry))
- (inhibit-point-motion-hooks t)
- (fun (nth 3 entry))
- (args (or (and (eq (car entry) 'gnus-button-url-regexp)
- (get-char-property marker 'gnus-button-url))
- (mapcar (lambda (group)
- (let ((string (match-string group)))
- (set-text-properties
- 0 (length string) nil string)
- string))
- (nthcdr 4 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)))))))
+ (let* ((marker (car marker-and-entry))
+ (entry (cadr marker-and-entry))
+ (regexp (car entry))
+ (inhibit-point-motion-hooks t))
+ (goto-char marker)
+ ;; This is obviously true, or something bad is happening :)
+ ;; But we need it to have the match-data
+ (when (looking-at (or (if (symbolp regexp)
+ (symbol-value regexp)
+ regexp)))
+ (let ((fun (nth 3 entry))
+ (args (or (and (eq (car entry) 'gnus-button-url-regexp)
+ (get-char-property marker 'gnus-button-url))
+ (mapcar (lambda (group)
+ (let ((string (match-string group)))
+ (set-text-properties
+ 0 (length string) nil string)
+ string))
+ (nthcdr 4 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)))))))))
(defun gnus-parse-news-url (url)
(let (scheme server port group message-id articles)
@@ -7994,7 +8061,7 @@ url is put as the `gnus-button-url' overlay property on the button."
(if (string-match
(concat "\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+i[ \t\n]+d?[ \t\n]?m[ \t\n]+"
"\\([^ ]+ ?[^ ]+\\)[ \t\n]+RET"
- "\\([ \t\n]+i[ \t\n]+[^ ]+ ?[^ ]+[ \t\n]+RET"
+ "\\([ \t\n]+i[ \t\n]+[^ ]+ ?[^ ]+[ \t\n]+RET\\>"
"\\(?:[ \t\n,]*\\)\\)?")
url)
(setq node (match-string 2 url)
@@ -8004,7 +8071,7 @@ url is put as the `gnus-button-url' overlay property on the button."
(Info-directory)
(Info-menu node)
(when (> (length indx) 0)
- (string-match (concat "[ \t\n]+i[ \t\n]+\\([^ ]+ ?[^ ]+\\)[ \t\n]+RET"
+ (string-match (concat "[ \t\n]+i[ \t\n]+\\([^ ]+ ?[^ ]+\\)[ \t\n]+RET\\>"
"\\([ \t\n,]*\\)")
indx)
(setq comma (match-string 2 indx))
@@ -8020,6 +8087,7 @@ url is put as the `gnus-button-url' overlay property on the button."
(Info-index-next 1)))
nil)))
+(autoload 'pgg-snarf-keys-region "pgg")
;; Called after pgg-snarf-keys-region, which autoloads pgg.el.
(declare-function pgg-display-output-buffer "pgg" (start end status))
@@ -8080,6 +8148,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 +8158,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 +8191,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 +8309,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 +8334,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 +8345,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 +8370,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 +8382,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 +8391,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 +8455,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 +8643,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 +8705,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 4a3c6f36e30..ad85bc5cf76 100644
--- a/lisp/gnus/gnus-async.el
+++ b/lisp/gnus/gnus-async.el
@@ -1,7 +1,6 @@
;;; gnus-async.el --- asynchronous support for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -71,6 +70,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 +144,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 +203,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 +225,29 @@ 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))
+ ;; Put the articles into the agent, if they aren't already.
+ (when (and gnus-agent
+ (gnus-agent-group-covered-p group))
+ (save-restriction
+ (narrow-to-region mark (point-max))
+ (gnus-agent-store-article article group)))
+ ;; 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 +321,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 +338,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 +394,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 ede7a716f40..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, 2011 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 52a5c559bf2..d3fee3538b8 100644
--- a/lisp/gnus/gnus-bcklg.el
+++ b/lisp/gnus/gnus-bcklg.el
@@ -1,7 +1,6 @@
;;; gnus-bcklg.el --- backlog functions for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -40,8 +39,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 +74,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 +87,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 +110,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 +133,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 +144,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 +152,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 39f583a83a6..f86c94571a7 100644
--- a/lisp/gnus/gnus-bookmark.el
+++ b/lisp/gnus/gnus-bookmark.el
@@ -1,6 +1,6 @@
;;; gnus-bookmark.el --- Bookmarks in Gnus
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
;; Author: Bastien Guerry <bzg AT altern DOT org>
;; Keywords: news
@@ -156,9 +156,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 +289,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 +538,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 +572,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 +824,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 272140f359a..203368f76e2 100644
--- a/lisp/gnus/gnus-cache.el
+++ b/lisp/gnus/gnus-cache.el
@@ -1,7 +1,6 @@
;;; gnus-cache.el --- cache interface for Gnus
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -25,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))))
@@ -180,8 +179,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 +382,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 +557,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 +607,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 +846,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 +869,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 +880,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 +912,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 a33f3eab413..d205437b811 100644
--- a/lisp/gnus/gnus-cite.el
+++ b/lisp/gnus/gnus-cite.el
@@ -1,7 +1,6 @@
;;; gnus-cite.el --- parse citations in articles for Gnus
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-2011 Free Software Foundation, Inc.
;; Author: Per Abhiddenware
@@ -407,9 +406,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 +459,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 +515,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 +539,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 +568,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 +599,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 +666,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 +770,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 +1115,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 +1283,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 855a1ea0a6b..2f99abba22c 100644
--- a/lisp/gnus/gnus-cus.el
+++ b/lisp/gnus/gnus-cus.el
@@ -1,7 +1,6 @@
;;; gnus-cus.el --- customization commands for Gnus
-;; Copyright (C) 1996, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1999-2011 Free Software Foundation, Inc.
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: news
@@ -50,7 +49,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 +864,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 +1112,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 cd9c21f63aa..bfd17055ea5 100644
--- a/lisp/gnus/gnus-delay.el
+++ b/lisp/gnus/gnus-delay.el
@@ -1,7 +1,6 @@
;;; gnus-delay.el --- Delayed posting of articles
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;; Author: Kai Grojohann <Kai.Grossjohann@CS.Uni-Dortmund.DE>
;; Keywords: mail, news, extensions
@@ -79,7 +78,7 @@ DELAY is a string, giving the length of the time. Possible values are:
time, then the deadline is tomorrow, else today."
(interactive
(list (read-string
- "Target date (YYYY-MM-DD) or length of delay (units in [mhdwMY]): "
+ "Target date (YYYY-MM-DD), time (hh:mm), or length of delay (units in [mhdwMY]): "
gnus-delay-default-delay)))
(let (num unit days year month day hour minute deadline)
(cond ((string-match
@@ -106,7 +105,7 @@ DELAY is a string, giving the length of the time. Possible values are:
(append deadline nil))))
;; If this time has passed already, add a day.
(when (< deadline (gnus-float-time))
- (setq deadline (+ 3600 deadline))) ;3600 secs/day
+ (setq deadline (+ 86400 deadline))) ; 86400 secs/day
;; Convert seconds to date header.
(setq deadline (message-make-date
(seconds-to-time deadline))))
@@ -133,8 +132,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 +190,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 447e7d6e30a..419346b7191 100644
--- a/lisp/gnus/gnus-demon.el
+++ b/lisp/gnus/gnus-demon.el
@@ -1,7 +1,6 @@
;;; gnus-demon.el --- daemonic Gnus behavior
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -32,9 +31,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 +42,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 +64,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 +87,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) nil)
+ (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 time 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 time 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 time 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 +195,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 +221,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 103f98d69d2..0b5a7ebf1f9 100644
--- a/lisp/gnus/gnus-diary.el
+++ b/lisp/gnus/gnus-diary.el
@@ -1,7 +1,6 @@
;;; gnus-diary.el --- Wrapper around the NNDiary Gnus back end
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Didier Verna <didier@xemacs.org>
;; Maintainer: Didier Verna <didier@xemacs.org>
@@ -368,11 +367,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 +400,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 2efb050eb1d..c38b0cd3606 100644
--- a/lisp/gnus/gnus-dired.el
+++ b/lisp/gnus/gnus-dired.el
@@ -1,7 +1,6 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1999, 2001-2011 Free Software Foundation, Inc.
;; Authors: Benjamin Rutt <brutt@bloomington.in.us>,
;; Shenghuo Zhu <zsh@cs.rochester.edu>
@@ -39,6 +38,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 +57,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 +86,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 +121,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 +134,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 +155,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 +203,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 +260,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 1c1d5bdfcb9..1709b1c4a05 100644
--- a/lisp/gnus/gnus-draft.el
+++ b/lisp/gnus/gnus-draft.el
@@ -1,7 +1,6 @@
;;; gnus-draft.el --- draft message support for Gnus
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -32,23 +31,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 +58,18 @@
["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))
+ (add-hook 'gnus-summary-prepare-exit-hook 'gnus-draft-clear-marks t t))))
;;; Commands
@@ -154,7 +149,7 @@ Obeys the standard process/prefix convention."
gnus-agent-queue-mail))
(rfc2047-encode-encoded-words nil)
type method move-to)
- (gnus-draft-setup article (or group "nndraft:queue"))
+ (gnus-draft-setup article (or group "nndraft:queue") nil 'dont-pop)
;; We read the meta-information that says how and where
;; this message is to be sent.
(save-restriction
@@ -226,7 +221,8 @@ Obeys the standard process/prefix convention."
(let ((message-sending-message
(format "Sending message %d of %d..."
(- total (length articles)) total)))
- (gnus-draft-send article))))))))
+ (gnus-draft-send article))))))
+ (gnus-group-refresh-group "nndraft:queue")))
;;;###autoload
(defun gnus-draft-reminder ()
@@ -248,55 +244,53 @@ Obeys the standard process/prefix convention."
:version "23.1" ;; No Gnus
:type 'hook)
-;;; Utility functions
-
-;;;!!!If this is byte-compiled, it fails miserably.
-;;;!!!This is because `gnus-setup-message' uses uninterned symbols.
-;;;!!!This has been fixed in recent versions of Emacs and XEmacs,
-;;;!!!but for the time being, we'll just run this tiny function uncompiled.
-(progn
- (defun gnus-draft-setup (narticle group &optional restore)
- (let (ga)
- (gnus-setup-message 'forward
- (let ((article narticle))
- (message-mail)
- (erase-buffer)
- (if (not (gnus-request-restore-buffer article group))
- (error "Couldn't restore the article")
- (when (and restore
- (equal group "nndraft:queue"))
- (mime-to-mml))
- ;; Insert the separator.
- (goto-char (point-min))
- (search-forward "\n\n")
- (forward-char -1)
- (save-restriction
- (narrow-to-region (point-min) (point))
- (setq ga
- (message-fetch-field gnus-draft-meta-information-header)))
- (insert mail-header-separator)
- (forward-line 1)
- (message-set-auto-save-file-name))))
- (gnus-backlog-remove-article group narticle)
- (when (and ga
- (ignore-errors (setq ga (car (read-from-string ga)))))
- (setq gnus-newsgroup-name
- (if (equal (car ga) "") nil (car ga)))
- (gnus-configure-posting-styles)
- (setq gnus-message-group-art (cons gnus-newsgroup-name (cadr ga)))
- (setq message-post-method
- `(lambda (arg)
- (gnus-post-method arg ,(car ga))))
- (unless (equal (cadr ga) "")
- (dolist (article (cdr ga))
- (message-add-action
- `(progn
- (gnus-add-mark ,(car ga) 'replied ,article)
- (gnus-request-set-mark ,(car ga) (list (list (list ,article)
- 'add '(reply)))))
- 'send))))
- (run-hooks 'gnus-draft-setup-hook))))
+(defun gnus-draft-setup (narticle group &optional restore dont-pop)
+ "Setup a mail draft buffer.
+If DONT-POP is nil, display the buffer after setting it up."
+ (let (ga)
+ (gnus-setup-message 'forward
+ (let ((article narticle))
+ (message-mail nil nil nil nil
+ (if dont-pop
+ (lambda (buf) (set-buffer (get-buffer-create buf)))))
+ (let ((inhibit-read-only t))
+ (erase-buffer))
+ (if (not (gnus-request-restore-buffer article group))
+ (error "Couldn't restore the article")
+ (when (and restore
+ (equal group "nndraft:queue"))
+ (mime-to-mml))
+ ;; Insert the separator.
+ (goto-char (point-min))
+ (search-forward "\n\n")
+ (forward-char -1)
+ (save-restriction
+ (narrow-to-region (point-min) (point))
+ (setq ga
+ (message-fetch-field gnus-draft-meta-information-header)))
+ (insert mail-header-separator)
+ (forward-line 1)
+ (message-set-auto-save-file-name))))
+ (gnus-backlog-remove-article group narticle)
+ (when (and ga
+ (ignore-errors (setq ga (car (read-from-string ga)))))
+ (setq gnus-newsgroup-name
+ (if (equal (car ga) "") nil (car ga)))
+ (gnus-configure-posting-styles)
+ (setq gnus-message-group-art (cons gnus-newsgroup-name (cadr ga)))
+ (setq message-post-method
+ `(lambda (arg)
+ (gnus-post-method arg ,(car ga))))
+ (unless (equal (cadr ga) "")
+ (dolist (article (cdr ga))
+ (message-add-action
+ `(progn
+ (gnus-add-mark ,(car ga) 'replied ,article)
+ (gnus-request-set-mark ,(car ga) (list (list (list ,article)
+ 'add '(reply)))))
+ 'send))))
+ (run-hooks 'gnus-draft-setup-hook)))
(defun gnus-draft-article-sendable-p (article)
"Say whether ARTICLE is sendable."
@@ -315,6 +309,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))
@@ -328,7 +324,12 @@ Obeys the standard process/prefix convention."
(pop-to-buffer buff t)))
(error "The draft %s is under edit" file)))))
+(defun gnus-draft-clear-marks ()
+ (setq gnus-newsgroup-reads nil
+ gnus-newsgroup-marked nil
+ gnus-newsgroup-unreads
+ (gnus-uncompress-range (gnus-active gnus-newsgroup-name))))
+
(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 662414a6a4b..eaecc07d767 100644
--- a/lisp/gnus/gnus-dup.el
+++ b/lisp/gnus/gnus-dup.el
@@ -1,7 +1,6 @@
;;; gnus-dup.el --- suppression of duplicate articles in Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -159,5 +158,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 a7ec2dd947e..4075e7a7625 100644
--- a/lisp/gnus/gnus-eform.el
+++ b/lisp/gnus/gnus-eform.el
@@ -1,7 +1,6 @@
;;; gnus-eform.el --- a mode for editing forms for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -130,5 +129,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 64488186150..bc85e4960d4 100644
--- a/lisp/gnus/gnus-ems.el
+++ b/lisp/gnus/gnus-ems.el
@@ -1,7 +1,6 @@
;;; gnus-ems.el --- functions for making Gnus work under different Emacsen
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -162,102 +161,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 +175,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 +209,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 22fd0637b99..cb495623af2 100644
--- a/lisp/gnus/gnus-fun.el
+++ b/lisp/gnus/gnus-fun.el
@@ -1,6 +1,6 @@
;;; gnus-fun.el --- various frivolous extension functions to Gnus
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -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..98b1f3bd18c
--- /dev/null
+++ b/lisp/gnus/gnus-gravatar.el
@@ -0,0 +1,144 @@
+;;; gnus-gravatar.el --- Gnus Gravatar support
+
+;; Copyright (C) 2010-2011 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)
+(require 'mail-extr) ;; Because of binding `mail-extr-disable-voodoo'.
+
+(defgroup gnus-gravatar nil
+ "Gnus Gravatar."
+ :group 'gnus-visual)
+
+(defcustom gnus-gravatar-size nil
+ "How big should gravatars be displayed.
+If nil, default to `gravatar-size'."
+ :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* ((mail-extr-disable-voodoo t)
+ (mail-extr-ignore-realname-equals-mailbox-name nil)
+ (addresses (mail-extract-address-components
+ (or (mail-fetch-field header) "") t))
+ (gravatar-size (or gnus-gravatar-size gravatar-size))
+ name)
+ (dolist (address addresses)
+ (when (and (setq name (car address))
+ (string-match "\\` +" name))
+ (setcar address (setq name (substring name (match-end 0)))))
+ (when (or force
+ (not (and gnus-gravatar-too-ugly
+ (or (string-match gnus-gravatar-too-ugly
+ (or (cadr address) ""))
+ (and name
+ (string-match gnus-gravatar-too-ugly
+ name))))))
+ (ignore-errors
+ (gravatar-retrieve
+ (cadr 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-buffer
+ (let ((mark (point-marker))
+ (inhibit-point-motion-hooks t)
+ (case-fold-search t))
+ (save-restriction
+ (article-narrow-to-head)
+ ;; 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 (car address))
+ (mail-address (cadr address)))
+ (when (if real-name
+ (re-search-forward
+ (concat (gnus-replace-in-string
+ (regexp-quote real-name) "[\t ]+" "[\t\n ]+")
+ "\\|"
+ (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 ((point (point)))
+ (unless (featurep 'xemacs)
+ (setq gravatar (append gravatar gnus-gravatar-properties)))
+ (gnus-put-image gravatar (buffer-substring (point) (1+ point)) category)
+ (put-text-property point (point) 'gnus-gravatar address)
+ (gnus-add-wash-type category)
+ (gnus-add-image category gravatar)))))))
+ (goto-char (marker-position mark))))))
+
+;;;###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 6849f6e1032..c265538e19c 100644
--- a/lisp/gnus/gnus-group.el
+++ b/lisp/gnus/gnus-group.el
@@ -1,7 +1,6 @@
;;; gnus-group.el --- group mode commands for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -25,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))))
@@ -55,17 +54,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 +118,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 +159,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 +282,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 +414,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 +494,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 +550,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 +645,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 +655,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
@@ -719,7 +697,8 @@ simple manner.")
"M" gnus-group-list-all-matching
"l" gnus-group-list-level
"c" gnus-group-list-cached
- "?" gnus-group-list-dormant)
+ "?" gnus-group-list-dormant
+ "!" gnus-group-list-ticked)
(gnus-define-keys (gnus-group-list-limit-map "/" gnus-group-list-map)
"k" gnus-group-list-limit
@@ -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
@@ -884,7 +850,8 @@ simple manner.")
["List all groups matching..." gnus-group-list-all-matching t]
["List active file" gnus-group-list-active t]
["List groups with cached" gnus-group-list-cached t]
- ["List groups with dormant" gnus-group-list-dormant t])
+ ["List groups with dormant" gnus-group-list-dormant t]
+ ["List groups with ticked" gnus-group-list-ticked t])
("Sort"
["Default sort" gnus-group-sort-groups t]
["Sort by method" gnus-group-sort-groups-by-method t]
@@ -935,10 +902,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 +938,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 +955,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 +1086,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 +1165,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 +1180,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 +1232,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 +1251,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 +1495,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 +1553,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 +1600,155 @@ 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-refresh-group (group)
+ (gnus-activate-group group)
+ (gnus-get-unread-articles-in-group (gnus-get-info group)
+ (gnus-active group))
+ (gnus-group-update-group group))
(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 +1761,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 +1898,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 +2172,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 +2233,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 +2274,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)))
@@ -2332,9 +2315,10 @@ Return the name of the group if selection was successful."
gnus-fetch-old-ephemeral-headers))
(gnus-group-read-group (or number t) t group select-articles))
group)
- ;;(error nil)
(quit
- (message "Quit reading the ephemeral group")
+ (if debug-on-quit
+ (debug "Quit")
+ (message "Quit reading the ephemeral group"))
nil)))))
(defcustom gnus-gmane-group-download-format
@@ -2358,13 +2342,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 +2376,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 +2429,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 +2470,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 nil
+ (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 +2667,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 +2676,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)))
@@ -2748,6 +2743,15 @@ even if it contains non-ASCII characters) unless ENCODED is non-nil."
(lambda (group)
(gnus-group-delete-group group nil t))))))
+(defun gnus-group-delete-articles (group)
+ "Delete all articles in the current group."
+ (interactive (list (gnus-group-group-name)))
+ (let ((articles (gnus-uncompress-range (gnus-active group))))
+ (when (gnus-yes-or-no-p
+ (format "Do you really want to delete these %d articles forever? "
+ (length articles)))
+ (gnus-request-expire-articles articles group 'force))))
+
(defun gnus-group-delete-group (group &optional force no-prompt)
"Delete the current group. Only meaningful with editable groups.
If FORCE (the prefix) is non-nil, all the articles in the group will
@@ -2934,8 +2938,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 +3032,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 +3049,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,65 +3099,13 @@ 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
directory will be used as a newsgroup. The directory should contain
mail messages or news articles in files that have numeric names."
(interactive
- (list (read-file-name "Create group from directory: ")))
+ (list (read-directory-name "Create group from directory: ")))
(unless (file-exists-p dir)
(error "No such directory"))
(unless (file-directory-p dir)
@@ -3170,47 +3123,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 +3173,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 +3699,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)
@@ -3885,6 +3799,8 @@ of groups killed."
gnus-list-of-killed-groups))
(gnus-group-change-level
(if entry entry group) gnus-level-killed (if entry nil level))
+ (when (numberp (gnus-group-unread group))
+ (gnus-request-update-group-status group 'unsubscribe))
(message "Killed group %s" (gnus-group-decoded-name group)))
;; If there are lots and lots of groups to be killed, we use
;; this thing instead.
@@ -3907,7 +3823,9 @@ of groups killed."
(setq gnus-zombie-list (delete group gnus-zombie-list))))
;; There may be more than one instance displayed.
(while (gnus-group-goto-group group)
- (gnus-delete-line)))
+ (gnus-delete-line))
+ (when (numberp (gnus-group-unread group))
+ (gnus-request-update-group-status group 'unsubscribe)))
(gnus-make-hashtable-from-newsrc-alist))
(gnus-group-position-point)
@@ -3935,6 +3853,7 @@ yanked) a list of yanked groups is returned."
(and prev (gnus-group-entry prev))
t)
(gnus-group-insert-group-line-info group)
+ (gnus-request-update-group-status group 'subscribe)
(gnus-undo-register
`(when (gnus-group-goto-group ,group)
(gnus-group-kill-group 1))))
@@ -4067,30 +3986,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 +4006,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 +4037,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 +4057,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 +4209,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 +4224,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 +4303,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 +4317,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 +4326,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 +4365,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
@@ -4582,6 +4403,21 @@ and the second element is the address."
(defun gnus-group-set-params-info (group params)
(gnus-group-set-info params group 'params))
+;; Ad-hoc function for inserting data from a different newsrc.eld
+;; file. Use with caution, if at all.
+(defun gnus-import-other-newsrc-file (file)
+ (with-temp-buffer
+ (insert-file file)
+ (let (form)
+ (while (ignore-errors
+ (setq form (read (current-buffer))))
+ (when (and (consp form)
+ (eq (cadr form) 'gnus-newsrc-alist))
+ (let ((infos (cadr (nth 2 form))))
+ (dolist (info infos)
+ (when (gnus-get-info (car info))
+ (gnus-set-info (car info) info)))))))))
+
(defun gnus-add-marked-articles (group type articles &optional info force)
;; Add ARTICLES of TYPE to the info of GROUP.
;; If INFO is non-nil, use that info. If FORCE is non-nil, don't
@@ -4612,8 +4448,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)))))
@@ -4703,6 +4538,28 @@ This command may read the active file."
(goto-char (point-min))
(gnus-group-position-point))
+(defun gnus-group-list-ticked (level &optional lowest)
+ "List all groups with ticked articles.
+If the prefix LEVEL is non-nil, it should be a number that says which
+level to cut off listing groups.
+If LOWEST, don't list groups with level lower than LOWEST.
+
+This command may read the active file."
+ (interactive "P")
+ (when level
+ (setq level (prefix-numeric-value level)))
+ (when (or (not level) (>= level gnus-level-zombie))
+ (gnus-cache-open))
+ (funcall gnus-group-prepare-function
+ (or level gnus-level-subscribed)
+ #'(lambda (info)
+ (let ((marks (gnus-info-marks info)))
+ (assq 'tick marks)))
+ lowest
+ 'ignore)
+ (goto-char (point-min))
+ (gnus-group-position-point))
+
(defun gnus-group-listed-groups ()
"Return a list of listed groups."
(let (point groups)
@@ -4813,5 +4670,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..b7f0c0922a3
--- /dev/null
+++ b/lisp/gnus/gnus-html.el
@@ -0,0 +1,528 @@
+;;; gnus-html.el --- Render HTML in a buffer.
+
+;; Copyright (C) 2010-2011 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)))
+ (widget-convert-button
+ 'url-link start (point)
+ :help-echo alt-text
+ :keymap gnus-html-image-map
+ url)
+ (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
+ (gnus-add-image
+ 'cid
+ (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))
+ (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)
+ (if (fboundp 'url-queue-retrieve)
+ (url-queue-retrieve (car image)
+ 'gnus-html-image-fetched
+ (list buffer image) t)
+ (ignore-errors
+ (url-retrieve (car image)
+ 'gnus-html-image-fetched
+ (list buffer image)))))
+
+(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)
+ (widget-convert-button
+ 'url-link start (point)
+ :help-echo alt-text
+ :keymap gnus-html-displayed-image-map
+ url)
+ (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 eef1969ef6e..ef15a479892 100644
--- a/lisp/gnus/gnus-int.el
+++ b/lisp/gnus/gnus-int.el
@@ -1,7 +1,6 @@
;;; gnus-int.el --- backend interface functions for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -31,6 +30,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 +41,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 +99,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 +186,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 +234,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.
@@ -237,54 +258,53 @@ If it is down, start it up (again)."
(gnus-message 1 "Denied server %s" server)
nil)
;; Open the server.
- (let* ((open-server-function (gnus-get-function gnus-command-method 'open-server))
+ (let* ((open-server-function
+ (gnus-get-function gnus-command-method 'open-server))
(result
- (condition-case err
- (funcall open-server-function
- (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)))
- nil)
- (quit
- (gnus-message 1 "Quit trying to open server %s" server)
- nil)))
- open-offline)
+ (condition-case err
+ (funcall open-server-function
+ (nth 1 gnus-command-method)
+ (nthcdr 2 gnus-command-method))
+ (error
+ (gnus-message 1 "Unable to open server %s due to: %s"
+ server (error-message-string err))
+ nil)
+ (quit
+ (if debug-on-quit
+ (debug "Quit")
+ (gnus-message 1 "Quit trying to open server %s" server))
+ nil)))
+ open-offline)
;; If this hasn't been opened before, we add it to the list.
(unless elem
(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 +339,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 +394,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."
@@ -437,6 +474,18 @@ If FETCH-OLD, retrieve all headers (or some subset thereof) in the group."
(funcall (gnus-get-function gnus-command-method 'request-type)
(gnus-group-real-name group) article))))
+(defun gnus-request-update-group-status (group status)
+ "Change the status of a group.
+Valid statuses include `subscribe' and `unsubscribe'."
+ (let ((gnus-command-method (gnus-find-method-for-group group)))
+ (if (not (gnus-check-backend-function
+ 'request-update-group-status (car gnus-command-method)))
+ nil
+ (funcall
+ (gnus-get-function gnus-command-method 'request-update-group-status)
+ (gnus-group-real-name group) status
+ (nth 1 gnus-command-method)))))
+
(defun gnus-request-set-mark (group action)
"Set marks on articles in the back end."
(let ((gnus-command-method (gnus-find-method-for-group group)))
@@ -445,7 +494,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 +503,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 +516,22 @@ If BUFFER, insert the article in that group."
article (gnus-group-real-name group)
(nth 1 gnus-command-method) buffer)))
+(defun gnus-request-thread (header)
+ "Request the headers in the thread containing the article specified by HEADER."
+ (let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name)))
+ (funcall (gnus-get-function gnus-command-method 'request-thread)
+ header)))
+
+(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 +557,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 +589,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 +602,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,21 +617,30 @@ 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)
+ (and (funcall (gnus-get-function gnus-command-method 'request-marks)
(gnus-group-real-name group)
info (nth 1 gnus-command-method))
;; If the minimum article number is greater than 1, then all
@@ -575,6 +657,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 +676,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)))
@@ -627,7 +711,9 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
(if (stringp group) (gnus-group-real-name group) group)
(cadr gnus-command-method)
last)))
- (when (and gnus-agent (gnus-agent-method-p gnus-command-method))
+ (when (and gnus-agent
+ (gnus-agent-method-p gnus-command-method)
+ (cdr result))
(gnus-agent-regenerate-group group (list (cdr result))))
result))
@@ -716,5 +802,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 119514fba68..fdbe125ff10 100644
--- a/lisp/gnus/gnus-kill.el
+++ b/lisp/gnus/gnus-kill.el
@@ -1,7 +1,6 @@
;;; gnus-kill.el --- kill commands for Gnus
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-2011 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -349,8 +348,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 +440,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 +479,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 +552,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 +606,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 +710,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 eaba5ae2762..51b44e6052d 100644
--- a/lisp/gnus/gnus-logic.el
+++ b/lisp/gnus/gnus-logic.el
@@ -1,7 +1,6 @@
;;; gnus-logic.el --- advanced scoring code for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -179,8 +178,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 +223,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 4428b161c0f..1c9d31ab6c4 100644
--- a/lisp/gnus/gnus-mh.el
+++ b/lisp/gnus/gnus-mh.el
@@ -1,7 +1,6 @@
;;; gnus-mh.el --- mh-e interface for Gnus
-;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-2011 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -109,5 +108,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 4a618f49509..d99680f5924 100644
--- a/lisp/gnus/gnus-ml.el
+++ b/lisp/gnus/gnus-ml.el
@@ -1,7 +1,6 @@
;;; gnus-ml.el --- Mailing list minor mode for Gnus
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Author: Julien Gilles <jgilles@free.fr>
;; Keywords: news, mail
@@ -30,27 +29,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 +84,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 +179,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 b4dd08df0cf..ccc145b7e29 100644
--- a/lisp/gnus/gnus-mlspl.el
+++ b/lisp/gnus/gnus-mlspl.el
@@ -1,7 +1,6 @@
;;; gnus-mlspl.el --- a group params-based mail splitting mechanism
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Alexandre Oliva <oliva@lsd.ic.unicamp.br>
;; Keywords: news, mail
@@ -227,5 +226,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 dc741027244..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, 2011 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 a8e17ba8879..093eec33fcd 100644
--- a/lisp/gnus/gnus-msg.el
+++ b/lisp/gnus/gnus-msg.el
@@ -1,7 +1,6 @@
;;; gnus-msg.el --- mail and post interface for Gnus
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-2011 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -55,7 +54,7 @@ method to use when posting."
(sexp :tag "Methods" ,gnus-select-method)))
(defcustom gnus-outgoing-message-group nil
- "*All outgoing messages will be put in this group.
+ "All outgoing messages will be put in this group.
If you want to store all your outgoing mail and articles in the group
\"nnml:archive\", you set this variable to that value. This variable
can also be a list of group names.
@@ -70,6 +69,8 @@ of names)."
(string :tag "Group")
(repeat :tag "List of groups" (string :tag "Group"))))
+(make-obsolete-variable 'gnus-outgoing-message-group 'gnus-message-archive-group "24.1")
+
(defcustom gnus-mailing-list-groups nil
"*If non-nil a regexp matching groups that are really mailing lists.
This is useful when you're reading a mailing list that has been
@@ -241,10 +242,10 @@ See also the `mml-default-sign-method' variable."
:group 'gnus-message
:type 'boolean)
-(defcustom gnus-message-replyencrypt
- nil
+(defcustom gnus-message-replyencrypt t
"Automatically encrypt replies to encrypted messages.
See also the `mml-default-encrypt-method' variable."
+ :version "24.1"
:group 'gnus-message
:type 'boolean)
@@ -382,11 +383,13 @@ Thank you for your help in stamping out bugs.
(defvar gnus-article-reply nil)
(defmacro gnus-setup-message (config &rest forms)
(let ((winconf (make-symbol "gnus-setup-message-winconf"))
+ (winconf-name (make-symbol "gnus-setup-message-winconf-name"))
(buffer (make-symbol "gnus-setup-message-buffer"))
(article (make-symbol "gnus-setup-message-article"))
(yanked (make-symbol "gnus-setup-yanked-articles"))
(group (make-symbol "gnus-setup-message-group")))
`(let ((,winconf (current-window-configuration))
+ (,winconf-name gnus-current-window-configuration)
(,buffer (buffer-name (current-buffer)))
(,article gnus-article-reply)
(,yanked gnus-article-yanked-articles)
@@ -397,7 +400,6 @@ Thank you for your help in stamping out bugs.
(message-mode-hook (copy-sequence message-mode-hook)))
(setq mml-buffer-list nil)
(add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc)
- (add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc)
;; message-newsreader and message-mailer were formerly set in
;; gnus-inews-add-send-actions, but this is too late when
;; message-generate-headers-first is used. --ansel
@@ -420,7 +422,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 "")))
@@ -432,7 +434,7 @@ Thank you for your help in stamping out bugs.
(progn
,@forms)
(gnus-inews-add-send-actions ,winconf ,buffer ,article ,config
- ,yanked)
+ ,yanked ',winconf-name)
(setq gnus-message-buffer (current-buffer))
(set (make-local-variable 'gnus-message-group-art)
(cons ,group ,article))
@@ -475,7 +477,7 @@ Thank you for your help in stamping out bugs.
;;;###autoload
(defun gnus-msg-mail (&optional to subject other-headers continue
- switch-action yank-action send-actions)
+ switch-action yank-action send-actions return-action)
"Start editing a mail message to be sent.
Like `message-mail', but with Gnus paraphernalia, particularly the
Gcc: header for archiving purposes."
@@ -484,7 +486,7 @@ Gcc: header for archiving purposes."
mail-buf)
(gnus-setup-message 'message
(message-mail to subject other-headers continue
- nil yank-action send-actions))
+ nil yank-action send-actions return-action))
(when switch-action
(setq mail-buf (current-buffer))
(switch-to-buffer buf)
@@ -527,7 +529,8 @@ Gcc: header for archiving purposes."
(throw 'found (cons (cadr elem) (caddr elem)))))))))
(defun gnus-inews-add-send-actions (winconf buffer article
- &optional config yanked)
+ &optional config yanked
+ winconf-name)
(gnus-make-local-hook 'message-sent-hook)
(add-hook 'message-sent-hook (if gnus-agent 'gnus-agent-possibly-do-gcc
'gnus-inews-do-gcc) nil t)
@@ -538,8 +541,10 @@ Gcc: header for archiving purposes."
`(lambda (&optional arg)
(gnus-post-method arg ,gnus-newsgroup-name)))
(message-add-action
- `(when (gnus-buffer-exists-p ,buffer)
- (set-window-configuration ,winconf))
+ `(progn
+ (setq gnus-current-window-configuration ',winconf-name)
+ (when (gnus-buffer-exists-p ,buffer)
+ (set-window-configuration ,winconf)))
'exit 'postpone 'kill)
(let ((to-be-marked (cond
(yanked
@@ -578,8 +583,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 +612,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 +633,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 +659,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 +689,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 +715,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))
@@ -826,7 +831,6 @@ header line with the old Message-ID."
(gnus-summary-mark-as-read ,article gnus-canceled-mark)))))
message-send-actions)
;; Add Gcc header.
- (gnus-inews-insert-archive-gcc)
(gnus-inews-insert-gcc))))
@@ -1028,8 +1032,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.
@@ -1082,14 +1086,14 @@ If VERY-WIDE, make a very wide reply."
(gnus-summary-work-articles 1))))
;; Allow user to require confirmation before replying by mail to the
;; author of a news article (or mail message).
- (when (or
- (not (or (gnus-news-group-p gnus-newsgroup-name)
+ (when (or (not (or (gnus-news-group-p gnus-newsgroup-name)
gnus-confirm-treat-mail-like-news))
(not (cond ((stringp gnus-confirm-mail-reply-to-news)
(string-match gnus-confirm-mail-reply-to-news
gnus-newsgroup-name))
((functionp gnus-confirm-mail-reply-to-news)
- (funcall gnus-confirm-mail-reply-to-news gnus-newsgroup-name))
+ (funcall gnus-confirm-mail-reply-to-news
+ gnus-newsgroup-name))
(t gnus-confirm-mail-reply-to-news)))
(if (or wide very-wide)
t ;; Ignore gnus-confirm-mail-reply-to-news for wide and very
@@ -1124,7 +1128,7 @@ If VERY-WIDE, make a very wide reply."
(insert headers))
(goto-char (point-max)))
(mml-quote-region (point) (point-max))
- (message-reply nil wide)
+ (message-reply nil wide 'switch-to-buffer)
(when yank
(gnus-inews-yank-articles yank))
(gnus-summary-handle-replysign)))))
@@ -1265,7 +1269,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>
@@ -1293,7 +1298,6 @@ composing a new message."
(goto-char (point-max))
(insert mail-header-separator)
;; Add Gcc header.
- (gnus-inews-insert-archive-gcc)
(gnus-inews-insert-gcc)
(goto-char (point-min))
(when (re-search-forward "^To:\\|^Newsgroups:" nil 'move)
@@ -1306,24 +1310,6 @@ See `gnus-summary-mail-forward' for ARG."
(interactive "P")
(gnus-summary-mail-forward arg t))
-(defvar gnus-nastygram-message
- "The following article was inappropriately posted to %s.\n\n"
- "Format string to insert in nastygrams.
-The current group name will be inserted at \"%s\".")
-
-(defun gnus-summary-mail-nastygram (n)
- "Send a nastygram to the author of the current article."
- (interactive "P")
- (when (or gnus-expert-user
- (gnus-y-or-n-p
- "Really send a nastygram to the author of the current article? "))
- (let ((group gnus-newsgroup-name))
- (gnus-summary-reply-with-original n)
- (set-buffer gnus-message-buffer)
- (message-goto-body)
- (insert (format gnus-nastygram-message group))
- (message-send-and-exit))))
-
(defun gnus-summary-mail-crosspost-complaint (n)
"Send a complaint about crossposting to the current article(s)."
(interactive "P")
@@ -1487,7 +1473,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))
@@ -1579,7 +1565,6 @@ this is a reply."
(gnus-setup-message 'compose-bounce
(message-bounce)
;; Add Gcc header.
- (gnus-inews-insert-archive-gcc)
(gnus-inews-insert-gcc)
;; If there are references, we fetch the article we answered to.
(when parent
@@ -1627,7 +1612,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)
@@ -1693,44 +1678,13 @@ this is a reply."
(gnus-group-mark-article-read group (cdr group-art)))
(kill-buffer (current-buffer)))))))))
-(defun gnus-inews-insert-gcc ()
- "Insert Gcc headers based on `gnus-outgoing-message-group'."
- (save-excursion
- (save-restriction
- (message-narrow-to-headers)
- (let* ((group gnus-outgoing-message-group)
- (gcc (cond
- ((functionp group)
- (funcall group))
- ((or (stringp group) (listp group))
- group))))
- (when gcc
- (insert "Gcc: "
- (if (stringp gcc)
- (if (string-match " " gcc)
- (concat "\"" gcc "\"")
- gcc)
- (mapconcat (lambda (group)
- (if (string-match " " group)
- (concat "\"" group "\"")
- group))
- gcc " "))
- "\n"))))))
-
-(defun gnus-inews-insert-archive-gcc (&optional group)
+(defun gnus-inews-insert-gcc (&optional group)
"Insert the Gcc to say where the article is to be archived."
- (setq group (cond (group
- (gnus-group-decoded-name group))
- (gnus-newsgroup-name
- (gnus-group-decoded-name gnus-newsgroup-name))
- (t
- "")))
- (let* ((var gnus-message-archive-group)
+ (let* ((group (or group gnus-newsgroup-name))
+ (group (when group (gnus-group-decoded-name group)))
+ (var (or gnus-outgoing-message-group gnus-message-archive-group))
(gcc-self-val
- (and gnus-newsgroup-name
- (not (equal gnus-newsgroup-name ""))
- (gnus-group-find-parameter
- gnus-newsgroup-name 'gcc-self)))
+ (and group (gnus-group-find-parameter group 'gcc-self)))
result
(groups
(cond
@@ -1890,7 +1844,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 +1947,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 0fc779628b5..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, 2011 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 a35e6fe9303..dc6feeec0ab 100644
--- a/lisp/gnus/gnus-picon.el
+++ b/lisp/gnus/gnus-picon.el
@@ -1,7 +1,6 @@
;;; gnus-picon.el --- displaying pretty icons in Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news xpm annotation glyph faces
@@ -38,7 +37,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 +84,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 +156,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 +193,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 +313,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 e75c975d718..ce5a837eaef 100644
--- a/lisp/gnus/gnus-range.el
+++ b/lisp/gnus/gnus-range.el
@@ -1,7 +1,6 @@
;;; gnus-range.el --- range and sequence functions for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -59,6 +58,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."
@@ -654,5 +683,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 0f7071f821c..02e4ce7e2e6 100644
--- a/lisp/gnus/gnus-registry.el
+++ b/lisp/gnus/gnus-registry.el
@@ -1,7 +1,6 @@
;;; gnus-registry.el --- article registry for Gnus
-;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Ted Zlatanov <tzz@lifelogs.com>
;; Keywords: news registry
@@ -24,7 +23,7 @@
;;; Commentary:
;; This is the gnus-registry.el package, which works with all
-;; backends, not just nnmail (e.g. NNTP). The major issue is that it
+;; Gnus backends, not just nnmail. The major issue is that it
;; doesn't go across backends, so for instance if an article is in
;; nnml:sys and you see a reference to it in nnimap splitting, the
;; article will end up in nnimap:sys
@@ -32,12 +31,22 @@
;; gnus-registry.el intercepts article respooling, moving, deleting,
;; and copying for all backends. If it doesn't work correctly for
;; you, submit a bug report and I'll be glad to fix it. It needs
-;; documentation in the manual (also on my to-do list).
+;; better documentation in the manual (also on my to-do list).
-;; Put this in your startup file (~/.gnus.el for instance)
+;; If you want to track recipients (and you should to make the
+;; gnus-registry splitting work better), you need the To and Cc
+;; headers collected by Gnus. Note that in more recent Gnus versions
+;; this is already the case: look at `gnus-extra-headers' to be sure.
+
+;; ;;; you may also want Gcc Newsgroups Keywords X-Face
+;; (add-to-list 'gnus-extra-headers 'To)
+;; (add-to-list 'gnus-extra-headers 'Cc)
+;; (setq nnmail-extra-headers gnus-extra-headers)
+
+;; Put this in your startup file (~/.gnus.el for instance) or use Customize:
;; (setq gnus-registry-max-entries 2500
-;; gnus-registry-use-long-group-names t)
+;; gnus-registry-track-extra '(sender subject recipient))
;; (gnus-registry-initialize)
@@ -45,21 +54,34 @@
;; (: 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
-;; - articles that are spooled to a different backend should be handled
+;; - articles that are spooled to a different backend should be moved
+;; after splitting
;;; Code:
(eval-when-compile (require 'cl))
+(eval-when-compile
+ (when (null (ignore-errors (require 'ert)))
+ (defmacro* ert-deftest (name () &body docstring-keys-and-body))))
+
+(ignore-errors
+ (require 'ert))
(require 'gnus)
(require 'gnus-int)
(require 'gnus-sum)
+(require 'gnus-art)
(require 'gnus-util)
(require 'nnmail)
+(require 'easymenu)
+(require 'registry)
(defvar gnus-adaptive-word-syntax-table)
@@ -71,12 +93,7 @@
:version "22.1"
:group 'gnus)
-(defvar gnus-registry-hashtb (make-hash-table
- :size 256
- :test 'equal)
- "*The article registry by Message ID.")
-
-(defcustom gnus-registry-marks
+(defvar gnus-registry-marks
'((Important
:char ?i
:image "summary_important")
@@ -96,37 +113,37 @@
"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.
Each entry must have an image string to be useful for visual
-display."
- :group 'gnus-registry
- :type '(repeat :tag "Registry Marks"
- (cons :tag "Mark"
- (symbol :tag "Name")
- (checklist :tag "Options" :greedy t
- (group :inline t
- (const :format "" :value :char)
- (character :tag "Character code"))
- (group :inline t
- (const :format "" :value :image)
- (string :tag "Image"))))))
+display.")
(defcustom gnus-registry-default-mark 'To-Do
"The default mark. Should be a valid key for `gnus-registry-marks'."
:group 'gnus-registry
:type 'symbol)
-(defcustom gnus-registry-unfollowed-groups
- '("delayed$" "drafts$" "queue$" "INBOX$")
+(defcustom gnus-registry-unfollowed-addresses
+ (list (regexp-quote user-mail-address))
+ "List of addresses that gnus-registry-split-fancy-with-parent won't trace.
+The addresses are matched, they don't have to be fully qualified.
+In the messages, these addresses can be the sender or the
+recipients."
+ :group 'gnus-registry
+ :type '(repeat regexp))
+
+(defcustom gnus-registry-unfollowed-groups
+ '("delayed$" "drafts$" "queue$" "INBOX$" "^nnmairix:" "archive")
"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
+qualified. This parameter tells the Gnus 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))
@@ -134,77 +151,74 @@ references.'"
"Whether the registry should be installed."
:group 'gnus-registry
:type '(choice (const :tag "Never Install" nil)
- (const :tag "Always Install" t)
- (const :tag "Ask Me" ask)))
+ (const :tag "Always Install" t)
+ (const :tag "Ask Me" ask)))
-(defcustom gnus-registry-clean-empty t
- "Whether the empty registry entries should be deleted.
-Registry entries are considered empty when they have no groups
-and no extra data."
- :group 'gnus-registry
- :type 'boolean)
+(defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning.
-(defcustom gnus-registry-use-long-group-names t
- "Whether the registry should use long group names."
- :group 'gnus-registry
- :type 'boolean)
+(defvar gnus-registry-misc-menus nil) ; ugly way to keep the menus
-(defcustom gnus-registry-max-track-groups 20
- "The maximum number of non-unique group matches to check for a message ID."
- :group 'gnus-registry
- :type '(radio (const :format "Unlimited " nil)
- (integer :format "Maximum non-unique matches: %v")))
+(make-obsolete-variable 'gnus-registry-clean-empty nil "23.4")
+(make-obsolete-variable 'gnus-registry-use-long-group-names nil "23.4")
+(make-obsolete-variable 'gnus-registry-max-track-groups nil "23.4")
+(make-obsolete-variable 'gnus-registry-entry-caching nil "23.4")
+(make-obsolete-variable 'gnus-registry-trim-articles-without-groups nil "23.4")
-(defcustom gnus-registry-track-extra nil
+(defcustom gnus-registry-track-extra '(subject sender recipient)
"Whether the registry should track extra data about a message.
-The Subject and Sender (From:) headers are currently tracked this
-way."
+The subject, recipients (To: and Cc:), and Sender (From:) headers
+are tracked this way by default."
:group 'gnus-registry
:type
'(set :tag "Tracking choices"
(const :tag "Track by subject (Subject: header)" subject)
+ (const :tag "Track by recipient (To: and Cc: headers)" recipient)
(const :tag "Track by sender (From: header)" sender)))
(defcustom gnus-registry-split-strategy nil
- "Whether the registry should track extra data about a message.
-The Subject and Sender (From:) headers are currently tracked this
-way."
- :group 'gnus-registry
- :type
- '(choice :tag "Tracking choices"
- (const :tag "Only use single choices, discard multiple matches" nil)
- (const :tag "Majority of matches wins" majority)
- (const :tag "First found wins" first)))
+ "The splitting strategy applied to the keys in `gnus-registry-track-extra'.
+
+Given a set of unique found groups G and counts for each element
+of G, and a key K (typically 'sender or 'subject):
-(defcustom gnus-registry-entry-caching t
- "Whether the registry should cache extra information."
+When nil, if G has only one element, use it. Otherwise give up.
+This is the fastest but also least useful strategy.
+
+When 'majority, use the majority by count. So if there is a
+group with the most articles counted by K, use that. Ties are
+resolved in no particular order, simply the first one found wins.
+This is the slowest strategy but also the most accurate one.
+
+When 'first, the first element of G wins. This is fast and
+should be OK if your senders and subjects don't \"bleed\" across
+groups."
:group 'gnus-registry
- :type 'boolean)
+ :type
+ '(choice :tag "Splitting strategy"
+ (const :tag "Only use single choices, discard multiple matches" nil)
+ (const :tag "Majority of matches wins" majority)
+ (const :tag "First found wins" first)))
(defcustom gnus-registry-minimum-subject-length 5
"The minimum length of a subject before it's considered trackable."
:group 'gnus-registry
:type 'integer)
-(defcustom gnus-registry-trim-articles-without-groups t
- "Whether the registry should clean out message IDs without groups."
- :group 'gnus-registry
- :type 'boolean)
-
-(defcustom gnus-registry-extra-entries-precious '(marks)
- "What extra entries are precious, meaning they won't get trimmed.
-When you save the Gnus registry, it's trimmed to be no longer
-than `gnus-registry-max-entries' (which is nil by default, so no
-trimming happens). Any entries with extra data in this list (by
-default, marks are included, so articles with marks are
-considered precious) will not be trimmed."
+(defcustom gnus-registry-extra-entries-precious '(mark)
+ "What extra keys are precious, meaning entries with them won't get pruned.
+By default, 'mark is included, so articles with marks are
+considered precious.
+
+Before you save the Gnus registry, it's pruned. Any entries with
+keys in this list will not be pruned. All other entries go to
+the Bit Bucket."
:group 'gnus-registry
:type '(repeat symbol))
-(defcustom gnus-registry-cache-file
- (nnheader-concat
- (or gnus-dribble-directory gnus-home-directory "~/")
- ".gnus.registry.eld")
+(defcustom gnus-registry-cache-file
+ (nnheader-concat
+ (or gnus-dribble-directory gnus-home-directory "~/")
+ ".gnus.registry.eioio")
"File where the Gnus registry will be stored."
:group 'gnus-registry
:type 'file)
@@ -213,254 +227,163 @@ considered precious) will not be trimmed."
"Maximum number of entries in the registry, nil for unlimited."
:group 'gnus-registry
:type '(radio (const :format "Unlimited " nil)
- (integer :format "Maximum number: %v")))
-
-(defun gnus-registry-track-subject-p ()
- (memq 'subject gnus-registry-track-extra))
+ (integer :format "Maximum number: %v")))
-(defun gnus-registry-track-sender-p ()
- (memq 'sender gnus-registry-track-extra))
+(defcustom gnus-registry-max-pruned-entries nil
+ "Maximum number of pruned entries in the registry, nil for unlimited."
+ :group 'gnus-registry
+ :type '(radio (const :format "Unlimited " nil)
+ (integer :format "Maximum number: %v")))
+
+(defun gnus-registry-fixup-registry (db)
+ (when db
+ (let ((old (oref db :tracked)))
+ (oset db :precious
+ (append gnus-registry-extra-entries-precious
+ '()))
+ (oset db :max-hard
+ (or gnus-registry-max-entries
+ most-positive-fixnum))
+ (oset db :max-soft
+ (or gnus-registry-max-pruned-entries
+ most-positive-fixnum))
+ (oset db :tracked
+ (append gnus-registry-track-extra
+ '(mark group keyword)))
+ (when (not (equal old (oref db :tracked)))
+ (gnus-message 4 "Reindexing the Gnus registry (tracked change)")
+ (registry-reindex db))))
+ db)
+
+(defun gnus-registry-make-db (&optional file)
+ (interactive "fGnus registry persistence file: \n")
+ (gnus-registry-fixup-registry
+ (registry-db
+ "Gnus Registry"
+ :file (or file gnus-registry-cache-file)
+ ;; these parameters are set in `gnus-registry-fixup-registry'
+ :max-hard most-positive-fixnum
+ :max-soft most-positive-fixnum
+ :precious nil
+ :tracked nil)))
+
+(defvar gnus-registry-db (gnus-registry-make-db)
+ "*The article registry by Message ID. See `registry-db'")
+
+;; top-level registry data management
+(defun gnus-registry-remake-db (&optional forsure)
+ "Remake the registry database after customization.
+This is not required after changing `gnus-registry-cache-file'."
+ (interactive (list (y-or-n-p "Remake and CLEAR the Gnus registry? ")))
+ (when forsure
+ (gnus-message 4 "Remaking the Gnus registry")
+ (setq gnus-registry-db (gnus-registry-make-db))))
-(defun gnus-registry-cache-read ()
+(defun gnus-registry-read ()
"Read the registry cache file."
(interactive)
(let ((file gnus-registry-cache-file))
- (when (file-exists-p file)
- (gnus-message 5 "Reading %s..." file)
- (gnus-load file)
- (gnus-message 5 "Reading %s...done" file))))
-
-;; FIXME: Get rid of duplicated code, cf. `gnus-save-newsrc-file' in
-;; `gnus-start.el'. --rsteib
-(defun gnus-registry-cache-save ()
+ (condition-case nil
+ (progn
+ (gnus-message 5 "Reading Gnus registry from %s..." file)
+ (setq gnus-registry-db (gnus-registry-fixup-registry
+ (eieio-persistent-read file)))
+ (gnus-message 5 "Reading Gnus registry from %s...done" file))
+ (error
+ (gnus-message
+ 1
+ "The Gnus registry could not be loaded from %s, creating a new one"
+ file)
+ (gnus-registry-remake-db t)))))
+
+(defun gnus-registry-save (&optional file db)
"Save the registry cache file."
(interactive)
- (let ((file gnus-registry-cache-file))
- (save-excursion
- (set-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)
- (setq default-directory (file-name-directory buffer-file-name))
- (buffer-disable-undo)
- (erase-buffer)
- (gnus-message 5 "Saving %s..." file)
- (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
- t "gnus registry startup file" 'gnus-registry-alist)
- (gnus-registry-cache-whitespace file)
- (save-buffer))
- (let ((coding-system-for-write gnus-ding-file-coding-system)
- (version-control gnus-backup-startup-file)
- (startup-file file)
- (working-dir (file-name-directory file))
- working-file
- (i -1))
- ;; Generate the name of a non-existent file.
- (while (progn (setq working-file
- (format
- (if (and (eq system-type 'ms-dos)
- (not (gnus-long-file-names)))
- "%s#%d.tm#" ; MSDOS limits files to 8+3
- "%s#tmp#%d")
- working-dir (setq i (1+ i))))
- (file-exists-p working-file)))
-
- (unwind-protect
- (progn
- (gnus-with-output-to-file working-file
- (gnus-gnus-to-quick-newsrc-format
- t "gnus registry startup file" 'gnus-registry-alist))
-
- ;; These bindings will mislead the current buffer
- ;; into thinking that it is visiting the startup
- ;; file.
- (let ((buffer-backed-up nil)
- (buffer-file-name startup-file)
- (file-precious-flag t)
- (setmodes (file-modes startup-file)))
- ;; Backup the current version of the startup file.
- (backup-buffer)
-
- ;; Replace the existing startup file with the temp file.
- (rename-file working-file startup-file t)
- (gnus-set-file-modes startup-file setmodes)))
- (condition-case nil
- (delete-file working-file)
- (file-error nil)))))
-
- (gnus-kill-buffer (current-buffer))
- (gnus-message 5 "Saving %s...done" file))))
-
-;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu>
-;; Save the gnus-registry file with extra line breaks.
-(defun gnus-registry-cache-whitespace (filename)
- (gnus-message 7 "Adding whitespace to %s" filename)
- (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))))
-
-(defun gnus-registry-save (&optional force)
- (when (or gnus-registry-dirty force)
- (let ((caching gnus-registry-entry-caching))
- ;; turn off entry caching, so mtime doesn't get recorded
- (setq gnus-registry-entry-caching nil)
- ;; remove entry caches
- (maphash
- (lambda (key value)
- (if (hash-table-p value)
- (remhash key gnus-registry-hashtb)))
- gnus-registry-hashtb)
- ;; remove empty entries
- (when gnus-registry-clean-empty
- (gnus-registry-clean-empty-function))
- ;; now trim and clean text properties from the registry appropriately
- (setq gnus-registry-alist
- (gnus-registry-remove-alist-text-properties
- (gnus-registry-trim
- (gnus-hashtable-to-alist
- gnus-registry-hashtb))))
- ;; really save
- (gnus-registry-cache-save)
- (setq gnus-registry-entry-caching caching)
- (setq gnus-registry-dirty nil))))
-
-(defun gnus-registry-clean-empty-function ()
- "Remove all empty entries from the registry. Returns count thereof."
- (let ((count 0))
-
- (maphash
- (lambda (key value)
- (when (stringp key)
- (dolist (group (gnus-registry-fetch-groups key))
- (when (gnus-parameter-registry-ignore group)
- (gnus-message
- 10
- "gnus-registry: deleted ignored group %s from key %s"
- group key)
- (gnus-registry-delete-group key group)))
-
- (unless (gnus-registry-group-count key)
- (gnus-registry-delete-id key))
-
- (unless (or
- (gnus-registry-fetch-group key)
- ;; TODO: look for specific extra data here!
- ;; in this example, we look for 'label
- (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"
- key)
- (gnus-registry-delete-id key))))
-
- gnus-registry-hashtb)
- count))
-
-(defun gnus-registry-read ()
- (gnus-registry-cache-read)
- (setq gnus-registry-hashtb (gnus-alist-to-hashtable gnus-registry-alist))
- (setq gnus-registry-dirty nil))
-
-(defun gnus-registry-remove-alist-text-properties (v)
- "Remove text properties from all strings in alist."
- (if (stringp v)
- (gnus-string-remove-all-properties v)
- (if (and (listp v) (listp (cdr v)))
- (mapcar 'gnus-registry-remove-alist-text-properties v)
- (if (and (listp v) (stringp (cdr v)))
- (cons (gnus-registry-remove-alist-text-properties (car v))
- (gnus-registry-remove-alist-text-properties (cdr v)))
- v))))
-
-(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)
- alist ; just return the alist
- ;; else, when given max-entries, trim the alist
- (let* ((timehash (make-hash-table
- :size 20000
- :test 'equal))
- (precious (make-hash-table
- :size 20000
- :test 'equal))
- (trim-length (- (length alist) gnus-registry-max-entries))
- (trim-length (if (natnump trim-length) trim-length 0))
- precious-list junk-list)
- (maphash
- (lambda (key value)
- (let ((extra (gnus-registry-fetch-extra key)))
- (dolist (item gnus-registry-extra-entries-precious)
- (dolist (e extra)
- (when (equal (nth 0 e) item)
- (puthash key t precious)
- (return))))
- (puthash key (gnus-registry-fetch-extra key 'mtime) timehash)))
- gnus-registry-hashtb)
-
- (dolist (item alist)
- (let ((key (nth 0 item)))
- (if (gethash key precious)
- (push item precious-list)
- (push item junk-list))))
-
- (sort
- junk-list
- (lambda (a b)
- (let ((t1 (or (cdr (gethash (car a) timehash))
- '(0 0 0)))
- (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))))))
-
+ (let ((file (or file gnus-registry-cache-file))
+ (db (or db gnus-registry-db)))
+ (gnus-message 5 "Saving Gnus registry (%d entries) to %s..."
+ (registry-size db) file)
+ (registry-prune db)
+ ;; TODO: call (gnus-string-remove-all-properties v) on all elements?
+ (eieio-persistent-save db file)
+ (gnus-message 5 "Saving Gnus registry (size %d) to %s...done"
+ (registry-size db) file)))
+
+;; article move/copy/spool/delete actions
(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
- (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))
- (to-name (if to to "the Bit Bucket"))
- (old-entry (gethash id gnus-registry-hashtb)))
- (gnus-message 7 "Registry: article %s %s from %s to %s"
- id
- (if method "respooling" "going")
- from
- to)
-
- ;; All except copy will need a delete
- (gnus-registry-delete-group id from)
-
- (when (equal 'copy action)
- (gnus-registry-add-group id from subject sender)) ; undo the delete
-
- (gnus-registry-add-group id to subject sender)))
-
-(defun gnus-registry-spool-action (id group &optional subject sender)
- (let ((group (gnus-group-guess-full-name-from-command-method group)))
+ (subject (mail-header-subject data-header))
+ (extra (mail-header-extra data-header))
+ (recipients (gnus-registry-sort-addresses
+ (or (cdr-safe (assq 'Cc extra)) "")
+ (or (cdr-safe (assq 'To extra)) "")))
+ (sender (nth 0 (gnus-registry-extract-addresses
+ (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))
+ (to-name (if to to "the Bit Bucket")))
+ (gnus-message 7 "Gnus registry: article %s %s from %s to %s"
+ id (if method "respooling" "going") from to)
+
+ (gnus-registry-handle-action
+ id
+ ;; unless copying, remove the old "from" group
+ (if (not (equal 'copy action)) from nil)
+ to subject sender recipients)))
+
+(defun gnus-registry-spool-action (id group &optional subject sender recipients)
+ (let ((to (gnus-group-guess-full-name-from-command-method group))
+ (recipients (or recipients
+ (gnus-registry-sort-addresses
+ (or (message-fetch-field "cc") "")
+ (or (message-fetch-field "to") ""))))
+ (subject (or subject (message-fetch-field "subject")))
+ (sender (or sender (message-fetch-field "from"))))
(when (and (stringp id) (string-match "\r$" id))
(setq id (substring id 0 -1)))
- (gnus-message 7 "Registry: article %s spooled to %s"
- id
- group)
- (gnus-registry-add-group id group subject sender)))
+ (gnus-message 7 "Gnus registry: article %s spooled to %s"
+ id
+ to)
+ (gnus-registry-handle-action id nil to subject sender recipients)))
+
+(defun gnus-registry-handle-action (id from to subject sender
+ &optional recipients)
+ (gnus-message
+ 10
+ "gnus-registry-handle-action %S" (list id from to subject sender recipients))
+ (let ((db gnus-registry-db)
+ ;; if the group is ignored, set the destination to nil (same as delete)
+ (to (if (gnus-registry-ignore-group-p to) nil to))
+ ;; safe if not found
+ (entry (gnus-registry-get-or-make-entry id))
+ (subject (gnus-string-remove-all-properties
+ (gnus-registry-simplify-subject subject)))
+ (sender (gnus-string-remove-all-properties sender)))
+
+ ;; this could be done by calling `gnus-registry-set-id-key'
+ ;; several times but it's better to bunch the transactions
+ ;; together
+
+ (registry-delete db (list id) nil)
+ (when from
+ (setq entry (cons (delete from (assoc 'group entry))
+ (assq-delete-all 'group entry))))
+
+ (dolist (kv `((group ,to)
+ (sender ,sender)
+ (recipient ,@recipients)
+ (subject ,subject)))
+ (when (second kv)
+ (let ((new (or (assq (first kv) entry)
+ (list (first kv)))))
+ (dolist (toadd (cdr kv))
+ (add-to-list 'new toadd t))
+ (setq entry (cons new
+ (assq-delete-all (first kv) entry))))))
+ (gnus-message 10 "Gnus registry: new entry for %s is %S"
+ id
+ entry)
+ (gnus-registry-insert db id entry)))
;; Function for nn{mail|imap}-split-fancy: look up all references in
;; the cache and if a match is found, return that group.
@@ -482,113 +405,153 @@ that group.
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
- (concat refstr " " reply-to)
- refstr))
- ;; these may not be used, but the code is cleaner having them up here
- (sender (gnus-string-remove-all-properties
- (message-fetch-field "from")))
- (subject (gnus-string-remove-all-properties
- (gnus-registry-simplify-subject
- (message-fetch-field "subject"))))
-
- (nnmail-split-fancy-with-parent-ignore-groups
- (if (listp nnmail-split-fancy-with-parent-ignore-groups)
- nnmail-split-fancy-with-parent-ignore-groups
- (list nnmail-split-fancy-with-parent-ignore-groups)))
- (log-agent "gnus-registry-split-fancy-with-parent")
- found found-full)
-
- ;; this is a big if-else statement. it uses
+ (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
+ (concat refstr " " reply-to)
+ refstr))
+ (references (and refstr (gnus-extract-references refstr)))
+ ;; these may not be used, but the code is cleaner having them up here
+ (sender (gnus-string-remove-all-properties
+ (message-fetch-field "from")))
+ (recipients (gnus-registry-sort-addresses
+ (or (message-fetch-field "cc") "")
+ (or (message-fetch-field "to") "")))
+ (subject (gnus-string-remove-all-properties
+ (gnus-registry-simplify-subject
+ (message-fetch-field "subject"))))
+
+ (nnmail-split-fancy-with-parent-ignore-groups
+ (if (listp nnmail-split-fancy-with-parent-ignore-groups)
+ nnmail-split-fancy-with-parent-ignore-groups
+ (list nnmail-split-fancy-with-parent-ignore-groups))))
+ (gnus-registry--split-fancy-with-parent-internal
+ :references references
+ :refstr refstr
+ :sender sender
+ :recipients recipients
+ :subject subject
+ :log-agent "Gnus registry fancy splitting with parent")))
+
+(defun* gnus-registry--split-fancy-with-parent-internal
+ (&rest spec
+ &key references refstr sender subject recipients log-agent
+ &allow-other-keys)
+ (gnus-message
+ 10
+ "gnus-registry--split-fancy-with-parent-internal %S" spec)
+ (let ((db gnus-registry-db)
+ found)
+ ;; this is a big chain of statements. it uses
;; gnus-registry-post-process-groups to filter the results after
;; every step.
- (cond
- ;; the references string must be valid and parse to valid references
- ((and refstr (gnus-extract-references refstr))
- (dolist (reference (nreverse (gnus-extract-references refstr)))
- (gnus-message
- 9
- "%s is looking for matches for reference %s from [%s]"
- log-agent reference refstr)
- (dolist (group (gnus-registry-fetch-groups
- reference
- gnus-registry-max-track-groups))
- (when (and group (gnus-registry-follow-group-p group))
- (gnus-message
- 7
- "%s traced the reference %s from [%s] to group %s"
- log-agent reference refstr group)
- (push group found))))
+ ;; the references string must be valid and parse to valid references
+ (when references
+ (gnus-message
+ 9
+ "%s is tracing references %s"
+ log-agent refstr)
+ (dolist (reference (nreverse references))
+ (gnus-message 9 "%s is looking up %s" log-agent reference)
+ (loop for group in (gnus-registry-get-id-key reference 'group)
+ when (gnus-registry-follow-group-p group)
+ do
+ (progn
+ (gnus-message 7 "%s traced %s to %s" log-agent reference group)
+ (push group found))))
;; filter the found groups and return them
;; the found groups are the full 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
- (not (equal (gnus-extract-address-component-email sender)
- user-mail-address)))
- (maphash
- (lambda (key value)
- (let ((this-sender (cdr
- (gnus-registry-fetch-extra key 'sender)))
- matches)
- (when (and this-sender
- (equal sender this-sender))
- (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)))))
- (push key matches)
- (gnus-message
- ;; raise level of messaging if gnus-registry-track-extra
- (if gnus-registry-track-extra 7 9)
- "%s (extra tracking) traced sender %s to groups %s (keys %s)"
- log-agent sender found matches))))
- 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
- "sender" sender found found-full)))
-
- ;; else: there were no matches, now try the extra tracking by subject
- ((and (gnus-registry-track-subject-p)
- subject
- (< gnus-registry-minimum-subject-length (length subject)))
- (maphash
- (lambda (key value)
- (let ((this-subject (cdr
- (gnus-registry-fetch-extra key 'subject)))
- matches)
- (when (and this-subject
- (equal subject this-subject))
- (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)))))
- (push key matches)
- (gnus-message
- ;; raise level of messaging if gnus-registry-track-extra
- (if gnus-registry-track-extra 7 9)
- "%s (extra tracking) traced subject %s to groups %s (keys %s)"
- log-agent subject found matches))))
- 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
- "subject" subject found found-full))))
- ;; after the (cond) we extract the actual value safely
- (car-safe found)))
+ (setq found (gnus-registry-post-process-groups
+ "references" refstr found)))
-(defun gnus-registry-post-process-groups (mode key groups groups-full)
- "Modifies GROUPS found by MODE for KEY to determine which ones to follow.
+ ;; else: there were no matches, now try the extra tracking by subject
+ (when (and (null found)
+ (memq 'subject gnus-registry-track-extra)
+ subject
+ (< gnus-registry-minimum-subject-length (length subject)))
+ (let ((groups (apply
+ 'append
+ (mapcar
+ (lambda (reference)
+ (gnus-registry-get-id-key reference 'group))
+ (registry-lookup-secondary-value db 'subject subject)))))
+ (setq found
+ (loop for group in groups
+ when (gnus-registry-follow-group-p group)
+ do (gnus-message
+ ;; warn more if gnus-registry-track-extra
+ (if gnus-registry-track-extra 7 9)
+ "%s (extra tracking) traced subject '%s' to %s"
+ log-agent subject group)
+ and collect group))
+ ;; filter the found groups and return them
+ ;; the found groups are NOT the full groups
+ (setq found (gnus-registry-post-process-groups
+ "subject" subject found))))
+
+ ;; else: there were no matches, try the extra tracking by sender
+ (when (and (null found)
+ (memq 'sender gnus-registry-track-extra)
+ sender
+ (not (gnus-grep-in-list
+ sender
+ gnus-registry-unfollowed-addresses)))
+ (let ((groups (apply
+ 'append
+ (mapcar
+ (lambda (reference)
+ (gnus-registry-get-id-key reference 'group))
+ (registry-lookup-secondary-value db 'sender sender)))))
+ (setq found
+ (loop for group in groups
+ when (gnus-registry-follow-group-p group)
+ do (gnus-message
+ ;; warn more if gnus-registry-track-extra
+ (if gnus-registry-track-extra 7 9)
+ "%s (extra tracking) traced sender '%s' to %s"
+ log-agent sender group)
+ and collect group)))
+
+ ;; filter the found groups and return them
+ ;; the found groups are NOT the full groups
+ (setq found (gnus-registry-post-process-groups
+ "sender" sender found)))
+
+ ;; else: there were no matches, try the extra tracking by recipient
+ (when (and (null found)
+ (memq 'recipient gnus-registry-track-extra)
+ recipients)
+ (dolist (recp recipients)
+ (when (and (null found)
+ (not (gnus-grep-in-list
+ recp
+ gnus-registry-unfollowed-addresses)))
+ (let ((groups (apply 'append
+ (mapcar
+ (lambda (reference)
+ (gnus-registry-get-id-key reference 'group))
+ (registry-lookup-secondary-value
+ db 'recipient recp)))))
+ (setq found
+ (loop for group in groups
+ when (gnus-registry-follow-group-p group)
+ do (gnus-message
+ ;; warn more if gnus-registry-track-extra
+ (if gnus-registry-track-extra 7 9)
+ "%s (extra tracking) traced recipient '%s' to %s"
+ log-agent recp group)
+ and collect group)))))
+
+ ;; filter the found groups and return them
+ ;; the found groups are NOT the full groups
+ (setq found (gnus-registry-post-process-groups
+ "recipients" (mapconcat 'identity recipients ", ") found)))
+
+ ;; after the (cond) we extract the actual value safely
+ (car-safe found)))
+
+(defun gnus-registry-post-process-groups (mode key groups)
+ "Inspects GROUPS found by MODE for KEY to determine which ones to follow.
MODE can be 'subject' or 'sender' for example. The KEY is the
value by which MODE was searched.
@@ -597,125 +560,203 @@ Transforms each group name to the equivalent short name.
Checks if the current Gnus method (from `gnus-command-method' or
from `gnus-newsgroup-name') is the same as the group's method.
-This is not possible if gnus-registry-use-long-group-names is
-false. Foreign methods are not supported so they are rejected.
+Foreign methods are not supported so they are rejected.
Reduces the list to a single group, or complains if that's not
-possible. Uses `gnus-registry-split-strategy' and GROUPS-FULL if
-necessary."
+possible. Uses `gnus-registry-split-strategy'."
(let ((log-agent "gnus-registry-post-process-group")
- out)
-
- ;; the strategy can be 'first, 'majority, or nil
- (when (eq gnus-registry-split-strategy 'first)
- (when groups
- (setq groups (list (car-safe groups)))))
-
- (when (eq gnus-registry-split-strategy 'majority)
- (let ((freq (make-hash-table
- :size 256
- :test 'equal)))
- (mapc (lambda(x) (puthash x (1+ (gethash x freq 0)) freq)) groups-full)
- (setq groups (list (car-safe
- (sort
- groups
- (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))
- (m2 (or gnus-command-method
- (gnus-find-method-for-group gnus-newsgroup-name)))
- (short-name (gnus-group-short-name group)))
- (if (gnus-methods-equal-p m1 m2)
- (progn
- ;; this is REALLY just for debugging
- (gnus-message
- 10
- "%s stripped group %s to %s"
- log-agent group short-name)
- (unless (member short-name out)
- (push short-name out)))
- ;; else...
- (gnus-message
- 7
- "%s ignored foreign group %s"
- log-agent group))))
- (setq out groups))
- (when (cdr-safe out)
- (gnus-message
- 5
- "%s: too many extra matches (%s) for %s %s. Returning none."
- log-agent out mode key)
- (setq out nil))
- out))
+ (desc (format "%d groups" (length groups)))
+ out chosen)
+ ;; the strategy can be nil, in which case chosen is nil
+ (setq chosen
+ (case gnus-registry-split-strategy
+ ;; default, take only one-element lists into chosen
+ ((nil)
+ (and (= (length groups) 1)
+ (car-safe groups)))
+
+ ((first)
+ (car-safe groups))
+
+ ((majority)
+ (let ((freq (make-hash-table
+ :size 256
+ :test 'equal)))
+ (mapc (lambda (x) (let ((x (gnus-group-short-name x)))
+ (puthash x (1+ (gethash x freq 0)) freq)))
+ groups)
+ (setq desc (format "%d groups, %d unique"
+ (length groups)
+ (hash-table-count freq)))
+ (car-safe
+ (sort groups
+ (lambda (a b)
+ (> (gethash (gnus-group-short-name a) freq 0)
+ (gethash (gnus-group-short-name b) freq 0)))))))))
+
+ (if chosen
+ (gnus-message
+ 9
+ "%s: strategy %s on %s produced %s"
+ log-agent gnus-registry-split-strategy desc chosen)
+ (gnus-message
+ 9
+ "%s: strategy %s on %s did not produce an answer"
+ log-agent
+ (or gnus-registry-split-strategy "default")
+ desc))
+
+ (setq groups (and chosen (list chosen)))
+
+ (dolist (group groups)
+ (let ((m1 (gnus-find-method-for-group group))
+ (m2 (or gnus-command-method
+ (gnus-find-method-for-group gnus-newsgroup-name)))
+ (short-name (gnus-group-short-name group)))
+ (if (gnus-methods-equal-p m1 m2)
+ (progn
+ ;; this is REALLY just for debugging
+ (when (not (equal group short-name))
+ (gnus-message
+ 10
+ "%s: stripped group %s to %s"
+ log-agent group short-name))
+ (add-to-list 'out short-name))
+ ;; else...
+ (gnus-message
+ 7
+ "%s: ignored foreign group %s"
+ log-agent group))))
+
+ (setq out (delq nil out))
+
+ (cond
+ ((= (length out) 1) out)
+ ((null out)
+ (gnus-message
+ 5
+ "%s: no matches for %s '%s'."
+ log-agent mode key)
+ nil)
+ (t (gnus-message
+ 5
+ "%s: too many extra matches (%s) for %s '%s'. Returning none."
+ log-agent out mode key)
+ nil))))
(defun gnus-registry-follow-group-p (group)
"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
- group
- gnus-registry-unfollowed-groups)
- (gnus-registry-grep-in-list
- group
- nnmail-split-fancy-with-parent-ignore-groups))))
+ (and group
+ (not (or (gnus-grep-in-list
+ group
+ gnus-registry-unfollowed-groups)
+ (gnus-grep-in-list
+ group
+ nnmail-split-fancy-with-parent-ignore-groups)))))
+
+;; note that gnus-registry-ignored-groups is defined in gnus.el as a
+;; group/topic parameter and an associated variable!
+
+;; we do special logic for ignoring to accept regular expressions and
+;; nnmail-split-fancy-with-parent-ignore-groups as well
+(defun gnus-registry-ignore-group-p (group)
+ "Determines if a group name should be ignored.
+Consults `gnus-registry-ignored-groups' and
+`nnmail-split-fancy-with-parent-ignore-groups'."
+ (and group
+ (or (gnus-grep-in-list
+ group
+ (delq nil (mapcar (lambda (g)
+ (cond
+ ((stringp g) g)
+ ((and (listp g) (nth 1 g))
+ (nth 0 g))
+ (t nil))) gnus-registry-ignored-groups)))
+ ;; only use `gnus-parameter-registry-ignore' if
+ ;; `gnus-registry-ignored-groups' is a list of lists
+ ;; (it can be a list of regexes)
+ (and (listp (nth 0 gnus-registry-ignored-groups))
+ (get-buffer "*Group*") ; in automatic tests this is false
+ (gnus-parameter-registry-ignore group))
+ (gnus-grep-in-list
+ group
+ nnmail-split-fancy-with-parent-ignore-groups))))
(defun gnus-registry-wash-for-keywords (&optional force)
+ "Get the keywords of the current article.
+Overrides existing keywords with FORCE set non-nil."
(interactive)
(let ((id (gnus-registry-fetch-message-id-fast gnus-current-article))
- word words)
- (if (or (not (gnus-registry-fetch-extra id 'keywords))
- force)
- (save-excursion
- (set-buffer gnus-article-buffer)
- (article-goto-body)
- (save-window-excursion
- (save-restriction
- (narrow-to-region (point) (point-max))
- (with-syntax-table gnus-adaptive-word-syntax-table
- (while (re-search-forward "\\b\\w+\\b" nil t)
- (setq word (gnus-registry-remove-alist-text-properties
- (downcase (buffer-substring
- (match-beginning 0) (match-end 0)))))
- (if (> (length word) 3)
- (push word words))))))
- (gnus-registry-store-extra-entry id 'keywords words)))))
+ word words)
+ (if (or (not (gnus-registry-get-id-key id 'keyword))
+ force)
+ (with-current-buffer gnus-article-buffer
+ (article-goto-body)
+ (save-window-excursion
+ (save-restriction
+ (narrow-to-region (point) (point-max))
+ (with-syntax-table gnus-adaptive-word-syntax-table
+ (while (re-search-forward "\\b\\w+\\b" nil t)
+ (setq word (gnus-string-remove-all-properties
+ (downcase (buffer-substring
+ (match-beginning 0) (match-end 0)))))
+ (if (> (length word) 2)
+ (push word words))))))
+ (gnus-registry-set-id-key id 'keyword words)))))
+
+(defun gnus-registry-keywords ()
+ (let ((table (registry-lookup-secondary gnus-registry-db 'keyword)))
+ (when table (maphash (lambda (k v) k) table))))
(defun gnus-registry-find-keywords (keyword)
- (interactive "skeyword: ")
- (let (articles)
- (maphash
- (lambda (key value)
- (when (member keyword
- (cdr-safe (gnus-registry-fetch-extra key 'keywords)))
- (push key articles)))
- gnus-registry-hashtb)
- articles))
+ (interactive (list
+ (completing-read "Keyword: " (gnus-registry-keywords) nil t)))
+ (registry-lookup-secondary-value gnus-registry-db 'keyword keyword))
(defun gnus-registry-register-message-ids ()
"Register the Message-ID of every article in the group"
(unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
(dolist (article gnus-newsgroup-articles)
- (let ((id (gnus-registry-fetch-message-id-fast article)))
- (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-newsgroup-name
- (gnus-registry-fetch-simplified-message-subject-fast article)
- (gnus-registry-fetch-sender-fast article)))))))
-
+ (let* ((id (gnus-registry-fetch-message-id-fast article))
+ (groups (gnus-registry-get-id-key id 'group)))
+ (unless (member gnus-newsgroup-name groups)
+ (gnus-message 9 "Registry: Registering article %d with group %s"
+ article gnus-newsgroup-name)
+ (gnus-registry-handle-action id nil gnus-newsgroup-name
+ (gnus-registry-fetch-simplified-message-subject-fast article)
+ (gnus-registry-fetch-sender-fast article)
+ (gnus-registry-fetch-recipients-fast article)))))))
+
+;; message field fetchers
(defun gnus-registry-fetch-message-id-fast (article)
"Fetch the Message-ID quickly, using the internal gnus-data-list function"
(if (and (numberp article)
- (assoc article (gnus-data-list nil)))
+ (assoc article (gnus-data-list nil)))
(mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
nil))
+(defun gnus-registry-extract-addresses (text)
+ "Extract all the addresses in a normalized way from TEXT.
+Returns an unsorted list of strings in the name <address> format.
+Addresses without a name will say \"noname\"."
+ (mapcar (lambda (add)
+ (gnus-string-remove-all-properties
+ (let* ((name (or (nth 0 add) "noname"))
+ (addr (nth 1 add))
+ (addr (if (bufferp addr)
+ (with-current-buffer addr
+ (buffer-string))
+ addr)))
+ (format "%s <%s>" name addr))))
+ (mail-extract-address-components text t)))
+
+(defun gnus-registry-sort-addresses (&rest addresses)
+ "Return a normalized and sorted list of ADDRESSES."
+ (sort (apply 'nconc (mapcar 'gnus-registry-extract-addresses addresses))
+ 'string-lessp))
+
(defun gnus-registry-simplify-subject (subject)
(if (stringp subject)
(gnus-simplify-subject subject)
@@ -724,51 +765,53 @@ Consults `gnus-registry-unfollowed-groups' and
(defun gnus-registry-fetch-simplified-message-subject-fast (article)
"Fetch the Subject quickly, using the internal gnus-data-list function"
(if (and (numberp article)
- (assoc article (gnus-data-list nil)))
+ (assoc article (gnus-data-list nil)))
(gnus-string-remove-all-properties
(gnus-registry-simplify-subject
- (mail-header-subject (gnus-data-header
- (assoc article (gnus-data-list nil))))))
+ (mail-header-subject (gnus-data-header
+ (assoc article (gnus-data-list nil))))))
nil))
(defun gnus-registry-fetch-sender-fast (article)
- "Fetch the Sender quickly, using the internal gnus-data-list function"
+ (gnus-registry-fetch-header-fast "from" article))
+
+(defun gnus-registry-fetch-recipients-fast (article)
+ (gnus-registry-sort-addresses
+ (or (ignore-errors (gnus-registry-fetch-header-fast "Cc" article)) "")
+ (or (ignore-errors (gnus-registry-fetch-header-fast "To" article)) "")))
+
+(defun gnus-registry-fetch-header-fast (article header)
+ "Fetch the HEADER quickly, using the internal gnus-data-list function"
(if (and (numberp article)
- (assoc article (gnus-data-list nil)))
+ (assoc article (gnus-data-list nil)))
(gnus-string-remove-all-properties
- (mail-header-from (gnus-data-header
- (assoc article (gnus-data-list nil)))))
+ (cdr (assq header (gnus-data-header
+ (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))))))
-
+;; registry marks glue
(defun gnus-registry-do-marks (type function)
"For each known mark, call FUNCTION for each cell of type TYPE.
FUNCTION should take two parameters, a mark symbol and the cell value."
(dolist (mark-info gnus-registry-marks)
(let* ((mark (car-safe mark-info))
- (data (cdr-safe mark-info))
- (cell-data (plist-get data type)))
+ (data (cdr-safe mark-info))
+ (cell-data (plist-get data type)))
(when cell-data
- (funcall function mark cell-data)))))
+ (funcall function mark cell-data)))))
;;; this is ugly code, but I don't know how to do it better
(defun gnus-registry-install-shortcuts ()
"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
- (format "gnus-registry-%%s-article-%s-mark" mark)))
+ (format "gnus-registry-%%s-article-%s-mark" mark)))
;;; The following generates these functions:
;;; (defun gnus-registry-set-article-Important-mark (&rest articles)
@@ -780,341 +823,299 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
;;; (interactive (gnus-summary-work-articles current-prefix-arg))
;;; (gnus-registry-set-article-mark-internal 'Important articles t t))
- (dolist (remove '(t nil))
- (let* ((variant-name (if remove "remove" "set"))
- (function-name (format function-format variant-name))
- (shortcut (format "%c" data))
- (shortcut (if remove (upcase shortcut) shortcut)))
- (unintern function-name)
- (eval
- `(defun
- ;; function name
- ,(intern function-name)
- ;; parameter definition
- (&rest articles)
- ;; documentation
- ,(format
- "%s the %s mark over process-marked ARTICLES."
- (upcase-initials variant-name)
- mark)
- ;; interactive definition
- (interactive
- (gnus-summary-work-articles current-prefix-arg))
- ;; actual code
-
- ;; if this is called and the user doesn't want the
- ;; registry enabled, we'll ask anyhow
- (when (eq gnus-registry-install nil)
- (setq gnus-registry-install 'ask))
-
- ;; now the user is asked if gnus-registry-install is 'ask
- (when (gnus-registry-install-p)
- (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)
- (dolist (article articles)
- (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"
- function-name))))))
+ (dolist (remove '(t nil))
+ (let* ((variant-name (if remove "remove" "set"))
+ (function-name (format function-format variant-name))
+ (shortcut (format "%c" data))
+ (shortcut (if remove (upcase shortcut) shortcut)))
+ (unintern function-name obarray)
+ (eval
+ `(defun
+ ;; function name
+ ,(intern function-name)
+ ;; parameter definition
+ (&rest articles)
+ ;; documentation
+ ,(format
+ "%s the %s mark over process-marked ARTICLES."
+ (upcase-initials variant-name)
+ mark)
+ ;; interactive definition
+ (interactive
+ (gnus-summary-work-articles current-prefix-arg))
+ ;; actual code
+
+ ;; if this is called and the user doesn't want the
+ ;; registry enabled, we'll ask anyhow
+ (when (eq gnus-registry-install nil)
+ (setq gnus-registry-install 'ask))
+
+ ;; now the user is asked if gnus-registry-install is 'ask
+ (when (gnus-registry-install-p)
+ (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
+ (assoc article (gnus-data-list nil)))))))
+ (push (intern function-name) keys-plist)
+ (push shortcut keys-plist)
+ (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
- (plist-get
- (cdr-safe
- (assoc mark gnus-registry-marks))
- :char)))
- (if c
- (list c)
- nil)))
- marks))))
+ (marks (when id (gnus-registry-get-id-key id 'mark))))
+ (apply 'concat (mapcar (lambda (mark)
+ (let ((c
+ (plist-get
+ (cdr-safe
+ (assoc mark gnus-registry-marks))
+ :char)))
+ (if c
+ (list c)
+ nil)))
+ marks))))
(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))))
(defun gnus-registry-set-article-mark (&rest articles)
"Apply a mark to process-marked ARTICLES."
(interactive (gnus-summary-work-articles current-prefix-arg))
- (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) articles nil t))
+ (gnus-registry-set-article-mark-internal (gnus-registry-read-mark)
+ articles nil t))
(defun gnus-registry-remove-article-mark (&rest articles)
"Remove a mark from process-marked ARTICLES."
(interactive (gnus-summary-work-articles current-prefix-arg))
- (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) articles t t))
-
-(defun gnus-registry-set-article-mark-internal (mark articles &optional remove show-message)
- "Apply a mark to a list of ARTICLES."
+ (gnus-registry-set-article-mark-internal (gnus-registry-read-mark)
+ articles t t))
+
+(defun gnus-registry-set-article-mark-internal (mark
+ articles
+ &optional remove
+ show-message)
+ "Apply or remove MARK across a list of ARTICLES."
(let ((article-id-list
- (mapcar 'gnus-registry-fetch-message-id-fast articles)))
+ (mapcar 'gnus-registry-fetch-message-id-fast articles)))
(dolist (id article-id-list)
- (let* (
- ;; all the marks for this article without the mark of
- ;; interest
- (marks
- (delq mark (gnus-registry-fetch-extra-marks id)))
- ;; the new marks we want to use
- (new-marks (if remove
- marks
- (cons mark marks))))
- (when show-message
- (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)))))
+ (let* ((marks (delq mark (gnus-registry-get-id-key id 'mark)))
+ (marks (if remove marks (cons mark marks))))
+ (when show-message
+ (gnus-message 1 "%s mark %s with message ID %s, resulting in %S"
+ (if remove "Removing" "Adding")
+ mark id marks))
+ (gnus-registry-set-id-key id 'mark marks)))))
(defun gnus-registry-get-article-marks (&rest articles)
"Get the Gnus registry marks for ARTICLES and show them if interactive.
Uses process/prefix conventions. For multiple articles,
only the last one's marks are returned."
(interactive (gnus-summary-work-articles 1))
- (let (marks)
- (dolist (article articles)
- (let ((article-id
- (gnus-registry-fetch-message-id-fast article)))
- (setq marks (gnus-registry-fetch-extra-marks article-id))))
+ (let* ((article (last articles))
+ (id (gnus-registry-fetch-message-id-fast article))
+ (marks (when id (gnus-registry-get-id-key id 'mark))))
(when (interactive-p)
- (gnus-message 1 "Marks are %S" marks))
+ (gnus-message 1 "Marks are %S" marks))
marks))
-;;; if this extends to more than 'marks, it should be improved to be more generic.
-(defun gnus-registry-fetch-extra-marks (id)
- "Get the marks of a message, based on the message ID.
-Returns a list of symbol marks or nil."
- (car-safe (cdr (gnus-registry-fetch-extra id 'marks))))
-
-(defun gnus-registry-has-extra-mark (id mark)
- "Checks if a message has `mark', based on the message ID `id'."
- (memq mark (gnus-registry-fetch-extra-marks id)))
-
-(defun gnus-registry-store-extra-marks (id &rest mark-list)
- "Set the marks of a message, based on the message ID.
-The `mark-list' can be nil, in which case no marks are left."
- (gnus-registry-store-extra-entry id 'marks (list mark-list)))
-
-(defun gnus-registry-delete-extra-marks (id &rest mark-delete-list)
- "Delete the message marks in `mark-delete-list', based on the message ID."
- (let ((marks (gnus-registry-fetch-extra-marks id)))
- (when marks
- (dolist (mark mark-delete-list)
- (setq marks (delq mark marks))))
- (gnus-registry-store-extra-marks id (car marks))))
-
-(defun gnus-registry-delete-all-extra-marks (id)
- "Delete all the marks for a message ID."
- (gnus-registry-store-extra-marks id nil))
-
-(defun gnus-registry-fetch-extra (id &optional entry)
- "Get the extra data of a message, based on the message ID.
-Returns the first place where the trail finds a nonstring."
- (let ((entry-cache (gethash entry gnus-registry-hashtb)))
- (if (and entry
- (hash-table-p entry-cache)
- (gethash id entry-cache))
- (gethash id entry-cache)
- ;; else, if there is no caching possible...
- (let ((trail (gethash id gnus-registry-hashtb)))
- (when (listp trail)
- (dolist (crumb trail)
- (unless (stringp crumb)
- (return (gnus-registry-fetch-extra-entry crumb entry id)))))))))
-
-(defun gnus-registry-fetch-extra-entry (alist &optional entry id)
- "Get the extra data of a message, or a specific entry in it.
-Update the entry cache if needed."
- (if (and entry id)
- (let ((entry-cache (gethash entry gnus-registry-hashtb))
- entree)
- (when gnus-registry-entry-caching
- ;; create the hash table
- (unless (hash-table-p entry-cache)
- (setq entry-cache (make-hash-table
- :size 4096
- :test 'equal))
- (puthash entry entry-cache gnus-registry-hashtb))
-
- ;; get the entree from the hash table or from the alist
- (setq entree (gethash id entry-cache)))
-
- (unless entree
- (setq entree (assq entry alist))
- (when gnus-registry-entry-caching
- (puthash id entree entry-cache)))
- entree)
- alist))
-
-(defun gnus-registry-store-extra (id extra)
- "Store the extra data of a message, based on the message ID.
-The message must have at least one group name."
- (when (gnus-registry-group-count id)
- ;; we now know the trail has at least 1 group name, so it's not empty
- (let ((trail (gethash id gnus-registry-hashtb))
- (old-extra (gnus-registry-fetch-extra id))
- entry-cache)
- (dolist (crumb trail)
- (unless (stringp crumb)
- (dolist (entry crumb)
- (setq entry-cache (gethash (car entry) gnus-registry-hashtb))
- (when entry-cache
- (remhash id entry-cache))))
- (puthash id (cons extra (delete old-extra trail))
- gnus-registry-hashtb)
- (setq gnus-registry-dirty t)))))
-
-(defun gnus-registry-delete-extra-entry (id key)
- "Delete a specific entry in the extras field of the registry entry for id."
- (gnus-registry-store-extra-entry id key nil))
-
-(defun gnus-registry-store-extra-entry (id key value)
- "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)))
- (alist (if value
- (gnus-registry-remove-alist-text-properties
- (cons (cons key value)
- the-rest))
- the-rest)))
- (gnus-registry-store-extra id alist)))
-
-(defun gnus-registry-fetch-group (id)
- "Get the group of a message, based on the message ID.
-Returns the first place where the trail finds a group name."
- (when (gnus-registry-group-count id)
- ;; we now know the trail has at least 1 group name
- (let ((trail (gethash id gnus-registry-hashtb)))
- (dolist (crumb trail)
- (when (stringp crumb)
- (return (if gnus-registry-use-long-group-names
- crumb
- (gnus-group-short-name crumb))))))))
-
-(defun gnus-registry-fetch-groups (id &optional max)
- "Get the groups (up to MAX, if given) of a message, based on the message ID."
- (let ((trail (gethash id gnus-registry-hashtb))
- groups)
- (dolist (crumb trail)
- (when (stringp crumb)
- ;; push the group name into the list
- (setq
- groups
- (cons
- (if (or (not (stringp crumb)) gnus-registry-use-long-group-names)
- crumb
- (gnus-group-short-name crumb))
- groups))
- (when (and max (> (length groups) max))
- (return))))
- ;; return the list of groups
- groups))
-
(defun gnus-registry-group-count (id)
"Get the number of groups of a message, based on the message ID."
- (let ((trail (gethash id gnus-registry-hashtb)))
- (if (and trail (listp trail))
- (apply '+ (mapcar (lambda (x) (if (stringp x) 1 0)) trail))
- 0)))
-
-(defun gnus-registry-delete-group (id group)
- "Delete a group for a message, based on the message ID."
- (when (and group id)
- (let ((trail (gethash id gnus-registry-hashtb))
- (short-group (gnus-group-short-name group)))
- (puthash id (if trail
- (delete short-group (delete group trail))
- nil)
- gnus-registry-hashtb))
- ;; now, clear the entry if there are no more groups
- (when gnus-registry-trim-articles-without-groups
- (unless (gnus-registry-group-count id)
- (gnus-registry-delete-id id)))
- ;; is this ID still in the registry?
- (when (gethash id gnus-registry-hashtb)
- (gnus-registry-store-extra-entry id 'mtime (current-time)))))
-
-(defun gnus-registry-delete-id (id)
- "Delete a message ID from the registry."
- (when (stringp id)
- (remhash id gnus-registry-hashtb)
- (maphash
- (lambda (key value)
- (when (hash-table-p value)
- (remhash id value)))
- gnus-registry-hashtb)))
-
-(defun gnus-registry-add-group (id group &optional subject sender)
- "Add a group for a message, based on the message ID."
- (when group
- (when (and id
- (not (string-match "totally-fudged-out-message-id" id)))
- (let ((full-group group)
- (group (if gnus-registry-use-long-group-names
- group
- (gnus-group-short-name group))))
- (gnus-registry-delete-group id group)
-
- (unless gnus-registry-use-long-group-names ;; unnecessary in this case
- (gnus-registry-delete-group id full-group))
-
- (let ((trail (gethash id gnus-registry-hashtb)))
- (puthash id (if trail
- (cons group trail)
- (list group))
- gnus-registry-hashtb)
-
- (when (and (gnus-registry-track-subject-p)
- subject)
- (gnus-registry-store-extra-entry
- id
- 'subject
- (gnus-registry-simplify-subject subject)))
- (when (and (gnus-registry-track-sender-p)
- sender)
- (gnus-registry-store-extra-entry
- id
- 'sender
- sender))
-
- (gnus-registry-store-extra-entry id 'mtime (current-time)))))))
-
-(defun gnus-registry-clear ()
- "Clear the Gnus registry."
- (interactive)
- (setq gnus-registry-alist nil)
- (setq gnus-registry-hashtb (gnus-alist-to-hashtable gnus-registry-alist))
- (setq gnus-registry-dirty t))
+ (length (gnus-registry-get-id-key id 'group)))
+
+(defun gnus-registry-get-or-make-entry (id)
+ (let* ((db gnus-registry-db)
+ ;; safe if not found
+ (entries (registry-lookup db (list id))))
+
+ (when (null entries)
+ (gnus-registry-insert db id (list (list 'creation-time (current-time))
+ '(group) '(sender) '(subject)))
+ (setq entries (registry-lookup db (list id))))
+
+ (nth 1 (assoc id entries))))
+
+(defun gnus-registry-delete-entries (idlist)
+ (registry-delete gnus-registry-db idlist nil))
+
+(defun gnus-registry-get-id-key (id key)
+ (cdr-safe (assq key (gnus-registry-get-or-make-entry id))))
+
+(defun gnus-registry-set-id-key (id key vals)
+ (let* ((db gnus-registry-db)
+ (entry (gnus-registry-get-or-make-entry id)))
+ (registry-delete db (list id) nil)
+ (setq entry (cons (cons key vals) (assq-delete-all key entry)))
+ (gnus-registry-insert db id entry)
+ entry))
+
+(defun gnus-registry-insert (db id entry)
+ "Just like `registry-insert' but tries to prune on error."
+ (when (registry-full db)
+ (message "Trying to prune the registry because it's full")
+ (registry-prune db))
+ (registry-insert db id entry)
+ entry)
+
+(defun gnus-registry-import-eld (file)
+ (interactive "fOld registry file to import? ")
+ ;; example content:
+ ;; (setq gnus-registry-alist '(
+ ;; ("<messageID>" ((marks nil)
+ ;; (mtime 19365 1776 440496)
+ ;; (sender . "root (Cron Daemon)")
+ ;; (subject . "Cron"))
+ ;; "cron" "nnml+private:cron")
+ (load file t)
+ (when (boundp 'gnus-registry-alist)
+ (let* ((old (symbol-value 'gnus-registry-alist))
+ (count 0)
+ (expected (length old))
+ entry)
+ (while (car-safe old)
+ (incf count)
+ ;; don't use progress reporters for backwards compatibility
+ (when (and (< 0 expected)
+ (= 0 (mod count 100)))
+ (message "importing: %d of %d (%.2f%%)"
+ count expected (/ (* 100 count) expected)))
+ (setq entry (car-safe old)
+ old (cdr-safe old))
+ (let* ((id (car-safe entry))
+ (new-entry (gnus-registry-get-or-make-entry id))
+ (rest (cdr-safe entry))
+ (groups (loop for p in rest
+ when (stringp p)
+ collect p))
+ extra-cell key val)
+ ;; remove all the strings from the entry
+ (dolist (elem rest)
+ (if (stringp elem) (setq rest (delq elem rest))))
+ (gnus-registry-set-id-key id 'group groups)
+ ;; just use the first extra element
+ (setq rest (car-safe rest))
+ (while (car-safe rest)
+ (setq extra-cell (car-safe rest)
+ key (car-safe extra-cell)
+ val (cdr-safe extra-cell)
+ rest (cdr-safe rest))
+ (when (and val (atom val))
+ (setq val (list val)))
+ (gnus-registry-set-id-key id key val))))
+ (message "Import done, collected %d entries" count))))
+
+(ert-deftest gnus-registry-misc-test ()
+ (should-error (gnus-registry-extract-addresses '("" "")))
+
+ (should (equal '("Ted Zlatanov <tzz@lifelogs.com>"
+ "noname <ed@you.me>"
+ "noname <cyd@stupidchicken.com>"
+ "noname <tzz@lifelogs.com>")
+ (gnus-registry-extract-addresses
+ (concat "Ted Zlatanov <tzz@lifelogs.com>, "
+ "ed <ed@you.me>, " ; "ed" is not a valid name here
+ "cyd@stupidchicken.com, "
+ "tzz@lifelogs.com")))))
+
+(ert-deftest gnus-registry-usage-test ()
+ (let* ((n 100)
+ (tempfile (make-temp-file "gnus-registry-persist"))
+ (db (gnus-registry-make-db tempfile))
+ (gnus-registry-db db)
+ back size)
+ (message "Adding %d keys to the test Gnus registry" n)
+ (dotimes (i n)
+ (let ((id (number-to-string i)))
+ (gnus-registry-handle-action id
+ (if (>= 50 i) "fromgroup" nil)
+ "togroup"
+ (when (>= 70 i)
+ (format "subject %d" (mod i 10)))
+ (when (>= 80 i)
+ (format "sender %d" (mod i 10))))))
+ (message "Testing Gnus registry size is %d" n)
+ (should (= n (registry-size db)))
+ (message "Looking up individual keys (registry-lookup)")
+ (should (equal (loop for e
+ in (mapcar 'cadr
+ (registry-lookup db '("20" "83" "72")))
+ collect (assq 'subject e)
+ collect (assq 'sender e)
+ collect (assq 'group e))
+ '((subject "subject 0") (sender "sender 0") (group "togroup")
+ (subject) (sender) (group "togroup")
+ (subject) (sender "sender 2") (group "togroup"))))
+
+ (message "Looking up individual keys (gnus-registry-id-key)")
+ (should (equal (gnus-registry-get-id-key "34" 'group) '("togroup")))
+ (should (equal (gnus-registry-get-id-key "34" 'subject) '("subject 4")))
+ (message "Trying to insert a duplicate key")
+ (should-error (gnus-registry-insert db "55" '()))
+ (message "Looking up individual keys (gnus-registry-get-or-make-entry)")
+ (should (gnus-registry-get-or-make-entry "22"))
+ (message "Saving the Gnus registry to %s" tempfile)
+ (should (gnus-registry-save tempfile db))
+ (setq size (nth 7 (file-attributes tempfile)))
+ (message "Saving the Gnus registry to %s: size %d" tempfile size)
+ (should (< 0 size))
+ (with-temp-buffer
+ (insert-file-contents-literally tempfile)
+ (should (looking-at (concat ";; Object "
+ "Gnus Registry"
+ "\n;; EIEIO PERSISTENT OBJECT"))))
+ (message "Reading Gnus registry back")
+ (setq back (eieio-persistent-read tempfile))
+ (should back)
+ (message "Read Gnus registry back: %d keys, expected %d==%d"
+ (registry-size back) n (registry-size db))
+ (should (= (registry-size back) n))
+ (should (= (registry-size back) (registry-size db)))
+ (delete-file tempfile)
+ (message "Pruning Gnus registry to 0 by setting :max-soft")
+ (oset db :max-soft 0)
+ (registry-prune db)
+ (should (= (registry-size db) 0)))
+ (message "Done with Gnus registry usage testing."))
;;;###autoload
(defun gnus-registry-initialize ()
"Initialize the Gnus registry."
(interactive)
(gnus-message 5 "Initializing the registry")
- (setq gnus-registry-install t) ; in case it was 'ask or nil
+ (setq gnus-registry-install t) ; in case it was 'ask or nil
(gnus-registry-install-hooks)
(gnus-registry-install-shortcuts)
(gnus-registry-read))
@@ -1152,23 +1153,18 @@ Returns the first place where the trail finds a group name."
(interactive)
(when (eq gnus-registry-install 'ask)
(setq gnus-registry-install
- (gnus-y-or-n-p
- (concat "Enable the Gnus registry? "
- "See the variable `gnus-registry-install' "
- "to get rid of this query permanently. ")))
+ (gnus-y-or-n-p
+ (concat "Enable the Gnus registry? "
+ "See the variable `gnus-registry-install' "
+ "to get rid of this query permanently. ")))
(when gnus-registry-install
;; we just set gnus-registry-install to t, so initialize the registry!
(gnus-registry-initialize)))
;;; 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 422c260787e..43a8eba4bed 100644
--- a/lisp/gnus/gnus-salt.el
+++ b/lisp/gnus/gnus-salt.el
@@ -1,7 +1,6 @@
;;; gnus-salt.el --- alternate summary mode interfaces for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1999, 2001-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -26,6 +25,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 +37,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 +70,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 +100,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 +320,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 +336,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 +868,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 795fcff2fbd..9bbfbfb057e 100644
--- a/lisp/gnus/gnus-score.el
+++ b/lisp/gnus/gnus-score.el
@@ -1,7 +1,6 @@
;;; gnus-score.el --- scoring code for Gnus
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-2011 Free Software Foundation, Inc.
;; Author: Per Abrahamsen <amanda@iesd.auc.dk>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -680,14 +679,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 +707,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 +733,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 +912,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 +1116,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 +1144,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 +1269,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 +1393,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 +1526,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 +1851,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 +1942,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 +2049,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
@@ -2154,7 +2151,7 @@ score in `gnus-newsgroup-scored' by SCORE."
;; Find fuzzy matches.
(when fuzzies
;; Simplify the entire buffer for easy matching.
- (gnus-simplify-buffer-fuzzy)
+ (gnus-simplify-buffer-fuzzy gnus-simplify-subject-fuzzy-regexp)
(while (setq kill (cadaar fuzzies))
(let* ((match (nth 0 kill))
(type (nth 3 kill))
@@ -2279,8 +2276,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 +2690,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 +3114,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 a2e6dff9759..bd7c3a77c36 100644
--- a/lisp/gnus/gnus-setup.el
+++ b/lisp/gnus/gnus-setup.el
@@ -1,7 +1,6 @@
;;; gnus-setup.el --- Initialization & Setup for Gnus 5
-;; Copyright (C) 1995, 1996, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-1996, 2000-2011 Free Software Foundation, Inc.
;; Author: Steven L. Baur <steve@miranova.com>
;; Keywords: news
@@ -189,5 +188,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 b3c67e74a92..376dd4277a0 100644
--- a/lisp/gnus/gnus-sieve.el
+++ b/lisp/gnus/gnus-sieve.el
@@ -1,6 +1,6 @@
;;; gnus-sieve.el --- Utilities to manage sieve scripts for Gnus
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;; Author: NAGY Andras <nagya@inf.elte.hu>,
;; Simon Josefsson <simon@josefsson.org>
@@ -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 e8b9cc35f88..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, 2011 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 0d6848cc360..4682f512476 100644
--- a/lisp/gnus/gnus-spec.el
+++ b/lisp/gnus/gnus-spec.el
@@ -1,7 +1,6 @@
;;; gnus-spec.el --- format spec functions for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -25,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))))
(eval-when-compile (require 'cl))
@@ -680,7 +679,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 +766,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 f2ae61db8e9..9bf2d37a3e4 100644
--- a/lisp/gnus/gnus-srvr.el
+++ b/lisp/gnus/gnus-srvr.el
@@ -1,7 +1,6 @@
;;; gnus-srvr.el --- virtual server support for Gnus
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -28,11 +27,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 +114,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 +152,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 +168,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 +306,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 +551,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 +574,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 +586,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 +610,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 +661,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)
@@ -723,7 +765,8 @@ The following commands are available:
(with-current-buffer nntp-server-buffer
(let ((cur (current-buffer)))
(goto-char (point-min))
- (unless (string= gnus-ignored-newsgroups "")
+ (unless (or (null gnus-ignored-newsgroups)
+ (string= gnus-ignored-newsgroups ""))
(delete-matching-lines gnus-ignored-newsgroups))
;; We treat NNTP as a special case to avoid problems with
;; garbage group names like `"foo' that appear in some badly
@@ -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,25 @@ 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)
+ (gnus-request-update-group-status group 'subscribe)))
(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 +1022,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 +1079,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 1d6216cbecb..719d0c9e472 100644
--- a/lisp/gnus/gnus-start.el
+++ b/lisp/gnus/gnus-start.el
@@ -1,7 +1,6 @@
;;; gnus-start.el --- startup functions for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -86,14 +85,6 @@ If a file with the `.el' or `.elc' suffixes exists, it will be read instead."
:group 'gnus-start
:type '(choice file (const nil)))
-(defcustom gnus-default-subscribed-newsgroups nil
- "List of newsgroups to subscribe, when a user runs Gnus the first time.
-The value should be a list of strings.
-If it is t, Gnus will not do anything special the first time it is
-started; it'll just use the normal newsgroups subscription methods."
- :group 'gnus-start
- :type '(choice (repeat string) (const :tag "Nothing special" t)))
-
(defcustom gnus-use-dribble-file t
"*Non-nil means that Gnus will use a dribble file to store user updates.
If Emacs should crash without saving the .newsrc files, complete
@@ -181,7 +172,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 +259,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.
@@ -341,8 +332,17 @@ hierarchy in its entirety."
:group 'gnus-group-new
:type 'boolean)
+(defcustom gnus-auto-subscribed-categories '(mail post-mail)
+ "*New groups from methods of these categories will be subscribed automatically.
+Note that this variable only deals with new groups. It has no
+effect whatsoever on old groups. The default is to automatically
+subscribe all groups from mail-like backends."
+ :version "24.1"
+ :group 'gnus-group-new
+ :type '(repeat symbol))
+
(defcustom gnus-auto-subscribed-groups
- "^nnml\\|^nnfolder\\|^nnmbox\\|^nnmh\\|^nnbabyl\\|^nnmaildir"
+ "^nnml\\|^nnfolder\\|^nnmbox\\|^nnmh\\|^nnbabyl\\|^nnmaildir\\|^nnimap"
"*All new groups that match this regexp will be subscribed automatically.
Note that this variable only deals with new groups. It has no effect
whatsoever on old groups.
@@ -402,8 +402,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 +419,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 +593,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)
@@ -639,6 +637,7 @@ the first newsgroup."
(gnus-group-change-level
newsgroup gnus-level-default-subscribed
gnus-level-killed (gnus-group-entry (or next "dummy.group")))
+ (gnus-request-update-group-status newsgroup 'subscribe)
(gnus-message 5 "Subscribe newsgroup: %s" newsgroup)
(run-hook-with-args 'gnus-subscribe-newsgroup-hooks newsgroup)
t))
@@ -706,6 +705,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 +765,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
@@ -786,10 +778,9 @@ prompt the user for the name of an NNTP server to use."
(gnus-start-news-server (and arg (not level))))))
(if (and (not dont-connect)
(not did-connect))
+ ;; Couldn't connect to the server, so bail out.
(gnus-group-quit)
(gnus-run-hooks 'gnus-startup-hook)
- ;; NNTP server is successfully open.
-
;; Find the current startup file name.
(setq gnus-current-startup-file
(gnus-make-newsrc-file gnus-startup-file))
@@ -799,11 +790,10 @@ prompt the user for the name of an NNTP server to use."
(gnus-dribble-read-file))
;; Do the actual startup.
- (if gnus-agent
- (gnus-request-create-group "queue" '(nndraft "")))
- (gnus-request-create-group "drafts" '(nndraft ""))
(gnus-setup-news nil level dont-connect)
(gnus-run-hooks 'gnus-setup-news-hook)
+ (when gnus-agent
+ (gnus-request-create-group "queue" '(nndraft "")))
(gnus-start-draft-setup)
;; Generate the group buffer.
(gnus-group-list-groups level)
@@ -814,13 +804,14 @@ 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))
- (gnus-subscribe-group "nndraft:drafts" nil '(nndraft ""))))
+ (gnus-subscribe-group "nndraft:drafts" nil '(nndraft "")))
+ (setcar (gnus-group-entry "nndraft:drafts") 0))
(unless (equal (gnus-group-get-parameter "nndraft:drafts" 'gnus-dummy t)
'((gnus-draft-mode)))
- (gnus-message 3 "Setting up drafts group")
(gnus-group-set-parameter
"nndraft:drafts" 'gnus-dummy '((gnus-draft-mode)))))
@@ -856,8 +847,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,11 +858,13 @@ 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)
+ (setq buffer-save-without-query t)
(erase-buffer)
(setq buffer-file-name dribble-file)
(auto-save-mode t)
@@ -920,8 +912,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 +922,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)))))
@@ -1000,27 +989,8 @@ If LEVEL is non-nil, the news will be set up at level LEVEL."
(when (or (null gnus-read-active-file)
(eq gnus-read-active-file 'some))
(gnus-update-active-hashtb-from-killed))
-
- ;; Validate agent covered methods now that gnus-server-alist has
- ;; been initialized.
- ;; NOTE: This is here for one purpose only. By validating the
- ;; agentized server's, it converts the old 5.10.3, and earlier,
- ;; format to the current format. That enables the agent code
- ;; within gnus-read-active-file to function correctly.
- (if gnus-agent
- (gnus-agent-read-servers-validate))
-
- ;; Read the active file and create `gnus-active-hashtb'.
- ;; If `gnus-read-active-file' is nil, then we just create an empty
- ;; hash table. The partial filling out of the hash table will be
- ;; done in `gnus-get-unread-articles'.
- (and gnus-read-active-file
- (not level)
- (gnus-read-active-file nil dont-connect))
-
(unless gnus-active-hashtb
(setq gnus-active-hashtb (gnus-make-hashtable 4096)))
-
;; Initialize the cache.
(when gnus-use-cache
(gnus-cache-open))
@@ -1059,15 +1029,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 +1074,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
@@ -1171,6 +1132,12 @@ for new groups, and subscribe the new groups as zombies."
((and gnus-options-subscribe
(string-match gnus-options-subscribe group))
'subscribe)
+ ((let ((do-subscribe nil))
+ (dolist (category gnus-auto-subscribed-categories)
+ (when (gnus-member-of-valid category group)
+ (setq do-subscribe t)))
+ do-subscribe)
+ 'subscribe)
((and gnus-auto-subscribed-groups
(string-match gnus-auto-subscribed-groups group))
'subscribe)
@@ -1257,55 +1224,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."
@@ -1387,16 +1306,13 @@ for new groups, and subscribe the new groups as zombies."
((>= level gnus-level-zombie)
;; Remove from the hash table.
(gnus-sethash group nil gnus-newsrc-hashtb)
- ;; We do not enter foreign groups into the list of dead
- ;; groups.
- (unless (gnus-group-foreign-p group)
- (if (= level gnus-level-zombie)
- (push group gnus-zombie-list)
- (if (= oldlevel gnus-level-killed)
- ;; Remove from active hashtb.
- (unintern group gnus-active-hashtb)
- ;; Don't add it into killed-list if it was killed.
- (push group gnus-killed-list)))))
+ (if (= level gnus-level-zombie)
+ (push group gnus-zombie-list)
+ (if (= oldlevel gnus-level-killed)
+ ;; Remove from active hashtb.
+ (unintern group gnus-active-hashtb)
+ ;; Don't add it into killed-list if it was killed.
+ (push group gnus-killed-list))))
(t
;; If the list is to be entered into the newsrc assoc, and
;; it was killed, we have to create an entry in the newsrc
@@ -1471,7 +1387,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 +1439,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,12 +1455,17 @@ 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))
- ;;(error nil)
+ (inline (gnus-request-group group (or dont-sub-check dont-check)
+ method
+ (gnus-get-info group)))
(quit
- (message "Quit activating %s" group)
+ (if debug-on-quit
+ (debug "Quit")
+ (message "Quit activating %s" group))
nil)))
(unless dont-check
(setq active (gnus-parse-active))
@@ -1569,6 +1491,8 @@ If SCAN, request a scan of that group as well."
;; Return the new active info.
active)))))
+(defvar gnus-propagate-marks) ; gnus-sum
+
(defun gnus-get-unread-articles-in-group (info active &optional update)
(when (and info active)
;; Allow the backend to update the info in the group.
@@ -1578,6 +1502,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-propagate-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 +1599,206 @@ 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))))))
+ ;; Go through the list of servers and possibly extend methods that
+ ;; aren't equal (and that need extension; i.e., they are async).
+ (let ((methods nil))
+ (dolist (elem type-cache)
+ (destructuring-bind (method method-type infos dummy) elem
+ (let ((gnus-opened-servers methods))
+ (when (and (gnus-similar-server-opened method)
+ (gnus-check-backend-function
+ 'retrieve-group-data-early (car method)))
+ (setq method (gnus-server-extend-method
+ (gnus-info-group (car infos))
+ method))
+ (setcar elem method))
+ (push (list method 'ok) methods)))))
+
+ ;; If we have primary/secondary select methods, but no groups from
+ ;; them, we still want to issue a retrieval request from them.
+ (dolist (method (cons gnus-select-method
+ gnus-secondary-select-methods))
+ (when (and (not (assoc method type-cache))
+ (gnus-check-backend-function 'request-list (car method)))
+ (with-current-buffer nntp-server-buffer
+ (gnus-read-active-file-1 method nil))))
+
+ ;; Start early async retrieval of data.
+ (let ((done-methods nil)
+ sanity-spec)
+ (dolist (elem type-cache)
+ (destructuring-bind (method method-type infos dummy) elem
+ (setq sanity-spec (list (car method) (cadr method)))
+ (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
+ ;; This is a sanity check, so that we never
+ ;; attempt to start two async requests to the
+ ;; same server, because that will fail. This
+ ;; should never happen, since the methods should
+ ;; be unique at this point, but apparently it
+ ;; does happen in the wild with some setups.
+ (not (member sanity-spec done-methods))
+ (gnus-server-opened method)
+ (gnus-check-backend-function
+ 'retrieve-group-data-early (car method)))
+ (push sanity-spec done-methods)
+ (when (gnus-check-backend-function 'request-scan (car method))
+ (gnus-request-scan nil method))
+ ;; Store the token we get back from -early so that we
+ ;; can pass it to -finish later.
+ (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
+ (not (gnus-method-denied-p method)))
+ (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
+ ;; Finish up getting the data from the methods that have -early
+ ;; methods.
+ ((and
+ early-data
+ (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))
+ ;; Most backends have -retrieve-groups.
+ ((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)))
+ ;; Virtually all backends have -request-list.
+ ((gnus-check-backend-function 'request-list (car method))
+ (gnus-read-active-file-1 method nil))
+ ;; Except nnvirtual and friends, where we request each group, one
+ ;; by one.
+ (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 +1819,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 +1852,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 +2006,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 ()
@@ -2027,7 +2020,9 @@ If SCAN, request a scan of that group as well."
;; We catch C-g so that we can continue past servers
;; that do not respond.
(quit
- (message "Quit reading the active file")
+ (if debug-on-quit
+ (debug "Quit")
+ (message "Quit reading the active file"))
nil))))))))
(defun gnus-read-active-file-1 (method force)
@@ -2037,10 +2032,13 @@ If SCAN, request a scan of that group as well."
(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 +2064,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 +2754,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)
@@ -2890,10 +2886,10 @@ If FORCE is non-nil, the .newsrc file is read."
(pop list))
(nreverse olist)))
-(defun gnus-gnus-to-newsrc-format ()
+(defun gnus-gnus-to-newsrc-format (&optional foreign-ok)
+ (interactive (list (gnus-y-or-n-p "write foreign groups too? ")))
;; 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)
@@ -2913,7 +2909,8 @@ If FORCE is non-nil, the .newsrc file is read."
;; Don't write foreign groups to .newsrc.
(when (or (null (setq method (gnus-info-method info)))
(equal method "native")
- (inline (gnus-server-equal method gnus-select-method)))
+ (inline (gnus-server-equal method gnus-select-method))
+ foreign-ok)
(insert (gnus-info-group info)
(if (> (gnus-info-level info) gnus-level-subscribed)
"!" ":"))
@@ -2960,12 +2957,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 +2987,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 +3055,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 +3107,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 +3134,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 +3172,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 4a38a360d1f..3cbb479e068 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -1,7 +1,6 @@
;;; gnus-sum.el --- summary mode commands for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -25,11 +24,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)
@@ -57,6 +59,8 @@
(autoload 'gnus-article-outlook-unwrap-lines "deuglify" nil t)
(autoload 'gnus-article-outlook-repair-attribution "deuglify" nil t)
(autoload 'gnus-article-outlook-rearrange-citation "deuglify" nil t)
+(autoload 'nnir-article-rsv "nnir" nil nil 'macro)
+(autoload 'nnir-article-group "nnir" nil nil 'macro)
(defcustom gnus-kill-summary-on-exit t
"*If non-nil, kill the summary buffer when you exit from it.
@@ -73,6 +77,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 +222,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 +232,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 +351,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
@@ -347,10 +359,10 @@ first subject), `unread' (place point on the subject line of the first
unread article), `best' (place point on the subject line of the
higest-scored article), `unseen' (place point on the subject line of
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
+line of the first unseen article or, if all articles 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 +452,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 +468,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 +549,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 +672,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 +994,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.
@@ -1113,9 +1128,9 @@ which it may alter in any way."
'mail-decode-encoded-address-string
"Function used to decode addresses with encoded words.")
-(defcustom gnus-extra-headers '(To Newsgroups)
+(defcustom gnus-extra-headers '(To Cc Keywords Gcc Newsgroups)
"*Extra headers to parse."
- :version "21.1"
+ :version "24.1" ; added Cc Keywords Gcc
:group 'gnus-summary
:type '(repeat symbol))
@@ -1219,9 +1234,10 @@ For example: ((1 . cn-gb-2312) (2 . big5))."
:type 'boolean
:group 'gnus-summary-marks)
-(defcustom gnus-propagate-marks t
- "If non-nil, do not propagate marks to the backends."
- :version "23.1" ;; No Gnus
+(defcustom gnus-propagate-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."
:type 'boolean
:group 'gnus-summary-marks)
@@ -1248,7 +1264,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))
@@ -1347,6 +1363,16 @@ the normal Gnus MIME machinery."
(?c (or (mail-header-chars gnus-tmp-header) 0) ?d)
(?k (gnus-summary-line-message-size gnus-tmp-header) ?s)
(?L gnus-tmp-lines ?s)
+ (?Z (or ,(gnus-macroexpand-all
+ '(nnir-article-rsv (mail-header-number gnus-tmp-header)))
+ 0) ?d)
+ (?G (or ,(gnus-macroexpand-all
+ '(nnir-article-group (mail-header-number gnus-tmp-header)))
+ "") ?s)
+ (?g (or ,(gnus-macroexpand-all
+ '(gnus-group-short-name
+ (nnir-article-group (mail-header-number gnus-tmp-header))))
+ "") ?s)
(?O gnus-tmp-downloaded ?c)
(?I gnus-tmp-indentation ?s)
(?T (if (= gnus-tmp-level 0) "" (make-string (frame-width) ? )) ?s)
@@ -1423,6 +1449,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,27 +1560,41 @@ 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
gnus-current-article gnus-current-headers gnus-have-all-headers
gnus-last-article gnus-article-internal-prepare-hook
+ (gnus-summary-article-delete-hook . global)
+ (gnus-summary-article-move-hook . global)
gnus-newsgroup-dependencies gnus-newsgroup-selected-overlay
gnus-newsgroup-scored gnus-newsgroup-kill-headers
gnus-thread-expunge-below
@@ -1562,12 +1603,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
@@ -1692,7 +1734,7 @@ If RE-ONLY is non-nil, strip leading `Re:'s only."
(while (re-search-forward regexp nil t)
(replace-match (or newtext ""))))
-(defun gnus-simplify-buffer-fuzzy ()
+(defun gnus-simplify-buffer-fuzzy (regexp)
"Simplify string in the buffer fuzzily.
The string in the accessible portion of the current buffer is simplified.
It is assumed to be a single-line subject.
@@ -1706,11 +1748,10 @@ matter is removed. Additional things can be deleted by setting
(while (not (eq modified-tick (buffer-modified-tick)))
(setq modified-tick (buffer-modified-tick))
(cond
- ((listp gnus-simplify-subject-fuzzy-regexp)
- (mapc 'gnus-simplify-buffer-fuzzy-step
- gnus-simplify-subject-fuzzy-regexp))
- (gnus-simplify-subject-fuzzy-regexp
- (gnus-simplify-buffer-fuzzy-step gnus-simplify-subject-fuzzy-regexp)))
+ ((listp regexp)
+ (mapc 'gnus-simplify-buffer-fuzzy-step regexp))
+ (regexp
+ (gnus-simplify-buffer-fuzzy-step regexp)))
(gnus-simplify-buffer-fuzzy-step "^ *\\[[-+?*!][-+?*!]\\] *")
(gnus-simplify-buffer-fuzzy-step
"^ *\\(re\\|fw\\|fwd\\)[[{(^0-9]*[])}]?[:;] *")
@@ -1725,15 +1766,16 @@ matter is removed. Additional things can be deleted by setting
"Simplify a subject string fuzzily.
See `gnus-simplify-buffer-fuzzy' for details."
(save-excursion
- (gnus-set-work-buffer)
- (let ((case-fold-search t))
- ;; Remove uninteresting prefixes.
- (when (and gnus-simplify-ignored-prefixes
- (string-match gnus-simplify-ignored-prefixes subject))
- (setq subject (substring subject (match-end 0))))
- (insert subject)
- (inline (gnus-simplify-buffer-fuzzy))
- (buffer-string))))
+ (let ((regexp gnus-simplify-subject-fuzzy-regexp))
+ (gnus-set-work-buffer)
+ (let ((case-fold-search t))
+ ;; Remove uninteresting prefixes.
+ (when (and gnus-simplify-ignored-prefixes
+ (string-match gnus-simplify-ignored-prefixes subject))
+ (setq subject (substring subject (match-end 0))))
+ (insert subject)
+ (inline (gnus-simplify-buffer-fuzzy regexp))
+ (buffer-string)))))
(defsubst gnus-simplify-subject-fully (subject)
"Simplify a subject string according to `gnus-summary-gather-subject-limit'."
@@ -1850,7 +1892,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 +1913,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 +2072,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 +2112,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 +2150,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 +2185,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 +2217,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 +2402,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 +2437,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 +2484,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 +2681,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 +2726,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 +2764,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 +3056,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 +3092,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 +3110,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 +3130,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 +3432,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 +3443,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 +3514,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 +3776,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 +3809,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)
@@ -3833,10 +3853,59 @@ This function is intended to be used in
((< c (* 1000 10000)) (format "%1.1fM" (/ c (* 1024.0 1024))))
(t (format "%dM" (/ c (* 1024.0 1024)))))))
+(defcustom gnus-user-date-format-alist
+ '(((gnus-seconds-today) . "Today, %H:%M")
+ ((+ 86400 (gnus-seconds-today)) . "Yesterday, %H:%M")
+ (604800 . "%A %H:%M") ; That's one week
+ ((gnus-seconds-month) . "%A %d")
+ ((gnus-seconds-year) . "%B %d")
+ (t . "%b %d %Y")) ; This one is used when no other
+ ; does match
+ "Specifies date format depending on age of article.
+This is an alist of items (AGE . FORMAT). AGE can be a number (of
+seconds) or a Lisp expression evaluating to a number. When the age of
+the article is less than this number, then use `format-time-string'
+with the corresponding FORMAT for displaying the date of the article.
+If AGE is not a number or a Lisp expression evaluating to a
+non-number, then the corresponding FORMAT is used as a default value.
+
+Note that the list is processed from the beginning, so it should be
+sorted by ascending AGE. Also note that items following the first
+non-number AGE will be ignored.
+
+You can use the functions `gnus-seconds-today', `gnus-seconds-month'
+and `gnus-seconds-year' in the AGE spec. They return the number of
+seconds passed since the start of today, of this month, of this year,
+respectively."
+ :version "24.1"
+ :group 'gnus-summary-format
+ :type '(alist :key-type sexp :value-type string))
+
+(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 another error occurs.
+Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"."
+ (condition-case ()
+ (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"))
+ (let* ((difference (- now messy-date))
+ (templist gnus-user-date-format-alist)
+ (top (eval (caar templist))))
+ (while (if (numberp top) (< top difference) (not top))
+ (progn
+ (setq templist (cdr templist))
+ (setq top (eval (caar templist)))))
+ (if (stringp (cdr (car templist)))
+ (setq my-format (cdr (car templist)))))
+ (format-time-string (eval my-format) (seconds-to-time messy-date)))
+ (error " ? ")))
(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.
@@ -3919,11 +3988,9 @@ If NO-DISPLAY, don't generate a summary buffer."
(gnus-group-jump-to-group group)
(gnus-group-next-unread-group 1))
(gnus-handle-ephemeral-exit quit-config)))
- (let ((grpinfo (gnus-get-info group)))
- (if (null (gnus-info-read grpinfo))
- (gnus-message 3 "Group %s contains no messages"
- (gnus-group-decoded-name group))
- (gnus-message 3 "Can't select group")))
+ (if (null (gnus-list-of-unread-articles group))
+ (gnus-message 3 "Group %s contains no messages" group)
+ (gnus-message 3 "Can't select group"))
nil)
;; The user did a `C-g' while prompting for number of articles,
;; so we exit this group.
@@ -3937,7 +4004,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 +4015,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
@@ -3999,6 +4066,7 @@ If NO-DISPLAY, don't generate a summary buffer."
;; gnus-summary-prepare-hook since kill processing may not
;; work with hidden articles.
(gnus-summary-maybe-hide-threads)
+ (gnus-configure-windows 'summary)
(when kill-buffer
(gnus-kill-or-deaden-summary kill-buffer))
(gnus-summary-auto-select-subject)
@@ -4008,7 +4076,6 @@ If NO-DISPLAY, don't generate a summary buffer."
gnus-newsgroup-unreads
gnus-auto-select-first)
(progn
- (gnus-configure-windows 'summary)
(let ((art (gnus-summary-article-number)))
(unless (and (not gnus-plugged)
(or (memq art gnus-newsgroup-undownloaded)
@@ -4504,7 +4571,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 +4893,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 +5047,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 +5061,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 +5438,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)
@@ -5437,12 +5510,17 @@ or a straight list of headers."
(cdr (assq number gnus-newsgroup-scored))
(memq number gnus-newsgroup-processable))))))
+(defun gnus-group-get-list-identifiers (group)
+ "Get list identifier regexp for GROUP."
+ (or (gnus-parameter-list-identifier group)
+ (if (consp gnus-list-identifiers)
+ (mapconcat 'identity gnus-list-identifiers " *\\|")
+ gnus-list-identifiers)))
+
(defun gnus-summary-remove-list-identifiers ()
"Remove list identifiers in `gnus-list-identifiers' from articles in the current group."
- (let ((regexp (if (consp gnus-list-identifiers)
- (mapconcat 'identity gnus-list-identifiers " *\\|")
- gnus-list-identifiers))
- changed subject)
+ (let ((regexp (gnus-group-get-list-identifiers gnus-newsgroup-name))
+ changed subject)
(when regexp
(setq regexp (concat "^\\(?:R[Ee]: +\\)*\\(" regexp " *\\)"))
(dolist (header gnus-newsgroup-headers)
@@ -5460,7 +5538,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 +5547,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,13 +5590,14 @@ 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 gnus-agent
+ (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 (and gnus-agent
+ (gnus-active group))
(gnus-agent-possibly-alter-active group (gnus-active group) info)
(setq gnus-summary-use-undownloaded-faces
@@ -5575,7 +5655,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(setq gnus-newsgroup-processable nil)
- (gnus-update-read-articles group gnus-newsgroup-unreads)
+ (gnus-update-read-articles group gnus-newsgroup-unreads t)
;; Adjust and set lists of article marks.
(when info
@@ -5632,8 +5712,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(when gnus-agent
(gnus-agent-get-undownloaded-list))
;; Remove list identifiers from subject
- (when gnus-list-identifiers
- (gnus-summary-remove-list-identifiers))
+ (gnus-summary-remove-list-identifiers)
;; Check whether auto-expire is to be done in this group.
(setq gnus-newsgroup-auto-expire
(gnus-group-auto-expirable-p group))
@@ -5671,17 +5750,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))
@@ -5723,7 +5802,8 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(defun gnus-articles-to-read (group &optional read-all)
"Find out what articles the user wants to read."
- (let* ((articles
+ (let* ((only-read-p t)
+ (articles
;; Select all articles if `read-all' is non-nil, or if there
;; are no unread articles.
(if (or read-all
@@ -5747,6 +5827,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(gnus-uncompress-range (gnus-active group)))
(gnus-cache-articles-in-group group))
;; Select only the "normal" subset of articles.
+ (setq only-read-p nil)
(gnus-sorted-nunion
(gnus-sorted-union gnus-newsgroup-dormant gnus-newsgroup-marked)
gnus-newsgroup-unreads)))
@@ -5770,16 +5851,25 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(let* ((cursor-in-echo-area nil)
(initial (gnus-parameter-large-newsgroup-initial
gnus-newsgroup-name))
+ (default (if only-read-p
+ (or initial gnus-large-newsgroup)
+ number))
(input
(read-string
- (format
- "How many articles from %s (%s %d): "
- (gnus-group-decoded-name gnus-newsgroup-name)
- (if initial "max" "default")
- number)
- (if initial
- (cons (number-to-string initial)
- 0)))))
+ (if only-read-p
+ (format
+ "How many articles from %s (available %d, default %d): "
+ (gnus-group-decoded-name
+ (gnus-group-real-name gnus-newsgroup-name))
+ number default)
+ (format
+ "How many articles from %s (%d available): "
+ (gnus-group-decoded-name
+ (gnus-group-real-name gnus-newsgroup-name))
+ default))
+ nil
+ nil
+ (number-to-string default))))
(if (string-match "^[ \t]*$" input) number input)))
((and (> scored marked) (< scored number)
(> (- scored number) 20))
@@ -5787,7 +5877,8 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(read-string
(format "%s %s (%d scored, %d total): "
"How many articles from"
- (gnus-group-decoded-name group)
+ (gnus-group-decoded-name
+ (gnus-group-real-name gnus-newsgroup-name))
scored number))))
(if (string-match "^[ \t]*$" input)
number input)))
@@ -5857,6 +5948,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)
@@ -5973,12 +6068,24 @@ If SELECT-ARTICLES, only select those articles from GROUP."
'request-set-mark gnus-newsgroup-name)
(not (gnus-article-unpropagatable-p (cdr type))))
(let* ((old (cdr (assq (cdr type) (gnus-info-marks info))))
- (del (gnus-remove-from-range (gnus-copy-sequence old) list))
- (add (gnus-remove-from-range
- (gnus-copy-sequence list) old)))
+ ;; Don't do anything about marks for articles we
+ ;; didn't actually get any headers for.
+ (del
+ (gnus-list-range-intersection
+ gnus-newsgroup-articles
+ (gnus-remove-from-range (gnus-copy-sequence old) list)))
+ (add
+ (gnus-list-range-intersection
+ gnus-newsgroup-articles
+ (gnus-remove-from-range
+ (gnus-copy-sequence list) old))))
(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 +6168,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 +6205,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 +6277,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 +6318,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
@@ -6480,9 +6588,8 @@ the subject line on."
(1+ (point-at-eol))
(gnus-delete-line))))))
;; Remove list identifiers from subject.
- (when gnus-list-identifiers
- (let ((gnus-newsgroup-headers (list header)))
- (gnus-summary-remove-list-identifiers)))
+ (let ((gnus-newsgroup-headers (list header)))
+ (gnus-summary-remove-list-identifiers))
(when old-header
(mail-header-set-number header (mail-header-number old-header)))
(setq gnus-newsgroup-sparse
@@ -6927,11 +7034,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-window' 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 +7119,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
@@ -7071,6 +7190,7 @@ If FORCE (the prefix), also save the .newsrc file(s)."
(let* ((group gnus-newsgroup-name)
(quit-config (gnus-group-quit-config gnus-newsgroup-name))
(gnus-group-is-exiting-p t)
+ (article-buffer gnus-article-buffer)
(mode major-mode)
(group-point nil)
(buf (current-buffer)))
@@ -7081,15 +7201,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 +7237,12 @@ 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)))
+
(setq gnus-current-select-method gnus-select-method)
(set-buffer gnus-group-buffer)
(if quit-config
@@ -7149,6 +7254,17 @@ If FORCE (the prefix), also save the .newsrc file(s)."
(if win (set-window-point win (point))))
(unless leave-hidden
(gnus-configure-windows 'group 'force)))
+
+ ;; If we have several article buffers, we kill them at exit.
+ (unless gnus-single-article-buffer
+ (when (gnus-buffer-live-p article-buffer)
+ (with-current-buffer article-buffer
+ ;; Don't kill sticky article buffers
+ (unless (eq major-mode 'gnus-sticky-article-mode)
+ (gnus-kill-buffer article-buffer)
+ (setq gnus-article-current nil))))
+ (gnus-kill-buffer gnus-original-article-buffer))
+
;; Clear the current group name.
(unless quit-config
(setq gnus-newsgroup-name nil)))))
@@ -7177,12 +7293,11 @@ If FORCE (the prefix), also save the .newsrc file(s)."
(gnus-kill-buffer gnus-article-buffer)
(gnus-kill-buffer gnus-original-article-buffer)
(setq gnus-article-current nil))
+ ;; Return to the group buffer.
+ (gnus-configure-windows 'group 'force)
(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))
@@ -7191,8 +7306,6 @@ If FORCE (the prefix), also save the .newsrc file(s)."
(gnus-async-prefetch-remove-group group)
(when (get-buffer gnus-article-buffer)
(bury-buffer gnus-article-buffer))
- ;; Return to the group buffer.
- (gnus-configure-windows 'group 'force)
;; Clear the current group name.
(setq gnus-newsgroup-name nil)
(unless (gnus-ephemeral-group-p group)
@@ -7246,33 +7359,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 +7427,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 +7436,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 +7500,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 +7523,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 +7684,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.
@@ -7668,13 +7755,11 @@ If BACKWARD, the previous article is selected instead of the next."
(point
(with-current-buffer gnus-group-buffer
(point)))
+ (current-summary (current-buffer))
(group
(if (eq gnus-keep-same-level 'best)
(gnus-summary-best-group gnus-newsgroup-name)
(gnus-summary-search-group backward gnus-keep-same-level))))
- ;; For some reason, the group window gets selected. We change
- ;; it back.
- (select-window (get-buffer-window (current-buffer)))
;; Select next unread newsgroup automagically.
(cond
((or (not gnus-auto-select-next)
@@ -7695,6 +7780,11 @@ If BACKWARD, the previous article is selected instead of the next."
(gnus-summary-next-group nil group backward)))
(t
(when (gnus-key-press-event-p last-input-event)
+ ;; Somehow or other, we may now have selected a different
+ ;; window. Make point go back to the summary buffer.
+ (when (eq current-summary (current-buffer))
+ ;; FIXME: This burps when get-buffer-window returns nil.
+ (select-window (get-buffer-window current-summary 0)))
(gnus-summary-walk-group-buffer
gnus-newsgroup-name cmd unread backward point))))))))
@@ -7805,7 +7895,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 +7948,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 +7965,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 +8022,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 +8105,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 +8294,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 +8347,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 +8361,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 +8389,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 +8408,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 +8434,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 +8485,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 +8540,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 +8589,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 +8763,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 +8800,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 +8846,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 +8937,41 @@ 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")
- (let ((id (mail-header-id (gnus-summary-article-header)))
- (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))
+ (gnus-warp-to-article)
+ (let* ((header (gnus-summary-article-header))
+ (id (mail-header-id header))
+ (gnus-inhibit-demon t)
+ (gnus-summary-ignore-duplicates t)
+ (gnus-read-all-available-headers t)
+ (limit (if limit (prefix-numeric-value limit)
+ gnus-refer-thread-limit)))
+ (setq gnus-newsgroup-headers
+ (gnus-merge
+ 'list gnus-newsgroup-headers
+ (if (gnus-check-backend-function
+ 'request-thread gnus-newsgroup-name)
+ (gnus-request-thread header)
+ (let* ((last (if (numberp limit)
+ (min (+ (mail-header-number header)
+ limit)
+ gnus-newsgroup-highest)
+ gnus-newsgroup-highest))
+ (subject (gnus-simplify-subject
+ (mail-header-subject header)))
+ (refs (split-string (or (mail-header-references 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)
@@ -8957,8 +9054,11 @@ of what's specified by the `gnus-refer-thread-limit' variable."
(defun gnus-summary-enter-digest-group (&optional force)
"Enter an nndoc group based on the current article.
-If FORCE, force a digest interpretation. If not, try
-to guess what the document format is."
+If FORCE, force a digest interpretation. If not, try to guess
+what the document format is.
+
+To control what happens when you exit the group, see the
+`gnus-auto-select-on-ephemeral-exit' variable."
(interactive "P")
(let ((conf gnus-current-window-configuration))
(save-window-excursion
@@ -9036,7 +9136,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 +9171,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 +9367,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 +9454,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,6 +9547,10 @@ strokes are `C-u g'."
((not arg)
;; Select the article the normal way.
(gnus-summary-select-article nil 'force))
+ ((equal arg '(16))
+ ;; C-u C-u g
+ (let ((gnus-inhibit-article-treatments t))
+ (gnus-summary-select-article nil 'force)))
(t
;; We have to require this here to make sure that the following
;; dynamic binding isn't shadowed by autoloading.
@@ -9544,7 +9665,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,6 +9814,9 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
articles)
(while articles
(setq article (pop articles))
+ ;; Set any marks that may have changed in the summary buffer.
+ (when gnus-preserve-marks
+ (gnus-summary-push-marks-to-backend article))
(setq
art-group
(cond
@@ -9704,21 +9828,25 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
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)))
+ (move-is-internal (gnus-server-equal from-method to-method)))
(gnus-request-move-article
article ; Article to move
- gnus-newsgroup-name ; From newsgroup
+ 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?
+ (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
- (when (gnus-request-article-this-buffer article gnus-newsgroup-name)
+ (when (gnus-request-article-this-buffer article
+ gnus-newsgroup-name)
(save-restriction
(nnheader-narrow-to-headers)
(dolist (hdr gnus-copy-article-ignored-headers)
@@ -9728,7 +9856,8 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
;; Crosspost the article.
((eq action 'crosspost)
(let ((xref (message-tokenize-header
- (mail-header-xref (gnus-summary-article-header article))
+ (mail-header-xref (gnus-summary-article-header
+ article))
" ")))
(setq new-xref (concat (gnus-group-real-name gnus-newsgroup-name)
":" (number-to-string article)))
@@ -9745,7 +9874,8 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
(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)))
+ to-newsgroup select-method (not articles)
+ t)))
(setq new-xref (concat new-xref " " (car art-group)
":"
(number-to-string (cdr art-group))))
@@ -9783,7 +9913,8 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
(unless (member to-group to-groups)
(push to-group to-groups))
- (unless (memq article gnus-newsgroup-unreads)
+ (when (and (not (memq article gnus-newsgroup-unreads))
+ (cdr art-group))
(push 'read to-marks)
(gnus-info-set-read
info (gnus-add-to-range (gnus-info-read info)
@@ -9794,24 +9925,29 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
(marks (if expirable
gnus-article-mark-lists
(delete '(expirable . expire)
- (copy-sequence gnus-article-mark-lists))))
+ (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
+ (when (and to-article
+ 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
+ (when (and gnus-preserve-marks
+ to-article)
;; 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)
+ (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))
@@ -9824,7 +9960,8 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
;; 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)))
+ (set (intern (format "gnus-newsgroup-%s"
+ (caar marks)))
(cons to-article
(symbol-value
(intern (format "gnus-newsgroup-%s"
@@ -9845,8 +9982,9 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
(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))))
+ (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 '"
@@ -9871,15 +10009,17 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
to-newsgroup
select-method))
- ;;;!!!Why is this necessary?
+ ;;;!!!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))))
+ (save-excursion
+ (gnus-summary-goto-subject article)
+ (gnus-summary-mark-article article gnus-canceled-mark)))))
(push article articles-to-update-marks))
- (apply 'gnus-summary-remove-process-mark 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 +10029,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))
+ (unless (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.
@@ -9927,15 +10081,15 @@ current group into whatever groups they are destined to. In the
latter case, they will be copied into the relevant groups."
(interactive
(list current-prefix-arg
- (let* ((methods (gnus-methods-using 'respool))
+ (let* ((methods (mapcar #'car (gnus-methods-using 'respool)))
(methname
(symbol-name (or gnus-summary-respool-default-method
(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 +10099,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 +10289,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 +10400,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 +10420,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 +10452,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 +10682,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 +10703,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 +10829,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 +10914,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 +10942,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 +11003,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 +11013,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 +11354,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 +11462,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 +11473,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 +11684,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 +11841,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 +12050,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 +12068,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 "")
@@ -11970,9 +12116,9 @@ If REVERSE, save parts that do not match TYPE."
gnus-summary-save-parts-default-mime)
'gnus-summary-save-parts-type-history)
(setq gnus-summary-save-parts-last-directory
- (read-file-name "Save to directory: "
- gnus-summary-save-parts-last-directory
- nil t))
+ (read-directory-name "Save to directory: "
+ gnus-summary-save-parts-last-directory
+ nil t))
current-prefix-arg))
(gnus-summary-iterate n
(let ((gnus-display-mime-function nil)
@@ -12005,10 +12151,7 @@ If REVERSE, save parts that do not match TYPE."
mm-file-name-rewrite-functions
(file-name-nondirectory
(or
- (mail-content-type-get
- (mm-handle-disposition handle) 'filename)
- (mail-content-type-get
- (mm-handle-type handle) 'name)
+ (mm-handle-filename handle)
(format "%s.%d.%d" gnus-newsgroup-name
(cdr gnus-article-current)
gnus-summary-save-parts-counter))))
@@ -12313,7 +12456,10 @@ UNREAD is a sorted list."
(save-excursion
(let (setmarkundo)
;; Propagate the read marks to the backend.
- (when (and gnus-propagate-marks
+ (when (and (or gnus-propagate-marks
+ (gnus-method-option-p
+ (gnus-find-method-for-group group)
+ 'server-marks))
(gnus-check-backend-function 'request-set-mark group))
(let ((del (gnus-remove-from-range (gnus-info-read info) read))
(add (gnus-remove-from-range read (gnus-info-read info))))
@@ -12545,8 +12691,7 @@ returned."
(when gnus-agent
(gnus-agent-get-undownloaded-list))
;; Remove list identifiers from subject
- (when gnus-list-identifiers
- (gnus-summary-remove-list-identifiers))
+ (gnus-summary-remove-list-identifiers)
;; First and last article in this newsgroup.
(when gnus-newsgroup-headers
(setq gnus-newsgroup-begin
@@ -12633,13 +12778,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 +12797,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 +12867,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..fbdacdd2fbe
--- /dev/null
+++ b/lisp/gnus/gnus-sync.el
@@ -0,0 +1,242 @@
+;;; gnus-sync.el --- synchronization facility for Gnus
+
+;; Copyright (C) 2010-2011 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, and my plan is to do this once No
+;; Gnus development is done. 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. So it's not
+;; run automatically, you have to call it with M-x gnus-sync-read
+
+;; - 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-read-newsrc-el-hook 'gnus-sync-read)
+ (add-hook 'gnus-save-newsrc-hook 'gnus-sync-save))
+
+(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 6c74a8620cb..f1a2ed43e26 100644
--- a/lisp/gnus/gnus-topic.el
+++ b/lisp/gnus/gnus-topic.el
@@ -1,7 +1,6 @@
;;; gnus-topic.el --- a folding minor mode for Gnus group buffers
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-2011 Free Software Foundation, Inc.
;; Author: Ilja Weis <kult@uni-paderborn.de>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -148,8 +147,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 +160,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 +908,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 +1135,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 +1254,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 +1302,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 +1349,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 +1443,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 +1492,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 +1504,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 +1726,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 +1742,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 +1781,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 6f814e52411..5530c3d9a34 100644
--- a/lisp/gnus/gnus-undo.el
+++ b/lisp/gnus/gnus-undo.el
@@ -1,7 +1,6 @@
;;; gnus-undo.el --- minor mode for undoing in Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -45,6 +44,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 +61,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 +83,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 +100,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 +187,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 b7a0605d6b3..3f66b45aaab 100644
--- a/lisp/gnus/gnus-util.el
+++ b/lisp/gnus/gnus-util.el
@@ -1,7 +1,6 @@
;;; gnus-util.el --- utility functions for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -33,16 +32,43 @@
;;; 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))))
+(require 'time-date)
+
+(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 +79,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 +148,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 +226,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 +251,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 +278,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))
@@ -291,14 +333,16 @@ Symbols are also allowed; their print names are used instead."
(and (= (car fdate) (car date))
(> (nth 1 fdate) (nth 1 date))))))
+;; Every version of Emacs Gnus supports has built-in float-time.
+;; The featurep test silences an irritating compiler warning.
(eval-and-compile
- (if (and (fboundp 'float-time)
- (subrp (symbol-function 'float-time)))
+ (if (or (featurep 'emacs)
+ (fboundp '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 +388,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,57 +463,6 @@ TIME defaults to the current time."
(+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600)
(* (- (string-to-number days) 1) 3600 24))))
-(defvar gnus-user-date-format-alist
- '(((gnus-seconds-today) . "%k:%M")
- (604800 . "%a %k:%M") ;;that's one week
- ((gnus-seconds-month) . "%a %d")
- ((gnus-seconds-year) . "%b %d")
- (t . "%b %d '%y")) ;;this one is used when no
- ;;other does match
- "Specifies date format depending on age of article.
-This is an alist of items (AGE . FORMAT). AGE can be a number (of
-seconds) or a Lisp expression evaluating to a number. When the age of
-the article is less than this number, then use `format-time-string'
-with the corresponding FORMAT for displaying the date of the article.
-If AGE is not a number or a Lisp expression evaluating to a
-non-number, then the corresponding FORMAT is used as a default value.
-
-Note that the list is processed from the beginning, so it should be
-sorted by ascending AGE. Also note that items following the first
-non-number AGE will be ignored.
-
-You can use the functions `gnus-seconds-today', `gnus-seconds-month'
-and `gnus-seconds-year' in the AGE spec. They return the number of
-seconds passed since the start of today, of this month, of this year,
-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.
-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)))
- (now (gnus-float-time))
- ;;If we don't find something suitable we'll use this one
- (my-format "%b %d '%y"))
- (let* ((difference (- now messy-date))
- (templist gnus-user-date-format-alist)
- (top (eval (caar templist))))
- (while (if (numberp top) (< top difference) (not top))
- (progn
- (setq templist (cdr templist))
- (setq top (eval (caar templist)))))
- (if (stringp (cdr (car templist)))
- (setq my-format (cdr (car templist)))))
- (format-time-string (eval my-format) (seconds-to-time messy-date)))
- (error " ? ")))
-
-(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))
- (error " - ")))
-
(defmacro gnus-date-get-time (date)
"Convert DATE string to Emacs time.
Cache the result as a text property stored in DATE."
@@ -494,6 +477,12 @@ Cache the result as a text property stored in DATE."
(put-text-property 0 1 'gnus-time time d)
time)))))
+(defun gnus-dd-mmm (messy-date)
+ "Return a string like DD-MMM from a big messy string."
+ (condition-case ()
+ (format-time-string "%d-%b" (gnus-date-get-time messy-date))
+ (error " - ")))
+
(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 +590,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 +606,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'."
@@ -669,11 +672,9 @@ If N, return the Nth ancestor instead."
(when (string-match "\\(<[^<]+>\\)[ \t]*\\'" references)
(match-string 1 references))))))
-(defun gnus-buffer-live-p (buffer)
+(defsubst gnus-buffer-live-p (buffer)
"Say whether BUFFER is alive or not."
- (and buffer
- (get-buffer buffer)
- (buffer-name (get-buffer buffer))))
+ (and buffer (buffer-live-p (get-buffer buffer))))
(defun gnus-horizontal-recenter ()
"Recenter the current buffer horizontally."
@@ -856,6 +857,7 @@ Bind `print-quoted' and `print-readably' to t, and `print-length' and
(defun gnus-write-buffer (file)
"Write the current buffer's contents to FILE."
+ (require 'nnmail)
(let ((file-name-coding-system nnmail-pathname-coding-system))
;; Make sure the directory exists.
(gnus-make-directory (file-name-directory file))
@@ -867,6 +869,15 @@ Bind `print-quoted' and `print-readably' to t, and `print-length' and
(when (file-exists-p file)
(delete-file file)))
+(defun gnus-delete-duplicates (list)
+ "Remove duplicate entries from LIST."
+ (let ((result nil))
+ (while list
+ (unless (member (car list) result)
+ (push (car list) result))
+ (pop list))
+ (nreverse result)))
+
(defun gnus-delete-directory (directory)
"Delete files in DIRECTORY. Subdirectories remain.
If there's no subdirectory, delete DIRECTORY as well."
@@ -1070,23 +1081,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)
@@ -1099,6 +1102,7 @@ In Emacs 22 this writes Babyl format; in Emacs 23 it writes mbox unless
FILENAME exists and is Babyl format."
(require 'rmail)
(require 'mm-util)
+ (require 'nnmail)
;; Some of this codes is borrowed from rmailout.el.
(setq filename (expand-file-name filename))
;; FIXME should we really be messing with this defcustom?
@@ -1123,8 +1127,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)
@@ -1191,6 +1194,7 @@ FILENAME exists and is Babyl format."
(defun gnus-output-to-mail (filename &optional ask)
"Append the current article to a mail file named FILENAME."
+ (require 'nnmail)
(setq filename (expand-file-name filename))
(let ((artbuf (current-buffer))
(tmpbuf (get-buffer-create " *Gnus-output*")))
@@ -1202,8 +1206,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 +1271,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 +1290,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 +1339,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 +1605,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 +1745,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 +1919,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 +1943,85 @@ 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))))
+
+(eval-and-compile
+ (if (fboundp 'macroexpand-all)
+ (defalias 'gnus-macroexpand-all 'macroexpand-all)
+ (defun gnus-macroexpand-all (form &optional environment)
+ "Return result of expanding macros at all levels in FORM.
+If no macros are expanded, FORM is returned unchanged.
+The second optional arg ENVIRONMENT specifies an environment of macro
+definitions to shadow the loaded ones for use in file byte-compilation."
+ (if (consp form)
+ (let ((idx 1)
+ (len (length (setq form (copy-sequence form))))
+ expanded)
+ (while (< idx len)
+ (setcar (nthcdr idx form) (gnus-macroexpand-all (nth idx form)
+ environment))
+ (setq idx (1+ idx)))
+ (if (eq (setq expanded (macroexpand form environment)) form)
+ form
+ (gnus-macroexpand-all expanded environment)))
+ form))))
+
(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 9d3cc9383ab..05ba3595479 100644
--- a/lisp/gnus/gnus-uu.el
+++ b/lisp/gnus/gnus-uu.el
@@ -1,7 +1,7 @@
;;; gnus-uu.el --- extract (uu)encoded files in Gnus
-;; Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1996, 1997, 1998,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1987, 1993-1998, 2000-2011
+;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Created: 2 Oct 1993
@@ -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\\)")
@@ -367,7 +366,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(interactive
(list current-prefix-arg
(file-name-as-directory
- (read-file-name "Uudecode and save in dir: "
+ (read-directory-name "Uudecode and save in dir: "
gnus-uu-default-dir
gnus-uu-default-dir t))))
(gnus-uu-decode-with-method 'gnus-uu-uustrip-article n dir nil nil t))
@@ -382,7 +381,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(interactive
(list current-prefix-arg
(file-name-as-directory
- (read-file-name "Unshar and save in dir: "
+ (read-directory-name "Unshar and save in dir: "
gnus-uu-default-dir
gnus-uu-default-dir t))))
(gnus-uu-decode-with-method 'gnus-uu-unshar-article n dir nil 'scan t))
@@ -391,12 +390,11 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
"Saves the current article."
(interactive
(list current-prefix-arg
- (read-file-name
- (if gnus-uu-save-separate-articles
- "Save articles in dir: "
- "Save articles in file: ")
- gnus-uu-default-dir
- gnus-uu-default-dir)))
+ (if gnus-uu-save-separate-articles
+ (read-directory-name
+ "Save articles in dir: " gnus-uu-default-dir gnus-uu-default-dir)
+ (read-file-name
+ "Save article in file: " gnus-uu-default-dir gnus-uu-default-dir))))
(setq gnus-uu-saved-article-name file)
(gnus-uu-decode-with-method 'gnus-uu-save-article n nil t))
@@ -405,7 +403,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(interactive
(list current-prefix-arg
(file-name-as-directory
- (read-file-name "Unbinhex and save in dir: "
+ (read-directory-name "Unbinhex and save in dir: "
gnus-uu-default-dir
gnus-uu-default-dir))))
(setq gnus-uu-binhex-article-name
@@ -417,7 +415,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(interactive
(list current-prefix-arg
(file-name-as-directory
- (read-file-name "yEnc decode and save in dir: "
+ (read-directory-name "yEnc decode and save in dir: "
gnus-uu-default-dir
gnus-uu-default-dir))))
(setq gnus-uu-yenc-article-name nil)
@@ -459,10 +457,11 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
"Saves and views the current article."
(interactive
(list current-prefix-arg
- (read-file-name (if gnus-uu-save-separate-articles
- "Save articles is dir: "
- "Save articles in file: ")
- gnus-uu-default-dir gnus-uu-default-dir)))
+ (if gnus-uu-save-separate-articles
+ (read-directory-name "Save articles in dir: "
+ gnus-uu-default-dir gnus-uu-default-dir)
+ (read-file-name "Save articles in file: "
+ gnus-uu-default-dir gnus-uu-default-dir))))
(let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic)))
(gnus-uu-decode-save n file)))
@@ -743,7 +742,7 @@ When called interactively, prompt for REGEXP."
(interactive
(list current-prefix-arg
(file-name-as-directory
- (read-file-name "Save in dir: "
+ (read-directory-name "Save in dir: "
gnus-uu-default-dir
gnus-uu-default-dir t))))
(gnus-uu-decode-with-method 'gnus-uu-decode-postscript-article
@@ -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 bc27cfb1c4f..522f03c43c1 100644
--- a/lisp/gnus/gnus-vm.el
+++ b/lisp/gnus/gnus-vm.el
@@ -1,7 +1,6 @@
;;; gnus-vm.el --- vm interface for Gnus
-;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-2011 Free Software Foundation, Inc.
;; Author: Per Persson <pp@gnu.ai.mit.edu>
;; Keywords: news, mail
@@ -103,5 +102,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 1aa5592a850..c38f57d96cb 100644
--- a/lisp/gnus/gnus-win.el
+++ b/lisp/gnus/gnus-win.el
@@ -1,7 +1,6 @@
;;; gnus-win.el --- window configuration functions for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -39,9 +38,6 @@
:group 'gnus-windows
:type 'boolean)
-(defvar gnus-window-configuration nil
- "Obsolete variable. See `gnus-buffer-configuration'.")
-
(defcustom gnus-window-min-width 2
"*Minimum width of Gnus buffers."
:group 'gnus-windows
@@ -68,12 +64,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 +78,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 +98,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 +136,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 +179,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)
@@ -229,56 +218,6 @@ See the Gnus manual for an explanation of the syntax used.")
(delete-frame (car gnus-created-frames))))
(pop gnus-created-frames)))
-(defun gnus-window-configuration-element (list)
- (while (and list
- (not (assq (car list) gnus-window-configuration)))
- (pop list))
- (cadr (assq (car list) gnus-window-configuration)))
-
-(defun gnus-windows-old-to-new (setting)
- ;; First we take care of the really, really old Gnus 3 actions.
- (when (symbolp setting)
- (setq setting
- ;; Take care of ooold GNUS 3.x values.
- (cond ((eq setting 'SelectArticle) 'article)
- ((memq setting '(SelectNewsgroup SelectSubject ExpandSubject))
- 'summary)
- ((memq setting '(ExitNewsgroup)) 'group)
- (t setting))))
- (if (or (listp setting)
- (not (and gnus-window-configuration
- (memq setting '(group summary article)))))
- setting
- (let* ((elem
- (cond
- ((eq setting 'group)
- (gnus-window-configuration-element
- '(group newsgroups ExitNewsgroup)))
- ((eq setting 'summary)
- (gnus-window-configuration-element
- '(summary SelectNewsgroup SelectSubject ExpandSubject)))
- ((eq setting 'article)
- (gnus-window-configuration-element
- '(article SelectArticle)))))
- (total (apply '+ elem))
- (types '(group summary article))
- (pbuf (if (eq setting 'newsgroups) 'group 'summary))
- (i 0)
- perc out)
- (while (< i 3)
- (or (not (numberp (nth i elem)))
- (zerop (nth i elem))
- (progn
- (setq perc (if (= i 2)
- 1.0
- (/ (float (nth i elem)) total)))
- (push (if (eq pbuf (nth i types))
- (list (nth i types) perc 'point)
- (list (nth i types) perc))
- out)))
- (incf i))
- `(vertical 1.0 ,@(nreverse out)))))
-
;;;###autoload
(defun gnus-add-configuration (conf)
"Add the window configuration CONF to `gnus-buffer-configuration'."
@@ -300,18 +239,9 @@ See the Gnus manual for an explanation of the syntax used.")
(defun gnus-configure-frame (split &optional window)
"Split WINDOW according to SPLIT."
- (let ((current-window
- (or (get-buffer-window (current-buffer)) (selected-window))))
- (unless window
- (setq window current-window))
+ (let* ((current-window (or (get-buffer-window (current-buffer)) (selected-window)))
+ (window (or window current-window)))
(select-window window)
- ;; This might be an old-style buffer config.
- (when (vectorp split)
- (setq split (append split nil)))
- (when (or (consp (car split))
- (vectorp (car split)))
- (push 1.0 split)
- (push 'vertical split))
;; The SPLIT might be something that is to be evaled to
;; return a new SPLIT.
(while (and (not (assq (car split) gnus-window-to-buffer))
@@ -338,8 +268,10 @@ See the Gnus manual for an explanation of the syntax used.")
(error "Invalid buffer type: %s" type))
(let ((buf (gnus-get-buffer-create
(gnus-window-to-buffer-helper buffer))))
- (if (eq buf (window-buffer (selected-window))) (set-buffer buf)
- (switch-to-buffer buf)))
+ (when (buffer-name buf)
+ (if (eq buf (window-buffer (selected-window)))
+ (set-buffer buf)
+ (switch-to-buffer buf))))
(when (memq 'frame-focus split)
(setq gnus-window-frame-focus window))
;; We return the window if it has the `point' spec.
@@ -430,56 +362,55 @@ See the Gnus manual for an explanation of the syntax used.")
(set-window-configuration setting)
(setq gnus-current-window-configuration setting)
(setq force (or force gnus-always-force-window-configuration))
- (setq setting (gnus-windows-old-to-new setting))
(let ((split (if (symbolp setting)
- (cadr (assq setting gnus-buffer-configuration))
- setting))
- all-visible)
+ (cadr (assq setting gnus-buffer-configuration))
+ setting))
+ all-visible)
(setq gnus-frame-split-p nil)
(unless split
- (error "No such setting in `gnus-buffer-configuration': %s" setting))
+ (error "No such setting in `gnus-buffer-configuration': %s" setting))
(if (and (setq all-visible (gnus-all-windows-visible-p split))
- (not force))
- ;; All the windows mentioned are already visible, so we just
- ;; put point in the assigned buffer, and do not touch the
- ;; winconf.
- (select-window all-visible)
-
- ;; Make sure "the other" buffer, nntp-server-buffer, is live.
- (unless (gnus-buffer-live-p nntp-server-buffer)
- (nnheader-init-server-buffer))
-
- ;; Either remove all windows or just remove all Gnus windows.
- (let ((frame (selected-frame)))
- (unwind-protect
- (if gnus-use-full-window
- ;; We want to remove all other windows.
- (if (not gnus-frame-split-p)
- ;; This is not a `frame' split, so we ignore the
- ;; other frames.
- (delete-other-windows)
- ;; This is a `frame' split, so we delete all windows
- ;; on all frames.
- (gnus-delete-windows-in-gnusey-frames))
- ;; Just remove some windows.
- (gnus-remove-some-windows)
- (if (featurep 'xemacs)
- (switch-to-buffer nntp-server-buffer)
- (set-buffer nntp-server-buffer)))
- (select-frame frame)))
-
- (let (gnus-window-frame-focus)
- (if (featurep 'xemacs)
- (switch-to-buffer nntp-server-buffer)
- (set-buffer nntp-server-buffer))
- (gnus-configure-frame split)
- (run-hooks 'gnus-configure-windows-hook)
- (when gnus-window-frame-focus
- (gnus-select-frame-set-input-focus
- (window-frame gnus-window-frame-focus))))))))
+ (not force))
+ ;; All the windows mentioned are already visible, so we just
+ ;; put point in the assigned buffer, and do not touch the
+ ;; winconf.
+ (select-window all-visible)
+
+ ;; Make sure "the other" buffer, nntp-server-buffer, is live.
+ (unless (gnus-buffer-live-p nntp-server-buffer)
+ (nnheader-init-server-buffer))
+
+ ;; Either remove all windows or just remove all Gnus windows.
+ (let ((frame (selected-frame)))
+ (unwind-protect
+ (if gnus-use-full-window
+ ;; We want to remove all other windows.
+ (if (not gnus-frame-split-p)
+ ;; This is not a `frame' split, so we ignore the
+ ;; other frames.
+ (delete-other-windows)
+ ;; This is a `frame' split, so we delete all windows
+ ;; on all frames.
+ (gnus-delete-windows-in-gnusey-frames))
+ ;; Just remove some windows.
+ (gnus-remove-some-windows)
+ (if (featurep 'xemacs)
+ (switch-to-buffer nntp-server-buffer)
+ (set-buffer nntp-server-buffer)))
+ (select-frame frame)))
+
+ (let (gnus-window-frame-focus)
+ (if (featurep 'xemacs)
+ (switch-to-buffer nntp-server-buffer)
+ (set-buffer nntp-server-buffer))
+ (gnus-configure-frame split)
+ (run-hooks 'gnus-configure-windows-hook)
+ (when gnus-window-frame-focus
+ (gnus-select-frame-set-input-focus
+ (window-frame gnus-window-frame-focus))))))))
(defun gnus-delete-windows-in-gnusey-frames ()
"Do a `delete-other-windows' in all frames that have Gnus windows."
@@ -508,11 +439,7 @@ should have point."
type buffer win buf)
(while (and (setq split (pop stack))
all-visible)
- ;; Be backwards compatible.
- (when (vectorp split)
- (setq split (append split nil)))
- (when (or (consp (car split))
- (vectorp (car split)))
+ (when (consp (car split))
(push 1.0 split)
(push 'vertical split))
;; The SPLIT might be something that is to be evaled to
@@ -544,6 +471,7 @@ should have point."
all-visible)))
(defun gnus-window-top-edge (&optional window)
+ "Return the top coordinate of WINDOW."
(nth 1 (window-edges window)))
(defun gnus-remove-some-windows ()
@@ -590,5 +518,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 5180673386c..8797780251a 100644
--- a/lisp/gnus/gnus.el
+++ b/lisp/gnus/gnus.el
@@ -1,12 +1,12 @@
;;; 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, 2011
+;; Copyright (C) 1987-1990, 1993-1998, 2000-2011
;; 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 +29,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 +307,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 +349,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 +916,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 +949,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 +974,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 +989,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 +1028,50 @@ 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 (gnus-splash-svg-color-symbols (find-image
+ `((:type svg :file "gnus.svg"
+ :color-symbols
+ (("#bf9900" . ,(car gnus-logo-colors))
+ ("#ffcc00" . ,(cadr gnus-logo-colors))))
+ (:type xpm :file "gnus.xpm"
+ :color-symbols
+ (("thing" . ,(car gnus-logo-colors))
+ ("shadow" . ,(cadr gnus-logo-colors))))
+ (: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 +1090,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 +1102,25 @@ 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)))
+
+(defun gnus-splash-svg-color-symbols (list)
+ "Do color-symbol search-and-replace in svg file."
+ (let ((type (plist-get (cdr list) :type))
+ (file (plist-get (cdr list) :file))
+ (color-symbols (plist-get (cdr list) :color-symbols)))
+ (if (string= type "svg")
+ (let ((data (with-temp-buffer (insert-file-contents file)
+ (buffer-string))))
+ (mapc (lambda (rule)
+ (setq data (replace-regexp-in-string
+ (concat "fill:" (car rule))
+ (concat "fill:" (cdr rule)) data)))
+ color-symbols)
+ (cons (car list) (list :type type :data data)))
+ list)))
(eval-when (load)
(let ((command (format "%s" this-command)))
@@ -1275,15 +1276,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 +1299,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 +1347,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 +1372,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 +1388,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 +1409,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,14 +1417,11 @@ no need to set this variable."
:group 'gnus-message
:type '(choice (const :tag "default" nil)
string))
-
-(defvar gnus-local-organization nil
- "String with a description of what organization (if any) the user belongs to.
-Obsolete variable; use `message-user-organization' instead.")
+(make-obsolete-variable 'gnus-local-domain nil "Emacs 24.1")
;; 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 +1433,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 +1448,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 +1469,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 +1487,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 +1552,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 +1604,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,21 +1620,14 @@ 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)
+ ("nnimap" post-mail address prompt-address physical-address respool
+ server-marks)
("nnmaildir" mail respool address)
("nnnil" none))
"*An alist of valid select methods.
@@ -1774,7 +1648,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 +1685,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))
@@ -2001,7 +1875,10 @@ total number of articles in the group.")
:function-document
"Whether this group should be ignored by the registry."
:variable gnus-registry-ignored-groups
- :variable-default nil
+ :variable-default (mapcar
+ (lambda (g) (list g t))
+ '("delayed$" "drafts$" "queue$" "INBOX$"
+ "^nnmairix:" "archive"))
:variable-document
"*Groups in which the registry should be turned off."
:variable-group gnus-registry
@@ -2688,6 +2565,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 compatibility.
+(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 +2587,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 +2614,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 +2627,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 +2770,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 +2785,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 +2901,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
@@ -3038,7 +2910,8 @@ gnus-registry.el will populate this if it's loaded.")
gnus-agent-save-active gnus-agent-method-p
gnus-agent-get-undownloaded-list gnus-agent-fetch-session
gnus-summary-set-agent-mark gnus-agent-save-group-info
- gnus-agent-request-article gnus-agent-retrieve-headers)
+ gnus-agent-request-article gnus-agent-retrieve-headers
+ gnus-agent-store-article gnus-agent-group-covered-p)
("gnus-agent" :interactive t
gnus-unplugged gnus-agentize gnus-agent-batch)
("gnus-vm" :interactive t gnus-summary-save-in-vm
@@ -3059,50 +2932,62 @@ gnus-registry.el will populate this if it's loaded.")
It works along the same lines as a normal formatting string,
with some simple extensions.
-%N Article number, left padded with spaces (string)
-%S Subject (string)
-%s Subject if it is at the root of a thread, and \"\" otherwise (string)
-%n Name of the poster (string)
-%a Extracted name of the poster (string)
-%A Extracted address of the poster (string)
-%F Contents of the From: header (string)
-%f Contents of the From: or To: headers (string)
-%x Contents of the Xref: header (string)
-%D Date of the article (string)
-%d Date of the article (string) in DD-MMM format
-%o Date of the article (string) in YYYYMMDD`T'HHMMSS format
-%M Message-id of the article (string)
-%r References of the article (string)
-%c Number of characters in the article (integer)
-%k Pretty-printed version of the above (string)
- For example, \"1.2k\" or \"0.4M\".
-%L Number of lines in the article (integer)
-%I Indentation based on thread level (a string of spaces)
-%B A complex trn-style thread tree (string)
- The variables `gnus-sum-thread-*' can be used for customization.
-%T A string with two possible values: 80 spaces if the article
- is on thread level two or larger and 0 spaces on level one
-%R \"A\" if this article has been replied to, \" \" otherwise (character)
-%U Status of this article (character, \"R\", \"K\", \"-\" or \" \")
-%[ Opening bracket (character, \"[\" or \"<\")
-%] Closing bracket (character, \"]\" or \">\")
-%> Spaces of length thread-level (string)
-%< Spaces of length (- 20 thread-level) (string)
-%i Article score (number)
-%z Article zcore (character)
-%t Number of articles under the current thread (number).
-%e Whether the thread is empty or not (character).
-%V Total thread score (number).
-%P The line number (number).
-%O Download mark (character).
-%* If present, indicates desired cursor position
- (instead of after first colon).
-%u User defined specifier. The next character in the format string should
- be a letter. Gnus will call the function gnus-user-format-function-X,
- where X is the letter following %u. The function will be passed the
- current header as argument. The function should return a string, which
- will be inserted into the summary just like information from any other
- summary specifier.
+%N Article number, left padded with spaces (string)
+%S Subject (string)
+%s Subject if it is at the root of a thread, and \"\"
+ otherwise (string)
+%n Name of the poster (string)
+%a Extracted name of the poster (string)
+%A Extracted address of the poster (string)
+%F Contents of the From: header (string)
+%f Contents of the From: or To: headers (string)
+%x Contents of the Xref: header (string)
+%D Date of the article (string)
+%d Date of the article (string) in DD-MMM format
+%o Date of the article (string) in YYYYMMDD`T'HHMMSS
+ format
+%M Message-id of the article (string)
+%r References of the article (string)
+%c Number of characters in the article (integer)
+%k Pretty-printed version of the above (string)
+ For example, \"1.2k\" or \"0.4M\".
+%L Number of lines in the article (integer)
+%I Indentation based on thread level (a string of
+ spaces)
+%B A complex trn-style thread tree (string)
+ The variables `gnus-sum-thread-*' can be used for
+ customization.
+%T A string with two possible values: 80 spaces if the
+ article is on thread level two or larger and 0 spaces
+ on level one
+%R \"A\" if this article has been replied to, \" \"
+ otherwise (character)
+%U Status of this article (character, \"R\", \"K\",
+ \"-\" or \" \")
+%[ Opening bracket (character, \"[\" or \"<\")
+%] Closing bracket (character, \"]\" or \">\")
+%> Spaces of length thread-level (string)
+%< Spaces of length (- 20 thread-level) (string)
+%i Article score (number)
+%z Article zcore (character)
+%t Number of articles under the current thread (number).
+%e Whether the thread is empty or not (character).
+%V Total thread score (number).
+%P The line number (number).
+%O Download mark (character).
+%* If present, indicates desired cursor position
+ (instead of after first colon).
+%u User defined specifier. The next character in the
+ format string should be a letter. Gnus will call the
+ function gnus-user-format-function-X, where X is the
+ letter following %u. The function will be passed the
+ current header as argument. The function should
+ return a string, which will be inserted into the
+ summary just like information from any other summary
+ specifier.
+&user-date; Age sensitive date format. Various date format is
+ defined in `gnus-summary-user-date-format-alist'.
+
The %U (status), %R (replied) and %z (zcore) specs have to be handled
with care. For reasons of efficiency, Gnus will compute what column
@@ -3253,6 +3138,10 @@ Return nil if not defined."
(defmacro gnus-get-info (group)
`(nth 2 (gnus-gethash ,group gnus-newsrc-hashtb)))
+(defun gnus-set-info (group info)
+ (setcar (nthcdr 2 (gnus-gethash group gnus-newsrc-hashtb))
+ info))
+
;;; Load the compatibility functions.
(require 'gnus-ems)
@@ -3298,12 +3187,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 +3208,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)
@@ -3403,7 +3291,7 @@ g -- Group name."
((= c ?d)
(point))
((= c ?D)
- (read-file-name prompt nil default-directory 'lambda))
+ (read-directory-name prompt nil default-directory 'lambda))
((= c ?f)
(read-file-name prompt nil nil 'lambda))
((= c ?F)
@@ -3503,14 +3391,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 +3463,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 +3489,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 +3533,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 +3580,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 +3815,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 +3865,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 +3875,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 +3923,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 +3937,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 +4042,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 +4089,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 +4112,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 +4142,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 +4178,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 +4252,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 +4370,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 +4387,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..4b0c9a16283
--- /dev/null
+++ b/lisp/gnus/gravatar.el
@@ -0,0 +1,159 @@
+;;; gravatar.el --- Get Gravatars
+
+;; Copyright (C) 2010-2011 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."
+ (save-excursion
+ (goto-char (point-min))
+ (when (re-search-forward "^HTTP/.+ 200 OK$" nil (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)
+ (let ((args (list url
+ 'gravatar-retrieved
+ (list cb (when cbargs cbargs)))))
+ (when (> (length (if (featurep 'xemacs)
+ (cdr (split-string (function-arglist 'url-retrieve)))
+ (help-function-arglist 'url-retrieve)))
+ 4)
+ (setq args (nconc args (list t))))
+ (apply #'url-retrieve args))
+ (apply cb
+ (with-temp-buffer
+ (mm-disable-multibyte)
+ (url-cache-extract (url-cache-create-filename url))
+ (gravatar-data->image))
+ cbargs))))
+
+;;;###autoload
+(defun gravatar-retrieve-synchronously (mail-address)
+ "Retrieve MAIL-ADDRESS gravatar and returns it."
+ (let ((url (gravatar-build-url mail-address)))
+ (if (gravatar-cache-expired url)
+ (with-current-buffer (if (featurep 'xemacs)
+ (url-retrieve url)
+ (url-retrieve-synchronously url))
+ (when gravatar-automatic-caching
+ (url-store-in-cache (current-buffer)))
+ (let ((data (gravatar-data->image)))
+ (kill-buffer (current-buffer))
+ data))
+ (with-temp-buffer
+ (mm-disable-multibyte)
+ (url-cache-extract (url-cache-create-filename url))
+ (gravatar-data->image)))))
+
+
+(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/gssapi.el b/lisp/gnus/gssapi.el
new file mode 100644
index 00000000000..e96c23b14ac
--- /dev/null
+++ b/lisp/gnus/gssapi.el
@@ -0,0 +1,105 @@
+;;; gssapi.el --- GSSAPI/Kerberos 5 interface for Emacs
+
+;; Copyright (C) 2011 Free Software Foundation, Inc.
+
+;; Author: Simon Josefsson <simon@josefsson.org>
+;; Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Keywords: network
+
+;; 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 'format-spec)
+
+(defcustom gssapi-program (list
+ (concat "gsasl %s %p "
+ "--mechanism GSSAPI "
+ "--authentication-id %l")
+ "imtest -m gssapi -u %l -p %p %s")
+ "List of strings containing commands for GSSAPI (krb5) authentication.
+%s is replaced with server hostname, %p with port to connect to,
+and %l with the user name. The program should accept commands on
+stdin and return responses to stdout. Each entry in the list is
+tried until a successful connection is made."
+ :group 'network
+ :type '(repeat string))
+
+(defun open-gssapi-stream (name buffer server port user)
+ (let ((cmds gssapi-program)
+ cmd done)
+ (with-current-buffer buffer
+ (while (and (not done)
+ (setq cmd (pop cmds)))
+ (message "Opening GSSAPI connection with `%s'..." cmd)
+ (erase-buffer)
+ (let* ((coding-system-for-read 'binary)
+ (coding-system-for-write 'binary)
+ (process (start-process
+ name buffer shell-file-name shell-command-switch
+ (format-spec
+ cmd
+ (format-spec-make
+ ?s server
+ ?p (number-to-string port)
+ ?l user))))
+ response)
+ (when process
+ (while (and (memq (process-status process) '(open run))
+ (goto-char (point-min))
+ ;; Athena IMTEST can output SSL verify errors
+ (or (while (looking-at "^verify error:num=")
+ (forward-line))
+ t)
+ (or (while (looking-at "^TLS connection established")
+ (forward-line))
+ t)
+ ;; cyrus 1.6.x (13? < x <= 22) queries capabilities
+ (or (while (looking-at "^C:")
+ (forward-line))
+ t)
+ ;; cyrus 1.6 imtest print "S: " before server greeting
+ (or (not (looking-at "S: "))
+ (forward-char 3)
+ t)
+ ;; GNU SASL may print 'Trying ...' first.
+ (or (not (looking-at "Trying "))
+ (forward-line)
+ t)
+ (not (and (looking-at "\\* \\(OK\\|PREAUTH\\|BYE\\) ")
+ ;; success in imtest 1.6:
+ (re-search-forward
+ (concat "^\\(\\(Authenticat.*\\)\\|\\("
+ "Client authentication "
+ "finished.*\\)\\)")
+ nil t)
+ (setq response (match-string 1)))))
+ (accept-process-output process 1)
+ (sit-for 1))
+ (erase-buffer)
+ (message "GSSAPI connection: %s" (or response "failed"))
+ (if (and response (let ((case-fold-search nil))
+ (not (string-match "failed" response))))
+ (setq done process)
+ (delete-process process)
+ nil))))
+ done)))
+
+(provide 'gssapi)
+
+;;; gssapi.el ends here
diff --git a/lisp/gnus/html2text.el b/lisp/gnus/html2text.el
index 17379ff33a7..0635ab0afc6 100644
--- a/lisp/gnus/html2text.el
+++ b/lisp/gnus/html2text.el
@@ -1,6 +1,6 @@
;;; html2text.el --- a simple html to plain text converter
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Joakim Hove <hove@phys.ntnu.no>
@@ -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 e1ee3b123bd..4d99cea7608 100644
--- a/lisp/gnus/ietf-drums.el
+++ b/lisp/gnus/ietf-drums.el
@@ -1,7 +1,6 @@
;;; ietf-drums.el --- Functions for parsing RFC822bis headers
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; This file is part of GNU Emacs.
@@ -39,7 +38,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 +294,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 268c03bbe89..6c6d119c0c5 100644
--- a/lisp/gnus/legacy-gnus-agent.el
+++ b/lisp/gnus/legacy-gnus-agent.el
@@ -1,6 +1,6 @@
;;; gnus-agent.el --- Legacy unplugged support for Gnus
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: Kevin Greiner <kgreiner@xpediantsolutions.com>
;; Keywords: news
@@ -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 c3808a81072..06aac776486 100644
--- a/lisp/gnus/mail-parse.el
+++ b/lisp/gnus/mail-parse.el
@@ -1,7 +1,6 @@
;;; mail-parse.el --- Interface functions for parsing mail
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; This file is part of GNU Emacs.
@@ -45,8 +44,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 +72,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 1a0cbe1acc3..b87656dab4d 100644
--- a/lisp/gnus/mail-prsvr.el
+++ b/lisp/gnus/mail-prsvr.el
@@ -1,7 +1,6 @@
;;; mail-prsvr.el --- Interface variables for parsing mail
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; This file is part of GNU Emacs.
@@ -41,5 +40,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 dd7cd5cfe63..6e6ef76c0c1 100644
--- a/lisp/gnus/mail-source.el
+++ b/lisp/gnus/mail-source.el
@@ -1,7 +1,6 @@
;;; mail-source.el --- functions for fetching mail
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news, mail
@@ -25,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))))
@@ -33,7 +32,7 @@
(eval-when-compile
(require 'cl)
(require 'imap))
-(autoload 'auth-source-user-or-password "auth-source")
+(autoload 'auth-source-search "auth-source")
(autoload 'pop3-movemail "pop3")
(autoload 'pop3-get-message-count "pop3")
(autoload 'nnheader-cancel-timer "nnheader")
@@ -219,34 +218,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
@@ -361,6 +332,7 @@ Common keywords should be listed here.")
(:prescript)
(:prescript-delay)
(:postscript)
+ ;; note server and port need to come before user and password
(:server (getenv "MAILHOST"))
(:port 110)
(:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
@@ -374,6 +346,7 @@ Common keywords should be listed here.")
(:subdirs ("cur" "new"))
(:function))
(imap
+ ;; note server and port need to come before user and password
(:server (getenv "MAILHOST"))
(:port)
(:stream)
@@ -387,13 +360,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 +369,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)
@@ -453,42 +419,66 @@ the `mail-source-keyword-map' variable."
(put 'mail-source-bind 'lisp-indent-function 1)
(put 'mail-source-bind 'edebug-form-spec '(sexp body))
-;; TODO: use the list format for auth-source-user-or-password modes
(defun mail-source-set-1 (source)
(let* ((type (pop source))
- (defaults (cdr (assq type mail-source-keyword-map)))
- default value keyword auth-info user-auth pass-auth)
+ (defaults (cdr (assq type mail-source-keyword-map)))
+ (search '(:max 1))
+ found default value keyword auth-info user-auth pass-auth)
+
+ ;; append to the search the useful info from the source and the defaults:
+ ;; user, host, and port
+
+ ;; the msname is the mail-source parameter
+ (dolist (msname '(:server :user :port))
+ ;; the asname is the auth-source parameter
+ (let* ((asname (case msname
+ (:server :host) ; auth-source uses :host
+ (t msname)))
+ ;; this is the mail-source default
+ (msdef1 (or (plist-get source msname)
+ (nth 1 (assoc msname defaults))))
+ ;; ...evaluated
+ (msdef (mail-source-value msdef1)))
+ (setq search (append (list asname
+ (if msdef msdef t))
+ search))))
+ ;; if the port is unknown yet, get it from the mail-source type
+ (unless (plist-get search :port)
+ (setq search (append (list :port (symbol-name type)))))
+
(while (setq default (pop defaults))
;; for each default :SYMBOL, set SYMBOL to the plist value for :SYMBOL
;; using `mail-source-value' to evaluate the plist value
(set (mail-source-strip-keyword (setq keyword (car default)))
- ;; note the following reasons for this structure:
- ;; 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
- ((and
- (eq keyword :user)
- (setq user-auth
- (nth 0 (auth-source-user-or-password
- '("login" "password")
- ;; this is "host" in auth-sources
- (if (boundp 'server) (symbol-value 'server) "")
- type))))
- user-auth)
- ((and
- (eq keyword :password)
- (setq pass-auth
- (nth 1
- (auth-source-user-or-password
- '("login" "password")
- ;; this is "host" in auth-sources
- (if (boundp 'server) (symbol-value 'server) "")
- type))))
- pass-auth)
- (t (if (setq value (plist-get source keyword))
- (mail-source-value value)
- (mail-source-value (cadr default)))))))))
+ ;; note the following reasons for this structure:
+ ;; 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
+ ((and
+ (eq keyword :user)
+ (setq user-auth (plist-get
+ ;; cache the search result in `found'
+ (or found
+ (setq found (nth 0 (apply 'auth-source-search
+ search))))
+ :user)))
+ user-auth)
+ ((and
+ (eq keyword :password)
+ (setq pass-auth (plist-get
+ ;; cache the search result in `found'
+ (or found
+ (setq found (nth 0 (apply 'auth-source-search
+ search))))
+ :secret)))
+ ;; maybe set the password to the return of the :secret function
+ (if (functionp pass-auth)
+ (setq pass-auth (funcall pass-auth))
+ pass-auth))
+ (t (if (setq value (plist-get source keyword))
+ (mail-source-value value)
+ (mail-source-value (cadr default)))))))))
(eval-and-compile
(defun mail-source-bind-common-1 ()
@@ -536,7 +526,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 +536,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 +576,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 +621,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 +640,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 +987,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 +1132,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 12fbea78357..dffb279daba 100644
--- a/lisp/gnus/mailcap.el
+++ b/lisp/gnus/mailcap.el
@@ -1,7 +1,6 @@
;;; mailcap.el --- MIME media types configuration
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: William M. Perry <wmperry@aventail.com>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -335,7 +334,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 +422,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 +811,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 +830,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 +872,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")
@@ -905,7 +909,8 @@ If NO-DECODE is non-nil, don't decode STRING."
(".zip" . "application/zip")
(".ai" . "application/postscript")
(".jpe" . "image/jpeg")
- (".jpeg" . "image/jpeg"))
+ (".jpeg" . "image/jpeg")
+ (".org" . "text/x-org"))
"An alist of file extensions and corresponding MIME content-types.
This exists for you to customize the information in Lisp. It is
merged with values from mailcap files by `mailcap-parse-mimetypes'.")
@@ -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 63fcf500189..0971aed0e02 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -1,7 +1,6 @@
;;; message.el --- composing mail and news messages
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: mail, news
@@ -29,16 +28,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 +49,7 @@
(require 'mail-parse)
(require 'mml)
(require 'rfc822)
-(require 'ecomplete)
+(require 'format-spec)
(autoload 'mailclient-send-it "mailclient") ;; Emacs 22 or contrib/
@@ -160,9 +161,7 @@ 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.
+ "Specifies how \"From\" headers look.
If nil, they contain just the return address like:
king@grassland.com
@@ -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
@@ -269,14 +277,14 @@ included. Organization and User-Agent are optional."
regexp))
(defcustom message-ignored-mail-headers
- "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:\\|^X-Draft-From:\\|^X-Gnus-Agent-Meta-Information:"
+ "^\\([GF]cc\\|Resent-Fcc\\|Xref\\|X-Draft-From\\|X-Gnus-Agent-Meta-Information\\):"
"*Regexp of headers to be removed unconditionally before mailing."
:group 'message-mail
:group 'message-headers
: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
@@ -431,14 +439,15 @@ whitespace)."
:group 'message-various)
(defcustom message-elide-ellipsis "\n[...]\n\n"
- "*The string which is inserted for elided text."
+ "*The string which is inserted for elided text.
+This is a format-spec string, and you can use %l to say how many
+lines were removed, and %c to say how many characters were
+removed."
:type 'string
:link '(custom-manual "(message)Various Commands")
: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 +464,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 +487,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)
@@ -500,14 +510,9 @@ This is used by `message-kill-buffer'."
:group 'message-buffers
:type 'boolean)
-(defvar gnus-local-organization)
(defcustom message-user-organization
- (or (and (boundp 'gnus-local-organization)
- (stringp gnus-local-organization)
- gnus-local-organization)
- (getenv "ORGANIZATION")
- t)
- "*String to be used as an Organization header.
+ (or (getenv "ORGANIZATION") t)
+ "String to be used as an Organization header.
If t, use `message-user-organization-file'."
:group 'message-headers
:type '(choice string
@@ -615,30 +620,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 +639,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 +647,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 +814,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
@@ -894,11 +873,7 @@ variable isn't used."
;; create a dependence to `gnus.el'.
:type 'sexp)
-;; FIXME: This should be a temporary workaround until someone implements a
-;; proper solution. If a crash happens while replying, the auto-save file
-;; will *not* have a `References:' header if `message-generate-headers-first'
-;; is nil. See: http://article.gmane.org/gmane.emacs.gnus.general/51138
-(defcustom message-generate-headers-first '(references)
+(defcustom message-generate-headers-first nil
"Which headers should be generated before starting to compose a message.
If t, generate all required headers. This can also be a list of headers to
generate. The variables `message-required-news-headers' and
@@ -910,7 +885,6 @@ will not have a visible effect for those headers."
:group 'message-headers
:link '(custom-manual "(message)Message Headers")
:type '(choice (const :tag "None" nil)
- (const :tag "References" '(references))
(const :tag "All" t)
(repeat (sexp :tag "Header"))))
@@ -1013,10 +987,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 +1013,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 +1044,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 +1053,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.
@@ -1120,6 +1081,71 @@ needed."
:link '(custom-manual "(message)Insertion Variables")
:group 'message-insertion)
+(defcustom message-cite-reply-position 'traditional
+ "*Where the reply should be positioned.
+If `traditional', reply inline.
+If `above', reply above quoted text.
+If `below', reply below quoted text.
+
+Note: Many newsgroups frown upon nontraditional reply styles. You
+probably want to set this variable only for specific groups,
+e.g. using `gnus-posting-styles':
+
+ (eval (set (make-local-variable 'message-cite-reply-above) 'above))"
+ :type '(choice (const :tag "Reply inline" 'traditional)
+ (const :tag "Reply above" 'above)
+ (const :tag "Reply below" 'below))
+ :group 'message-insertion)
+
+(defcustom message-cite-style nil
+ "*The overall style to be used when yanking cited text.
+Value is either `nil' (no variable overrides) or a let-style list
+of pairs (VARIABLE VALUE) that will be bound in
+`message-yank-original' to do the quoting.
+
+Presets to impersonate popular mail agents are found in the
+message-cite-style-* variables. This variable is intended for
+use in `gnus-posting-styles', such as:
+
+ ((posting-from-work-p) (eval (set (make-local-variable 'message-cite-style) message-cite-style-outlook)))"
+ :version "24.1"
+ :group 'message-insertion
+ :type '(choice (const :tag "Do not override variables" :value nil)
+ (const :tag "MS Outlook" :value message-cite-style-outlook)
+ (const :tag "Mozilla Thunderbird" :value message-cite-style-thunderbird)
+ (const :tag "Gmail" :value message-cite-style-gmail)
+ (variable :tag "User-specified")))
+
+(defconst message-cite-style-outlook
+ '((message-cite-function 'message-cite-original)
+ (message-citation-line-function 'message-insert-formatted-citation-line)
+ (message-cite-reply-position 'above)
+ (message-yank-prefix "")
+ (message-yank-cited-prefix "")
+ (message-yank-empty-prefix "")
+ (message-citation-line-format "\n\n-----------------------\nOn %a, %b %d %Y, %N wrote:\n"))
+ "Message citation style used by MS Outlook. Use with message-cite-style.")
+
+(defconst message-cite-style-thunderbird
+ '((message-cite-function 'message-cite-original)
+ (message-citation-line-function 'message-insert-formatted-citation-line)
+ (message-cite-reply-position 'above)
+ (message-yank-prefix "> ")
+ (message-yank-cited-prefix ">")
+ (message-yank-empty-prefix ">")
+ (message-citation-line-format "On %D %R %p, %N wrote:"))
+ "Message citation style used by Mozilla Thunderbird. Use with message-cite-style.")
+
+(defconst message-cite-style-gmail
+ '((message-cite-function 'message-cite-original)
+ (message-citation-line-function 'message-insert-formatted-citation-line)
+ (message-cite-reply-position 'above)
+ (message-yank-prefix " ")
+ (message-yank-cited-prefix " ")
+ (message-yank-empty-prefix " ")
+ (message-citation-line-format "On %e %B %Y %R, %f wrote:\n"))
+ "Message citation style used by Gmail. Use with message-cite-style.")
+
(defcustom message-distribution-function nil
"*Function called to return a Distribution header."
:group 'message-news
@@ -1157,6 +1183,8 @@ It is a vector of the following headers:
(defvar message-checksum nil)
(defvar message-send-actions nil
"A list of actions to be performed upon successful sending of a message.")
+(defvar message-return-action nil
+ "Action to return to the caller after sending or postphoning a message.")
(defvar message-exit-actions nil
"A list of actions to be performed upon exiting after sending a message.")
(defvar message-kill-actions nil
@@ -1171,13 +1199,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 +1223,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."
@@ -1215,14 +1247,11 @@ these lines."
(if (and (string-match "sparc-sun-sunos\\(\\'\\|[^5]\\)"
system-configuration)
(file-readable-p "/etc/sendmail.cf")
- (let ((buffer (get-buffer-create " *temp*")))
- (unwind-protect
- (with-current-buffer buffer
- (insert-file-contents "/etc/sendmail.cf")
- (goto-char (point-min))
- (let ((case-fold-search nil))
- (re-search-forward "^OR\\>" nil t)))
- (kill-buffer buffer))))
+ (with-temp-buffer
+ (insert-file-contents "/etc/sendmail.cf")
+ (goto-char (point-min))
+ (let ((case-fold-search nil))
+ (re-search-forward "^OR\\>" nil t))))
;; According to RFC822, "The field-name must be composed of printable
;; ASCII characters (i. e., characters that have decimal values between
;; 33 and 126, except colon)", i. e., any chars except ctl chars,
@@ -1280,7 +1309,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 +1652,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 +1748,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 +1772,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)
@@ -1841,11 +1872,17 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'."
(defvar message-options nil
"Some saved answers when sending message.")
+;; FIXME: On XEmacs this causes problems since let-binding like:
+;; (let ((message-options message-options)) ...)
+;; as in `message-send' and `mml-preview' loses to buffer-local
+;; variable initialization.
+(unless (featurep 'xemacs)
+ (make-variable-buffer-local 'message-options))
(defvar message-send-mail-real-function nil
"Internal send mail function.")
-(defvar message-bogus-system-names "^localhost\\.\\|\\.local$"
+(defvar message-bogus-system-names "\\`localhost\\.\\|\\.local\\'"
"The regexp of bogus system names.")
(defcustom message-valid-fqdn-regexp
@@ -1956,6 +1993,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 +2219,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 +2706,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))
@@ -2802,7 +2839,7 @@ message composition doesn't break too bad."
:link '(custom-manual "(message)Various Message Variables")
:type 'boolean)
-(defconst message-forbidden-properties
+(defvar message-forbidden-properties
;; No reason this should be clutter up customize. We make it a
;; property list (rather than a list of property symbols), to be
;; directly useful for `remove-text-properties'.
@@ -2849,6 +2886,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.
@@ -2892,6 +2931,7 @@ M-RET `message-newline-and-reformat' (break the line and reformat)."
(set (make-local-variable 'message-reply-buffer) nil)
(set (make-local-variable 'message-inserted-headers) nil)
(set (make-local-variable 'message-send-actions) nil)
+ (set (make-local-variable 'message-return-action) nil)
(set (make-local-variable 'message-exit-actions) nil)
(set (make-local-variable 'message-kill-actions) nil)
(set (make-local-variable 'message-postpone-actions) nil)
@@ -2943,6 +2983,7 @@ M-RET `message-newline-and-reformat' (break the line and reformat)."
(mail-aliases-setup))))
((message-mail-alias-type-p 'ecomplete)
(ecomplete-setup)))
+ (add-hook 'completion-at-point-functions 'message-completion-function nil t)
(unless buffer-file-name
(message-set-auto-save-file-name))
(unless (buffer-base-buffer)
@@ -3071,10 +3112,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 +3136,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 +3461,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
@@ -3486,8 +3539,12 @@ Note that this should not be used in newsgroups."
An ellipsis (from `message-elide-ellipsis') will be inserted where the
text was killed."
(interactive "r")
- (kill-region b e)
- (insert message-elide-ellipsis))
+ (let ((lines (count-lines b e))
+ (chars (- e b)))
+ (kill-region b e)
+ (insert (format-spec message-elide-ellipsis
+ `((?l . ,lines)
+ (?c . ,chars))))))
(defvar message-caesar-translation-table nil)
@@ -3655,16 +3712,49 @@ To use this automatically, you may add this function to
(while (re-search-forward citexp nil t)
(replace-match (if remove "" "\n"))))))
-(defvar message-cite-reply-above nil
- "If non-nil, start own text above the quote.
-
-Note: Top posting is bad netiquette. Don't use it unless you
-really must. You probably want to set variable only for specific
-groups, e.g. using `gnus-posting-styles':
-
- (eval (set (make-local-variable 'message-cite-reply-above) t))
-
-This variable has no effect in news postings.")
+(defun message--yank-original-internal (arg)
+ (let ((modified (buffer-modified-p))
+ body-text)
+ (when (and message-reply-buffer
+ message-cite-function)
+ (when (equal message-cite-reply-position 'above)
+ (save-excursion
+ (setq body-text
+ (buffer-substring (message-goto-body)
+ (point-max)))
+ (delete-region (message-goto-body) (point-max))))
+ (if (bufferp message-reply-buffer)
+ (delete-windows-on message-reply-buffer t))
+ (push-mark (save-excursion
+ (cond
+ ((bufferp message-reply-buffer)
+ (insert-buffer-substring message-reply-buffer))
+ ((and (consp message-reply-buffer)
+ (functionp (car message-reply-buffer)))
+ (apply (car message-reply-buffer)
+ (cdr message-reply-buffer))))
+ (unless (bolp)
+ (insert ?\n))
+ (point)))
+ (unless arg
+ (funcall message-cite-function)
+ (unless (eq (char-before (mark t)) ?\n)
+ (let ((pt (point)))
+ (goto-char (mark t))
+ (insert-before-markers ?\n)
+ (goto-char pt))))
+ (case message-cite-reply-position
+ (above
+ (message-goto-body)
+ (insert body-text)
+ (insert (if (bolp) "\n" "\n\n"))
+ (message-goto-body))
+ (below
+ (message-goto-signature)))
+ ;; Add a `message-setup-very-last-hook' here?
+ ;; Add `gnus-article-highlight-citation' here?
+ (unless modified
+ (setq message-checksum (message-checksum))))))
(defun message-yank-original (&optional arg)
"Insert the message being replied to, if any.
@@ -3677,51 +3767,10 @@ This function uses `message-cite-function' to do the actual citing.
Just \\[universal-argument] as argument means don't indent, insert no
prefix, and don't delete any headers."
(interactive "P")
- (let ((modified (buffer-modified-p))
- body-text)
- (when (and message-reply-buffer
- message-cite-function)
- (when message-cite-reply-above
- (if (and (not (message-news-p))
- (or (eq message-cite-reply-above 'is-evil)
- (y-or-n-p "\
-Top posting is bad netiquette. Please don't top post unless you really must.
-Really top post? ")))
- (save-excursion
- (setq body-text
- (buffer-substring (message-goto-body)
- (point-max)))
- (delete-region (message-goto-body) (point-max)))
- (set (make-local-variable 'message-cite-reply-above) nil)))
- (if (bufferp message-reply-buffer)
- (delete-windows-on message-reply-buffer t))
- (push-mark (save-excursion
- (cond
- ((bufferp message-reply-buffer)
- (insert-buffer-substring message-reply-buffer))
- ((and (consp message-reply-buffer)
- (functionp (car message-reply-buffer)))
- (apply (car message-reply-buffer)
- (cdr message-reply-buffer))))
- (unless (bolp)
- (insert ?\n))
- (point)))
- (unless arg
- (funcall message-cite-function)
- (unless (eq (char-before (mark t)) ?\n)
- (let ((pt (point)))
- (goto-char (mark t))
- (insert-before-markers ?\n)
- (goto-char pt))))
- (when message-cite-reply-above
- (message-goto-body)
- (insert body-text)
- (insert (if (bolp) "\n" "\n\n"))
- (message-goto-body))
- ;; Add a `message-setup-very-last-hook' here?
- ;; Add `gnus-article-highlight-citation' here?
- (unless modified
- (setq message-checksum (message-checksum))))))
+ ;; eval the let forms contained in message-cite-style
+ (eval
+ `(let ,message-cite-style
+ (message--yank-original-internal ',arg))))
(defun message-yank-buffer (buffer)
"Insert BUFFER into the current buffer and quote it."
@@ -3971,11 +4020,9 @@ The text will also be indented the normal way."
(actions message-exit-actions))
(when (and (message-send arg)
(buffer-name buf))
+ (message-bury buf)
(if message-kill-buffer-on-exit
- (kill-buffer buf)
- (bury-buffer buf)
- (when (eq buf (current-buffer))
- (message-bury buf)))
+ (kill-buffer buf))
(message-do-actions actions)
t)))
@@ -4023,32 +4070,11 @@ Instead, just auto-save the buffer and then bury it."
(defun message-bury (buffer)
"Bury this mail BUFFER."
- (let ((newbuf (other-buffer (current-buffer))))
- (bury-buffer (current-buffer))
- (if (and (window-dedicated-p (frame-selected-window))
- (not (null (delq (selected-frame) (visible-frame-list)))))
- (delete-frame (selected-frame))
- ;; Temporary hack to make this behave like `mail-bury', when
- ;; used with Rmail. Replaced in Emacs 24 with
- (let (rmail-flag summary-buffer)
- (and (not (one-window-p))
- (with-current-buffer
- (window-buffer (next-window (selected-window) 'not))
- (setq rmail-flag (eq major-mode 'rmail-mode))
- (setq summary-buffer
- (and (if (boundp 'mail-bury-selects-summary)
- mail-bury-selects-summary
- t)
- (boundp 'rmail-summary-buffer)
- rmail-summary-buffer
- (buffer-name rmail-summary-buffer)
- (not (get-buffer-window rmail-summary-buffer))
- rmail-summary-buffer))))
- (if rmail-flag
- ;; If the Rmail buffer has a summary, show that.
- (if summary-buffer (switch-to-buffer summary-buffer)
- (delete-window))
- (switch-to-buffer newbuf))))))
+ (if message-return-action
+ (progn
+ (bury-buffer buffer)
+ (apply (car message-return-action) (cdr message-return-action)))
+ (with-current-buffer buffer (bury-buffer))))
(defun message-send (&optional arg)
"Send the message in the current buffer.
@@ -4110,7 +4136,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)
@@ -4166,7 +4193,6 @@ not have PROP."
(nreverse regions)))
(defcustom message-bogus-addresses
- ;; '("noreply" "nospam" "invalid")
'("noreply" "nospam" "invalid" "@@" "[^[:ascii:]].*@" "[ \t]")
"List of regexps of potentially bogus mail addresses.
See `message-check-recipients' how to setup checking.
@@ -4252,7 +4278,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"))
@@ -4296,9 +4322,10 @@ matching entry in `message-bogus-addresses'."
;; FIXME: How about "foo@subdomain", when the MTA adds ".domain.tld"?
(let (found)
(mapc (lambda (address)
- (setq address (cadr address))
+ (setq address (or (cadr address) ""))
(when
- (or (not
+ (or (string= "" address)
+ (not
(or
(not (string-match "@" address))
(string-match
@@ -4312,7 +4339,7 @@ matching entry in `message-bogus-addresses'."
"\\|")
message-bogus-addresses)))
(string-match re address))))
- (push address found)))
+ (push address found)))
;;
(mail-extract-address-components recipients t))
found))
@@ -4331,7 +4358,17 @@ This function could be useful in `message-setup-hook'."
(and bog
(not (y-or-n-p
(format
- "Address `%s' might be bogus. Continue? " bog)))
+ "Address `%s'%s might be bogus. Continue? "
+ bog
+ ;; If the encoded version of the email address
+ ;; is different from the unencoded version,
+ ;; then we likely have invisible characters or
+ ;; the like. Display the encoded version,
+ ;; too.
+ (let ((encoded (rfc2047-encode-string bog)))
+ (if (string= encoded bog)
+ ""
+ (format " (%s)" encoded))))))
(error "Bogus address"))))))))
(custom-add-option 'message-setup-hook 'message-check-recipients)
@@ -4374,7 +4411,7 @@ This function could be useful in `message-setup-hook'."
(tembuf (message-generate-new-buffer-clone-locals " message temp"))
(curbuf (current-buffer))
(id (message-make-message-id)) (n 1)
- plist total header required-mail-headers)
+ plist total header)
(while (not (eobp))
(if (< (point-max) (+ p message-send-mail-partially-limit))
(goto-char (point-max))
@@ -4432,6 +4469,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"))
@@ -4439,14 +4478,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
@@ -4511,6 +4562,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"))
@@ -4527,7 +4580,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))
@@ -4568,6 +4623,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")
@@ -4687,6 +4743,8 @@ to find out how to use this."
;; should never happen
(t (error "qmail-inject reported unknown failure"))))
+(defvar mh-previous-window-config)
+
(defun message-send-mail-with-mh ()
"Send the prepared message buffer with mh."
(let ((mh-previous-window-config nil)
@@ -4731,10 +4789,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))
@@ -4745,7 +4807,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)
@@ -4898,8 +4965,7 @@ Otherwise, generate and save a value for `canlock-password' first."
t))
;; Check long header lines.
(message-check 'long-header-lines
- (let ((start (point))
- (header nil)
+ (let ((header nil)
(length 0)
found)
(while (and (not found)
@@ -4908,7 +4974,6 @@ Otherwise, generate and save a value for `canlock-password' first."
(setq found t
length (- (point) (match-beginning 0)))
(setq header (match-string-no-properties 1)))
- (setq start (match-beginning 0))
(forward-line 1))
(if found
(y-or-n-p (format "Your %s header is too long (%d). Really post? "
@@ -5432,7 +5497,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))))
@@ -5490,7 +5555,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 " ")
@@ -5502,7 +5567,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
@@ -5751,14 +5816,16 @@ subscribed address (and not the additional To and Cc header contents)."
(defun message-idna-to-ascii-rhs-1 (header)
"Interactively potentially IDNA encode domain names in HEADER."
(let ((field (message-fetch-field header))
- rhs ace address)
+ ace)
(when field
(dolist (rhs
(mm-delete-duplicates
(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.
@@ -5798,6 +5865,21 @@ See `message-idna-encode'."
(message-idna-to-ascii-rhs-1 "Mail-Followup-To")
(message-idna-to-ascii-rhs-1 "Cc")))))
+(defvar Date)
+(defvar Message-ID)
+(defvar Organization)
+(defvar From)
+(defvar Path)
+(defvar Subject)
+(defvar Newsgroups)
+(defvar In-Reply-To)
+(defvar References)
+(defvar To)
+(defvar Distribution)
+(defvar Lines)
+(defvar User-Agent)
+(defvar Expires)
+
(defun message-generate-headers (headers)
"Prepare article HEADERS.
Headers already prepared in the buffer are not modified."
@@ -5956,7 +6038,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
@@ -5966,12 +6048,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
@@ -6071,6 +6153,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)
@@ -6307,11 +6390,11 @@ between beginning of field and beginning of line."
;; YANK-ACTION, if non-nil, can be a buffer or a yank action of the
;; form (FUNCTION . ARGS).
(defun message-setup (headers &optional yank-action actions
- continue switch-function)
+ continue switch-function return-action)
(let ((mua (message-mail-user-agent))
subject to field)
(if (not (and message-this-is-mail mua))
- (message-setup-1 headers yank-action actions)
+ (message-setup-1 headers yank-action actions return-action)
(setq headers (copy-sequence headers))
(setq field (assq 'Subject headers))
(when field
@@ -6359,11 +6442,12 @@ are not included."
(push header result)))
(nreverse result)))
-(defun message-setup-1 (headers &optional yank-action actions)
+(defun message-setup-1 (headers &optional yank-action actions return-action)
(dolist (action actions)
(condition-case nil
(add-to-list 'message-send-actions
`(apply ',(car action) ',(cdr action)))))
+ (setq message-return-action return-action)
(setq message-reply-buffer
(if (and (consp yank-action)
(eq (car yank-action) 'insert-buffer))
@@ -6382,32 +6466,40 @@ 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")
+ (insert (concat mail-header-separator "\n"))
(forward-line -1)
- (when (message-news-p)
- (when message-default-news-headers
- (insert message-default-news-headers)
- (or (bolp) (insert ?\n)))
- (when message-generate-headers-first
+ ;; If a crash happens while replying, the auto-save file would *not* have a
+ ;; `References:' header if `message-generate-headers-first' was nil.
+ ;; Therefore, always generate it first.
+ (let ((message-generate-headers-first
+ (if (eq message-generate-headers-first t)
+ t
+ (append message-generate-headers-first '(References)))))
+ (when (message-news-p)
+ (when message-default-news-headers
+ (insert message-default-news-headers)
+ (or (bolp) (insert ?\n)))
(message-generate-headers
(message-headers-to-generate
- (append message-required-news-headers
- message-required-headers)
- message-generate-headers-first
- '(Lines Subject)))))
- (when (message-mail-p)
- (when message-default-mail-headers
- (insert message-default-mail-headers)
- (or (bolp) (insert ?\n)))
- (when message-generate-headers-first
+ (append message-required-news-headers
+ message-required-headers)
+ message-generate-headers-first
+ '(Lines Subject))))
+ (when (message-mail-p)
+ (when message-default-mail-headers
+ (insert message-default-mail-headers)
+ (or (bolp) (insert ?\n)))
(message-generate-headers
(message-headers-to-generate
- (append message-required-mail-headers
- message-required-headers)
- message-generate-headers-first
- '(Lines Subject)))))
+ (append message-required-mail-headers
+ message-required-headers)
+ message-generate-headers-first
+ '(Lines Subject)))))
(run-hooks 'message-signature-setup-hook)
(message-insert-signature)
(save-restriction
@@ -6450,9 +6542,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"))
@@ -6491,9 +6581,9 @@ are not included."
;;;
;;;###autoload
-(defun message-mail (&optional to subject
- other-headers continue switch-function
- yank-action send-actions)
+(defun message-mail (&optional to subject other-headers continue
+ switch-function yank-action send-actions
+ return-action &rest ignored)
"Start editing a mail message to be sent.
OTHER-HEADERS is an alist of header/value pairs. CONTINUE says whether
to continue editing a message already being composed. SWITCH-FUNCTION
@@ -6520,9 +6610,8 @@ is a function used to switch to and display the mail buffer."
;; We need to convert any string input, eg from rmail-start-mail.
(dolist (h other-headers other-headers)
(if (stringp (car h)) (setcar h (intern (capitalize (car h)))))))
- yank-action send-actions continue switch-function)
- ;; FIXME: Should return nil if failure.
- t))
+ yank-action send-actions continue switch-function
+ return-action)))
;;;###autoload
(defun message-news (&optional newsgroups subject)
@@ -6558,7 +6647,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
@@ -6595,6 +6684,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
@@ -6630,10 +6723,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)))
@@ -6684,6 +6773,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)))))
@@ -6697,6 +6788,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
@@ -6731,12 +6838,12 @@ Useful functions to put in this list include:
subject)
;;;###autoload
-(defun message-reply (&optional to-address wide)
+(defun message-reply (&optional to-address wide switch-function)
"Start editing a reply to the article in the current buffer."
(interactive)
(require 'gnus-sum) ; for gnus-list-identifiers
(let ((cur (current-buffer))
- from subject date reply-to to cc
+ from subject date
references message-id follow-to
(inhibit-point-motion-hooks t)
(message-this-is-mail t)
@@ -6774,7 +6881,8 @@ Useful functions to put in this list include:
(message-pop-to-buffer
(message-buffer-name
(if wide "wide reply" "reply") from
- (if wide to-address nil))))
+ (if wide to-address nil))
+ switch-function))
(setq message-reply-headers
(vector 0 subject from date message-id references 0 0 ""))
@@ -7168,22 +7276,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)
@@ -7219,18 +7333,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)
@@ -7247,11 +7365,9 @@ Optional DIGEST will use digest to forward."
(defun message-forward-make-body-digest-plain (forward-buffer)
(insert
"\n-------------------- Start of forwarded message --------------------\n")
- (let ((b (point)) e)
- (mml-insert-buffer forward-buffer)
- (setq e (point))
- (insert
- "\n-------------------- End of forwarded message --------------------\n")))
+ (mml-insert-buffer forward-buffer)
+ (insert
+ "\n-------------------- End of forwarded message --------------------\n"))
(defun message-forward-make-body-digest-mime (forward-buffer)
(insert "\n<#multipart type=digest>\n")
@@ -7371,6 +7487,8 @@ is for the internal use."
(setq rmail-insert-mime-forwarded-message-function
'message-forward-rmail-make-body))
+(defvar message-inhibit-body-encoding nil)
+
;;;###autoload
(defun message-resend (address)
"Resend the current article to ADDRESS."
@@ -7383,7 +7501,8 @@ is for the internal use."
;; We first set up a normal mail buffer.
(unless (message-mail-user-agent)
(set-buffer (get-buffer-create " *message resend*"))
- (erase-buffer))
+ (let ((inhibit-read-only t))
+ (erase-buffer)))
(let ((message-this-is-mail t)
message-generate-hashcash
message-setup-hook)
@@ -7400,7 +7519,8 @@ is for the internal use."
(insert "Resent-"))
(widen)
(forward-line)
- (delete-region (point) (point-max))
+ (let ((inhibit-read-only t))
+ (delete-region (point) (point-max)))
(setq beg (point))
;; Insert the message to be resent.
(insert-buffer-substring cur)
@@ -7421,7 +7541,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)
@@ -7617,24 +7742,22 @@ Pre-defined symbols include `message-tool-bar-gnome' and
(defcustom message-tool-bar-gnome
'((ispell-message "spell" nil
+ :vert-only t
:visible (or (not (boundp 'flyspell-mode))
(not flyspell-mode)))
(flyspell-buffer "spell" t
+ :vert-only t
:visible (and (boundp 'flyspell-mode)
flyspell-mode)
:help "Flyspell whole buffer")
- (gmm-ignore "separator")
- (message-send-and-exit "mail/send")
+ (message-send-and-exit "mail/send" t :label "Send")
(message-dont-send "mail/save-draft")
- (message-kill-buffer "close") ;; stock_cancel
- (mml-attach-file "attach" mml-mode-map)
+ (mml-attach-file "attach" mml-mode-map :vert-only t)
(mml-preview "mail/preview" mml-mode-map)
(mml-secure-message-sign-encrypt "lock" mml-mode-map :visible nil)
(message-insert-importance-high "important" nil :visible nil)
(message-insert-importance-low "unimportant" nil :visible nil)
- (message-insert-disposition-notification-to "receipt" nil :visible nil)
- (gmm-customize-mode "preferences" t :help "Edit mode preferences")
- (message-info "help" t :help "Message manual"))
+ (message-insert-disposition-notification-to "receipt" nil :visible nil))
"List of items for the message tool bar (GNOME style).
See `gmm-tool-bar-from-list' for details on the format of the list."
@@ -7720,7 +7843,7 @@ When FORCE, rebuild the tool bar."
:type '(alist :key-type regexp :value-type function))
(defcustom message-expand-name-databases
- (list 'bbdb 'eudc)
+ '(bbdb eudc)
"List of databases to try for name completion (`message-expand-name').
Each element is a symbol and can be `bbdb' or `eudc'."
:group 'message
@@ -7742,15 +7865,27 @@ If nil, the function bound in `text-mode-map' or `global-map' is executed."
Execute function specified by `message-tab-body-function' when not in
those headers."
(interactive)
+ (cond
+ ((if (and (boundp 'completion-fail-discreetly)
+ (fboundp 'completion-at-point))
+ (let ((completion-fail-discreetly t)) (completion-at-point))
+ (funcall (or (message-completion-function) #'ignore)))
+ ;; Completion was performed; nothing else to do.
+ nil)
+ (message-tab-body-function (funcall message-tab-body-function))
+ (t (funcall (or (lookup-key text-mode-map "\t")
+ (lookup-key global-map "\t")
+ 'indent-relative)))))
+
+(defvar mail-abbrev-mode-regexp)
+
+(defun message-completion-function ()
(let ((alist message-completion-alist))
(while (and alist
(let ((mail-abbrev-mode-regexp (caar alist)))
(not (mail-abbrev-in-expansion-header-p))))
(setq alist (cdr alist)))
- (funcall (or (cdar alist) message-tab-body-function
- (lookup-key text-mode-map "\t")
- (lookup-key global-map "\t")
- 'indent-relative))))
+ (cdar alist)))
(eval-and-compile
(condition-case nil
@@ -7821,7 +7956,12 @@ those headers."
(eudc-expand-inline))
((and (memq 'bbdb message-expand-name-databases)
(fboundp 'bbdb-complete-name))
- (bbdb-complete-name))
+ (let ((starttick (buffer-modified-tick)))
+ (or (bbdb-complete-name)
+ ;; Apparently, bbdb-complete-name can return nil even when
+ ;; completion took place. So let's double check the buffer was
+ ;; not modified.
+ (/= starttick (buffer-modified-tick)))))
(t
(expand-abbrev))))
@@ -7882,8 +8022,6 @@ regexp VARSTR."
;;; MIME functions
;;;
-(defvar message-inhibit-body-encoding nil)
-
(defun message-encode-message-body ()
(unless message-inhibit-body-encoding
(let ((mail-parse-charset (or mail-parse-charset
@@ -8034,7 +8172,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))
@@ -8045,6 +8187,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))
diff --git a/lisp/gnus/messcompat.el b/lisp/gnus/messcompat.el
index a3ae50d96b5..c0c5125aeea 100644
--- a/lisp/gnus/messcompat.el
+++ b/lisp/gnus/messcompat.el
@@ -1,7 +1,6 @@
;;; messcompat.el --- making message mode compatible with mail mode
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: mail, news
@@ -89,5 +88,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 f4fff57fcc5..9952f410f0d 100644
--- a/lisp/gnus/mm-bodies.el
+++ b/lisp/gnus/mm-bodies.el
@@ -1,7 +1,6 @@
;;; mm-bodies.el --- Functions for decoding MIME things
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
@@ -24,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))))
@@ -302,5 +301,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 4775abe3647..f543920446b 100644
--- a/lisp/gnus/mm-decode.el
+++ b/lisp/gnus/mm-decode.el
@@ -1,7 +1,6 @@
;;; mm-decode.el --- Functions for decoding MIME things
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
@@ -24,17 +23,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 +104,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 +114,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 +123,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 +136,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
@@ -224,25 +223,21 @@ before the external MIME handler is invoked."
("text/plain" mm-inline-text identity)
("text/enriched" mm-inline-text identity)
("text/richtext" mm-inline-text identity)
- ("text/x-patch" mm-display-patch-inline
- (lambda (handle)
- ;; If the diff-mode.el package is installed, the function is
- ;; autoloaded. Checking (locate-library "diff-mode") would be trying
- ;; to cater to broken installations. OTOH checking the function
- ;; makes it possible to install another package which provides an
- ;; alternative implementation of diff-mode. --Stef
- (fboundp 'diff-mode)))
+ ("text/x-patch" mm-display-patch-inline identity)
;; In case mime.types uses x-diff (as does Debian's mime-support-3.40).
- ("text/x-diff" mm-display-patch-inline
- (lambda (handle) (fboundp 'diff-mode)))
+ ("text/x-diff" mm-display-patch-inline identity)
("application/emacs-lisp" mm-display-elisp-inline identity)
("application/x-emacs-lisp" mm-display-elisp-inline identity)
+ ("application/x-shellscript" mm-display-shell-script-inline identity)
+ ("application/x-sh" mm-display-shell-script-inline identity)
+ ("text/x-sh" mm-display-shell-script-inline identity)
+ ("application/javascript" mm-display-javascript-inline identity)
("text/dns" mm-display-dns-inline identity)
+ ("text/x-org" mm-display-org-inline identity)
("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)
@@ -314,7 +309,8 @@ when selecting a different article."
"application/pkcs7-signature" "application/x-pkcs7-mime"
"application/pkcs7-mime"
;; Mutt still uses this even though it has already been withdrawn.
- "application/pgp\\'")
+ "application/pgp\\'"
+ "text/x-org")
"A list of MIME types to be displayed automatically."
:type '(repeat regexp)
:group 'mime-display)
@@ -367,8 +363,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 +550,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 +621,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 +663,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 +690,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 +753,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 +1147,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 +1248,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 +1267,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 +1283,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 +1310,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)
@@ -1343,13 +1364,19 @@ text/\\(\\sw+\\)\\(?:\;\\s-*charset=\\(.+\\)\\)?[\"'][^>]*>" nil t)
(defun mm-preferred-alternative-precedence (handles)
"Return the precedence based on HANDLES and `mm-discouraged-alternatives'."
- (let ((seq (nreverse (mapcar #'mm-handle-media-type
- handles))))
- (dolist (disc (reverse mm-discouraged-alternatives))
- (dolist (elem (copy-sequence seq))
- (when (string-match disc elem)
- (setq seq (nconc (delete elem seq) (list elem))))))
- seq))
+ (setq handles (reverse handles))
+ (dolist (disc (reverse mm-discouraged-alternatives))
+ (dolist (handle (copy-sequence handles))
+ (when (string-match disc (mm-handle-media-type handle))
+ (setq handles (nconc (delete handle handles) (list handle))))))
+ ;; Remove empty parts.
+ (dolist (handle (copy-sequence handles))
+ (when (and (bufferp (mm-handle-buffer handle))
+ (not (with-current-buffer (mm-handle-buffer handle)
+ (goto-char (point-min))
+ (re-search-forward "[^ \t\n]" nil t))))
+ (setq handles (nconc (delete handle handles) (list handle)))))
+ (mapcar #'mm-handle-media-type handles))
(defun mm-get-content-id (id)
"Return the handle(s) referred to by ID."
@@ -1464,7 +1491,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 +1572,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 +1587,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 +1686,71 @@ 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 char)
+ (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
+ (insert (prog1
+ (if (and charset
+ (setq charset
+ (mm-charset-to-coding-system charset))
+ (not (eq charset 'ascii)))
+ (mm-decode-coding-string (buffer-string) charset)
+ (mm-string-as-multibyte (buffer-string)))
+ (erase-buffer)
+ (mm-enable-multibyte)))
+ (goto-char (point-min))
+ (setq case-fold-search t)
+ (while (re-search-forward
+ "&#\\(?:x\\([89][0-9a-f]\\)\\|\\(1[2-5][0-9]\\)\\);" nil t)
+ (when (setq char
+ (cdr (assq (if (match-beginning 1)
+ (string-to-number (match-string 1) 16)
+ (string-to-number (match-string 2)))
+ mm-extra-numeric-entities)))
+ (replace-match (char-to-string char))))
+ (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))))))))
+
+(defun mm-handle-filename (handle)
+ "Return filename of HANDLE if any."
+ (or (mail-content-type-get (mm-handle-type handle)
+ 'name)
+ (mail-content-type-get (mm-handle-disposition handle)
+ 'filename)))
+
(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 2c8e1e3a0a6..055ba475b8e 100644
--- a/lisp/gnus/mm-encode.el
+++ b/lisp/gnus/mm-encode.el
@@ -1,7 +1,6 @@
;;; mm-encode.el --- Functions for encoding MIME things
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
@@ -26,7 +25,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 +41,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 +215,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 3912a90806e..5f4a9a85fc6 100644
--- a/lisp/gnus/mm-extern.el
+++ b/lisp/gnus/mm-extern.el
@@ -1,7 +1,6 @@
;;; mm-extern.el --- showing message/external-body
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
;; Keywords: message external-body
@@ -25,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))))
@@ -67,9 +66,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)
@@ -92,7 +90,7 @@
(let (mm-extern-anonymous)
(mm-extern-anon-ftp handle)))
-(declare-function message-goto-body "message" (&optional interactivep))
+(declare-function message-goto-body "message" ())
(defun mm-extern-mail-server (handle)
(require 'message)
@@ -125,7 +123,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 +134,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 +166,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 148f7059d27..017b604e9bb 100644
--- a/lisp/gnus/mm-partial.el
+++ b/lisp/gnus/mm-partial.el
@@ -1,7 +1,6 @@
;;; mm-partial.el --- showing message/partial
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
;; Keywords: message partial
@@ -70,8 +69,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 +81,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 +147,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 c62d56494a8..2ce3791ef3d 100644
--- a/lisp/gnus/mm-url.el
+++ b/lisp/gnus/mm-url.el
@@ -1,7 +1,6 @@
;;; mm-url.el --- a wrapper of url functions/commands for Gnus
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
@@ -84,13 +83,6 @@ Likely values are `wget', `w3m', `lynx' and `curl'."
;;; Internal variables
-(defvar mm-url-package-name
- (gnus-replace-in-string
- (gnus-replace-in-string gnus-version " v.*$" "")
- " " "-"))
-
-(defvar mm-url-package-version gnus-version-number)
-
;; Stolen from w3.
(defvar mm-url-html-entities
'(
@@ -299,10 +291,6 @@ If `mm-url-use-external' is non-nil, use `mm-url-program'."
(if (not (and (boundp 'url-version)
(equal url-version "Emacs")))
(list (cons "Connection" "Close"))))
- (url-package-name (or mm-url-package-name
- url-package-name))
- (url-package-version (or mm-url-package-version
- url-package-version))
result)
(setq result (url-insert-file-contents url))
(save-excursion
@@ -365,15 +353,23 @@ 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
+ ;; 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)))))
+ (setq c (or (cdr (assq c mm-extra-numeric-entities))
+ (mm-ucs-to-char c)))
+ (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 +400,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 +414,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 +492,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 0f02d3cebb8..435c3bba00f 100644
--- a/lisp/gnus/mm-util.el
+++ b/lisp/gnus/mm-util.el
@@ -1,7 +1,6 @@
;;; mm-util.el --- Utility functions for Mule and low level things
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
@@ -24,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))))
@@ -39,6 +38,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 +71,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 +205,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
@@ -225,42 +219,43 @@ to the contents of the accessible portion of the buffer."
(t 'identity))))
;; `ucs-to-char' is a function that Mule-UCS provides.
-(if (featurep 'xemacs)
- (cond ((and (fboundp 'unicode-to-char) ;; XEmacs 21.5.
- (subrp (symbol-function 'unicode-to-char)))
- (if (featurep 'mule)
- (defalias 'mm-ucs-to-char 'unicode-to-char)
+(eval-and-compile
+ (if (featurep 'xemacs)
+ (cond ((and (fboundp 'unicode-to-char) ;; XEmacs 21.5.
+ (subrp (symbol-function 'unicode-to-char)))
+ (if (featurep 'mule)
+ (defalias 'mm-ucs-to-char 'unicode-to-char)
+ (defun mm-ucs-to-char (codepoint)
+ "Convert Unicode codepoint to character."
+ (or (unicode-to-char codepoint) ?#))))
+ ((featurep 'mule)
+ (defun mm-ucs-to-char (codepoint)
+ "Convert Unicode codepoint to character."
+ (if (fboundp 'ucs-to-char) ;; Mule-UCS is loaded.
+ (progn
+ (defalias 'mm-ucs-to-char
+ (lambda (codepoint)
+ "Convert Unicode codepoint to character."
+ (condition-case nil
+ (or (ucs-to-char codepoint) ?#)
+ (error ?#))))
+ (mm-ucs-to-char codepoint))
+ (condition-case nil
+ (or (int-to-char codepoint) ?#)
+ (error ?#)))))
+ (t
(defun mm-ucs-to-char (codepoint)
"Convert Unicode codepoint to character."
- (or (unicode-to-char codepoint) ?#))))
- ((featurep 'mule)
- (defun mm-ucs-to-char (codepoint)
- "Convert Unicode codepoint to character."
- (if (fboundp 'ucs-to-char) ;; Mule-UCS is loaded.
- (progn
- (defalias 'mm-ucs-to-char
- (lambda (codepoint)
- "Convert Unicode codepoint to character."
- (condition-case nil
- (or (ucs-to-char codepoint) ?#)
- (error ?#))))
- (mm-ucs-to-char codepoint))
(condition-case nil
(or (int-to-char codepoint) ?#)
(error ?#)))))
- (t
- (defun mm-ucs-to-char (codepoint)
- "Convert Unicode codepoint to character."
- (condition-case nil
- (or (int-to-char codepoint) ?#)
- (error ?#)))))
- (if (let ((char (make-char 'japanese-jisx0208 36 34)))
- (eq char (decode-char 'ucs char)))
- ;; Emacs 23.
- (defalias 'mm-ucs-to-char 'identity)
- (defun mm-ucs-to-char (codepoint)
- "Convert Unicode codepoint to character."
- (or (decode-char 'ucs codepoint) ?#))))
+ (if (let ((char (make-char 'japanese-jisx0208 36 34)))
+ (eq char (decode-char 'ucs char)))
+ ;; Emacs 23.
+ (defalias 'mm-ucs-to-char 'identity)
+ (defun mm-ucs-to-char (codepoint)
+ "Convert Unicode codepoint to character."
+ (or (decode-char 'ucs codepoint) ?#)))))
;; Fixme: This seems always to be used to read a MIME charset, so it
;; should be re-named and fixed (in Emacs) to offer completion only on
@@ -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))
@@ -868,6 +866,21 @@ variable is set, it overrides the default priority."
Setting it to nil is useful on Emacsen supporting Unicode if sending
mail with multiple parts is preferred to sending a Unicode one.")
+(defvar mm-extra-numeric-entities
+ (mapcar
+ (lambda (item)
+ (cons (car item) (mm-ucs-to-char (cdr item))))
+ '((#x80 . #x20AC) (#x82 . #x201A) (#x83 . #x0192) (#x84 . #x201E)
+ (#x85 . #x2026) (#x86 . #x2020) (#x87 . #x2021) (#x88 . #x02C6)
+ (#x89 . #x2030) (#x8A . #x0160) (#x8B . #x2039) (#x8C . #x0152)
+ (#x8E . #x017D) (#x91 . #x2018) (#x92 . #x2019) (#x93 . #x201C)
+ (#x94 . #x201D) (#x95 . #x2022) (#x96 . #x2013) (#x97 . #x2014)
+ (#x98 . #x02DC) (#x99 . #x2122) (#x9A . #x0161) (#x9B . #x203A)
+ (#x9C . #x0153) (#x9E . #x017E) (#x9F . #x0178)))
+ "*Alist of extra numeric entities and characters other than ISO 10646.
+This table is used for decoding extra numeric entities to characters,
+like \"&#128;\" to the euro sign, mainly in html messages.")
+
;;; Internal variables:
;;; Functions:
@@ -899,26 +912,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 +976,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
@@ -983,6 +989,7 @@ If the charset is `composition', return the actual one."
;; This is for XEmacs.
(mm-mule-charset-to-mime-charset charset)))
+;; `delete-dups' is not available in XEmacs 21.4.
(if (fboundp 'delete-dups)
(defalias 'mm-delete-duplicates 'delete-dups)
(defun mm-delete-duplicates (list)
@@ -1227,28 +1234,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 +1439,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 +1549,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 +1565,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,12 +1598,12 @@ 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))
- (prog1
+ (unwind-protect
(cond
((boundp 'set-auto-coding-function) ;; Emacs
(if filename
@@ -1661,5 +1669,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 7dbede08f6f..4f7b5ed26b3 100644
--- a/lisp/gnus/mm-uu.el
+++ b/lisp/gnus/mm-uu.el
@@ -1,7 +1,6 @@
;;; mm-uu.el --- Return uu stuff as mm handles
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
;; Keywords: postscript uudecode binhex shar forward gnatsweb pgp
@@ -159,13 +158,25 @@ This can be either \"inline\" or \"attachment\".")
mm-uu-diff-extract
nil
mm-uu-diff-test)
+ (diff
+ "^=== modified file "
+ nil
+ mm-uu-diff-extract
+ nil
+ mm-uu-diff-test)
+ (git-format-patch
+ "^diff --git "
+ "^-- "
+ mm-uu-diff-extract
+ nil
+ mm-uu-diff-test)
(message-marks
;; Text enclosed with tags similar to `message-mark-insert-begin' and
;; `message-mark-insert-end'. Don't use those variables to avoid
;; 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).
@@ -186,7 +197,15 @@ This can be either \"inline\" or \"attachment\".")
"^\\\\end{document}"
mm-uu-latex-extract
nil
- mm-uu-latex-test))
+ mm-uu-latex-test)
+ (org-src-code-block
+ "^[ \t]*#\\+begin_"
+ "^[ \t]*#\\+end_"
+ mm-uu-org-src-code-block-extract)
+ (org-meta-line
+ "^[ \t]*#\\+[[:alpha:]]+: "
+ "$"
+ mm-uu-org-src-code-block-extract))
"A list of specifications for non-MIME attachments.
Each element consist of the following entries: label,
start-regexp, end-regexp, extract-function, test-function.
@@ -383,6 +402,10 @@ apply the face `mm-uu-extract'."
(list mm-dissect-disposition
(cons 'filename file-name))))
+(defun mm-uu-org-src-code-block-extract ()
+ (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
+ '("text/x-org")))
+
(defvar gnus-newsgroup-name)
(defun mm-uu-emacs-sources-test ()
@@ -441,7 +464,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
@@ -682,6 +705,8 @@ Assume text has been decoded if DECODED is non-nil."
;; Mutt still uses application/pgp even though
;; it has already been withdrawn.
(string-match "\\`text/\\|\\`application/pgp\\'" type)
+ (equal (car (mm-handle-disposition handle))
+ "inline")
(setq
children
(with-current-buffer buffer
@@ -729,5 +754,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 d10f2d9f631..5a90f015aed 100644
--- a/lisp/gnus/mm-view.el
+++ b/lisp/gnus/mm-view.el
@@ -1,7 +1,6 @@
;;; mm-view.el --- functions for viewing MIME objects
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; This file is part of GNU Emacs.
@@ -22,6 +21,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))
@@ -30,7 +31,10 @@
(require 'mm-bodies)
(require 'mm-decode)
(require 'smime)
+(require 'mml-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
@@ -441,7 +455,7 @@
(narrow-to-region (point) (point))
(mm-insert-part handle)
(goto-char (point-max)))
- (insert (mm-decode-string (mm-get-part handle) charset)))
+ (mm-display-inline-fontify handle))
(when (and mm-fill-flowed
(equal type "plain")
(equal (cdr (assoc 'format (mm-handle-type handle)))
@@ -551,15 +565,16 @@
(face-property 'default prop) (current-buffer))))
(delete-region ,(point-min-marker) ,(point-max-marker)))))))))
-(defun mm-display-inline-fontify (handle mode)
+(defun mm-display-inline-fontify (handle &optional mode)
+ "Insert HANDLE inline fontifying with MODE.
+If MODE is not set, try to find mode automatically."
(let ((charset (mail-content-type-get (mm-handle-type handle) 'charset))
text coding-system)
(unless (eq charset 'gnus-decoded)
(mm-with-unibyte-buffer
(mm-insert-part handle)
(mm-decompress-buffer
- (or (mail-content-type-get (mm-handle-disposition handle) 'name)
- (mail-content-type-get (mm-handle-disposition handle) 'filename))
+ (mm-handle-filename handle)
t t)
(unless charset
(setq coding-system (mm-find-buffer-file-coding-system)))
@@ -587,9 +602,15 @@
(font-lock-support-mode nil)
;; I find font-lock a bit too verbose.
(font-lock-verbose nil))
- (funcall mode)
+ (setq buffer-file-name (mm-handle-filename handle))
+ (set (make-local-variable 'enable-local-variables) nil)
+ (if mode
+ (funcall mode)
+ (set-auto-mode))
;; The mode function might have already turned on font-lock.
- (unless (symbol-value 'font-lock-mode)
+ ;; Do not fontify if the guess mode is fundamental.
+ (unless (or (symbol-value 'font-lock-mode)
+ (eq major-mode 'fundamental-mode))
(font-lock-fontify-buffer)))
;; By default, XEmacs font-lock uses non-duplicable text
;; properties. This code forces all the text properties
@@ -600,6 +621,9 @@
nil)
nil nil nil nil nil 'text-prop))
(setq text (buffer-string))
+ ;; Set buffer unmodified to avoid confirmation when killing the
+ ;; buffer.
+ (set-buffer-modified-p nil)
(kill-buffer (current-buffer)))
(mm-insert-inline handle text)))
@@ -617,6 +641,18 @@
(defun mm-display-dns-inline (handle)
(mm-display-inline-fontify handle 'dns-mode))
+(defun mm-display-org-inline (handle)
+ "Show an Org mode text from HANDLE inline."
+ (mm-display-inline-fontify handle 'org-mode))
+
+(defun mm-display-shell-script-inline (handle)
+ "Show a shell script from HANDLE inline."
+ (mm-display-inline-fontify handle 'shell-script-mode))
+
+(defun mm-display-javascript-inline (handle)
+ "Show JavsScript code from HANDLE inline."
+ (mm-display-inline-fontify handle 'javascript-mode))
+
;; id-signedData OBJECT IDENTIFIER ::= { iso(1) member-body(2)
;; us(840) rsadsi(113549) pkcs(1) pkcs7(7) 2 }
(defvar mm-pkcs7-signed-magic
@@ -639,9 +675,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,21 +702,26 @@
(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")
- (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m")
- (smime-decrypt-region
- (point-min) (point-max)
- (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))))))
+ (if (eq mml-smime-use 'epg)
+ ;; Use EPG/gpgsm
+ (let ((part (base64-decode-string (buffer-string))))
+ (erase-buffer)
+ (insert (epg-decrypt-string (epg-make-context 'CMS) part)))
+ ;; Use openssl
+ (insert "MIME-Version: 1.0\n")
+ (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m")
+ (smime-decrypt-region
+ (point-min) (point-max)
+ (if (= (length smime-keys) 1)
+ (cadar smime-keys)
+ (smime-get-key-by-email
+ (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 +729,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 3d80fee6880..1c6405b2b38 100644
--- a/lisp/gnus/mml-sec.el
+++ b/lisp/gnus/mml-sec.el
@@ -1,7 +1,6 @@
;;; mml-sec.el --- A package with security functions for MML documents
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Author: Simon Josefsson <simon@josefsson.org>
@@ -26,10 +25,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 +104,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 +307,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 +379,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 85995d8cd4f..43c91604ec5 100644
--- a/lisp/gnus/mml-smime.el
+++ b/lisp/gnus/mml-smime.el
@@ -1,7 +1,6 @@
;;; mml-smime.el --- S/MIME support for MML
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Author: Simon Josefsson <simon@josefsson.org>
;; Keywords: Gnus, MIME, S/MIME, MML
@@ -25,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))))
@@ -37,7 +36,12 @@
(autoload 'message-narrow-to-headers "message")
(autoload 'message-fetch-field "message")
-(defvar mml-smime-use 'openssl)
+(defcustom mml-smime-use (if (featurep 'epg) 'epg 'openssl)
+ "Whether to use OpenSSL or EPG to decrypt S/MIME messages.
+Defaults to EPG if it's loaded."
+ :group 'mime-security
+ :type '(choice (const :tag "EPG" epg)
+ (const :tag "OpenSSL" openssl)))
(defvar mml-smime-function-alist
'((openssl mml-smime-openssl-sign
@@ -53,11 +57,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 +165,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 +217,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 +520,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 +554,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 e81d30ea545..8b196fa26fc 100644
--- a/lisp/gnus/mml.el
+++ b/lisp/gnus/mml.el
@@ -1,7 +1,6 @@
;;; mml.el --- A package for parsing and validating MML documents
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; This file is part of GNU Emacs.
@@ -23,7 +22,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 +32,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 +120,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 +236,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 +265,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 +408,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 +536,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 +553,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 +719,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 +918,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 +1145,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 +1185,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 +1197,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 +1214,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 +1405,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 +1462,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 +1485,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 +1508,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 +1586,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 dc564665731..0ce74b1d765 100644
--- a/lisp/gnus/mml1991.el
+++ b/lisp/gnus/mml1991.el
@@ -1,7 +1,6 @@
;;; mml1991.el --- Old PGP message format (RFC 1991) support for MML
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Sascha Ldecke <sascha@meta-x.de>,
;; Simon Josefsson <simon@josefsson.org> (Mailcrypt interface, Gnus glue)
@@ -26,9 +25,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 +56,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 +139,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,100 +165,11 @@ 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
+(autoload 'pgg-sign-region "pgg")
+(autoload 'pgg-encrypt-region "pgg")
+
(defvar pgg-default-user-id)
(defvar pgg-errors-buffer)
(defvar pgg-output-buffer)
@@ -329,7 +239,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 +425,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 5b3271b3022..df106bb6de8 100644
--- a/lisp/gnus/mml2015.el
+++ b/lisp/gnus/mml2015.el
@@ -1,7 +1,6 @@
;;; mml2015.el --- MIME Security with Pretty Good Privacy (PGP)
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
;; Keywords: PGP MIME MML
@@ -28,9 +27,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 +55,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 +65,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 +75,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 +103,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
@@ -133,10 +116,17 @@ Whether the passphrase is cached at all is controlled by
:type 'integer)
(defcustom mml2015-signers nil
- "A list of your own key ID which will be used to sign a message."
+ "A list of your own key ID(s) which will be used to sign a message.
+If set, it overrides the setting of `mml2015-sign-with-sender'."
:group 'mime-security
:type '(repeat (string :tag "Key ID")))
+(defcustom mml2015-sign-with-sender nil
+ "If t, use message sender so find a key to sign with."
+ :group 'mime-security
+ :type 'boolean
+ :version "24.1")
+
(defcustom mml2015-encrypt-to-self nil
"If t, add your own key ID to recipient list when encryption."
:group 'mime-security
@@ -149,7 +139,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 +179,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 +225,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 +489,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)
@@ -982,12 +748,11 @@ Whether the passphrase is cached at all is controlled by
(autoload 'epg-key-sub-key-list "epg")
(autoload 'epg-sub-key-capability "epg")
(autoload 'epg-sub-key-validity "epg")
+(autoload 'epg-sub-key-fingerprint "epg")
(autoload 'epg-configuration "epg-config")
(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,12 +784,31 @@ 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)))
(setq pointer (cdr pointer))))
(setq keys (cdr keys)))))
+;; XXX: since gpg --list-secret-keys does not return validity of each
+;; key, `mml2015-epg-find-usable-key' defined above is not enough for
+;; secret keys. The function `mml2015-epg-find-usable-secret-key'
+;; below looks at appropriate public keys to check usability.
+(defun mml2015-epg-find-usable-secret-key (context name usage)
+ (let ((secret-keys (epg-list-keys context name t))
+ secret-key)
+ (while (and (not secret-key) secret-keys)
+ (if (mml2015-epg-find-usable-key
+ (epg-list-keys context (epg-sub-key-fingerprint
+ (car (epg-key-sub-key-list
+ (car secret-keys)))))
+ usage)
+ (setq secret-key (car secret-keys)
+ secret-keys nil)
+ (setq secret-keys (cdr secret-keys))))
+ secret-key))
+
(defun mml2015-epg-decrypt (handle ctl)
(catch 'error
(let ((inhibit-redisplay t)
@@ -1182,6 +966,10 @@ 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-names (or mml2015-signers
+ (if (and mml2015-sign-with-sender sender)
+ (list (concat "<" sender ">")))))
signer-key
(signers
(or (message-options-get 'mml2015-epg-signers)
@@ -1191,14 +979,15 @@ 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
+ signer-names
+ t)
+ (if (or sender mml2015-signers)
(delq nil
(mapcar
(lambda (signer)
- (setq signer-key (mml2015-epg-find-usable-key
- (epg-list-keys context signer t)
- 'sign))
+ (setq signer-key
+ (mml2015-epg-find-usable-secret-key
+ context signer 'sign))
(unless (or signer-key
(y-or-n-p
(format
@@ -1206,7 +995,7 @@ If no one is selected, default secret key is used. "
signer)))
(error "No secret key for %s" signer))
signer-key)
- mml2015-signers)))))))
+ signer-names)))))))
signature micalg)
(epg-context-set-armor context t)
(epg-context-set-textmode context t)
@@ -1246,13 +1035,18 @@ If no one is selected, default secret key is used. "
(goto-char (point-max))))
(defun mml2015-epg-encrypt (cont &optional sign)
- (let ((inhibit-redisplay t)
- (context (epg-make-context))
- (config (epg-configuration))
- (recipients (message-options-get 'mml2015-epg-recipients))
- cipher signers
- (boundary (mml-compute-boundary cont))
- recipient-key signer-key)
+ (let* ((inhibit-redisplay t)
+ (context (epg-make-context))
+ (boundary (mml-compute-boundary cont))
+ (config (epg-configuration))
+ (recipients (message-options-get 'mml2015-epg-recipients))
+ cipher
+ (sender (message-options-get 'message-sender))
+ (signer-names (or mml2015-signers
+ (if (and mml2015-sign-with-sender sender)
+ (list (concat "<" sender ">")))))
+ signers
+ recipient-key signer-key)
(unless recipients
(setq recipients
(apply #'nconc
@@ -1266,9 +1060,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 signer-names
+ (error "Neither message sender nor mml2015-signers are set"))
+ (setq recipients (nconc recipients signer-names)))
(if (eq mm-encrypt-option 'guided)
(setq recipients
(epa-select-keys context "\
@@ -1301,14 +1095,15 @@ 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
+ signer-names
+ t)
+ (if (or sender mml2015-signers)
(delq nil
(mapcar
(lambda (signer)
- (setq signer-key (mml2015-epg-find-usable-key
- (epg-list-keys context signer t)
- 'sign))
+ (setq signer-key
+ (mml2015-epg-find-usable-secret-key
+ context signer 'sign))
(unless (or signer-key
(y-or-n-p
(format
@@ -1316,7 +1111,7 @@ If no one is selected, default secret key is used. "
signer)))
(error "No secret key for %s" signer))
signer-key)
- mml2015-signers)))))))
+ signer-names)))))))
(epg-context-set-signers context signers))
(epg-context-set-armor context t)
(epg-context-set-textmode context t)
@@ -1416,5 +1211,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 63eea8cacd4..f6f0d6c1434 100644
--- a/lisp/gnus/nnagent.el
+++ b/lisp/gnus/nnagent.el
@@ -1,7 +1,6 @@
;;; nnagent.el --- offline backend for Gnus
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news, mail
@@ -121,7 +120,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 +150,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 +189,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 +251,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 +263,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 0e53be39a77..e10620683c9 100644
--- a/lisp/gnus/nnbabyl.el
+++ b/lisp/gnus/nnbabyl.el
@@ -1,7 +1,6 @@
;;; nnbabyl.el --- rmail mbox access for Gnus
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
@@ -75,8 +74,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 +134,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 +152,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 +190,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 +212,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 +259,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 +302,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 +336,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 +355,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 +365,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 +379,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 +399,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 +425,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 +545,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 +558,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 +635,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 +647,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 07cd7b1d127..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, 2011 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 0662da239b2..db7ac1b44f8 100644
--- a/lisp/gnus/nndiary.el
+++ b/lisp/gnus/nndiary.el
@@ -1,7 +1,6 @@
;;; nndiary.el --- A diary back end for Gnus
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Didier Verna <didier@xemacs.org>
;; Maintainer: Didier Verna <didier@xemacs.org>
@@ -380,8 +379,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 +481,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 +613,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 +669,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 +684,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 +837,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 +882,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 +982,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 +1007,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 +1060,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 +1070,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 +1083,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 +1094,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 +1115,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 +1571,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 b90cd4929e6..736f37c1fa5 100644
--- a/lisp/gnus/nndir.el
+++ b/lisp/gnus/nndir.el
@@ -1,7 +1,6 @@
;;; nndir.el --- single directory newsgroup access for Gnus
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -96,5 +95,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 b3361bb4a94..f900e02eb08 100644
--- a/lisp/gnus/nndoc.el
+++ b/lisp/gnus/nndoc.el
@@ -1,7 +1,6 @@
;;; nndoc.el --- single file access for Gnus
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
@@ -64,9 +63,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 +78,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 +99,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 +117,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 +137,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 +200,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 +223,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 +231,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 +277,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 +293,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 +316,7 @@ from the document.")
t)
(deffoo nndoc-request-list (&optional server)
- nil)
+ t)
(deffoo nndoc-request-newgroups (date &optional server)
nil)
@@ -322,8 +350,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 +363,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 +386,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 +473,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 +604,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 +663,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 +716,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 +807,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 +867,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 +917,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 +940,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 +1077,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 +1093,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 94dd20b2e19..006348869ef 100644
--- a/lisp/gnus/nndraft.el
+++ b/lisp/gnus/nndraft.el
@@ -1,7 +1,6 @@
;;; nndraft.el --- draft article access for Gnus
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -77,10 +76,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 +90,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 +120,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 +184,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 +202,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 +221,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 +317,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 daf4311a911..7f4fab0a991 100644
--- a/lisp/gnus/nneething.el
+++ b/lisp/gnus/nneething.el
@@ -1,7 +1,6 @@
;;; nneething.el --- arbitrary file access for Gnus
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
@@ -28,6 +27,7 @@
(eval-when-compile (require 'cl))
+(require 'mailcap)
(require 'nnheader)
(require 'nnmail)
(require 'nnoo)
@@ -80,8 +80,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 +143,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 +321,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 +329,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 +378,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 +422,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 d90e836e246..3ec30410473 100644
--- a/lisp/gnus/nnfolder.el
+++ b/lisp/gnus/nnfolder.el
@@ -1,7 +1,6 @@
;;; nnfolder.el --- mail folder access for Gnus
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-2011 Free Software Foundation, Inc.
;; Author: Simon Josefsson <simon@josefsson.org> (adding MARKS)
;; ShengHuo Zhu <zsh@cs.rochester.edu> (adding NOV)
@@ -29,7 +28,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 +156,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 +259,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 +288,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))
@@ -324,20 +321,20 @@ the group. Then the marks file will be regenerated properly by Gnus.")
(when nnfolder-get-new-mail
(nnfolder-possibly-change-group group server)
(nnmail-get-new-mail
- 'nnfolder
- (lambda ()
- (let ((bufs nnfolder-buffer-alist))
- (save-excursion
- (while bufs
- (if (not (gnus-buffer-live-p (nth 1 (car bufs))))
- (setq nnfolder-buffer-alist
- (delq (car bufs) nnfolder-buffer-alist))
- (set-buffer (nth 1 (car bufs)))
- (nnfolder-save-buffer)
- (kill-buffer (current-buffer)))
- (setq bufs (cdr bufs))))))
- nnfolder-directory
- group)))
+ 'nnfolder 'nnfolder-save-all-buffers
+ nnfolder-directory group)))
+
+(defun nnfolder-save-all-buffers ()
+ (let ((bufs nnfolder-buffer-alist))
+ (save-excursion
+ (while bufs
+ (if (not (gnus-buffer-live-p (nth 1 (car bufs))))
+ (setq nnfolder-buffer-alist
+ (delq (car bufs) nnfolder-buffer-alist))
+ (set-buffer (nth 1 (car bufs)))
+ (nnfolder-save-buffer)
+ (kill-buffer (current-buffer)))
+ (setq bufs (cdr bufs))))))
;; Don't close the buffer if we're not shutting down the server. This way,
;; we can keep the buffer in the group buffer cache, and not have to grovel
@@ -360,8 +357,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 +443,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.
@@ -492,17 +487,17 @@ the group. Then the marks file will be regenerated properly by Gnus.")
(nnfolder-save-buffer)
(nnfolder-adjust-min-active newsgroup)
(nnfolder-save-active nnfolder-group-alist nnfolder-active-file)
+ (nnfolder-save-all-buffers)
(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))
@@ -1092,6 +1083,8 @@ This command does not work if you use short group names."
(or nnfolder-nov-directory nnfolder-directory)))
(concat (nnfolder-group-pathname group) nnfolder-nov-file-suffix)))
+(defvar copyright-update)
+
(defun nnfolder-save-buffer ()
"Save the buffer."
(when (buffer-modified-p)
@@ -1114,8 +1107,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 +1131,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 +1141,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 +1177,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 +1188,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 +1278,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 f3a12c5582b..994cefc9d08 100644
--- a/lisp/gnus/nngateway.el
+++ b/lisp/gnus/nngateway.el
@@ -1,7 +1,6 @@
;;; nngateway.el --- posting news via mail gateways
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news, mail
@@ -89,5 +88,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 a0bd442f113..6f871ccb9e8 100644
--- a/lisp/gnus/nnheader.el
+++ b/lisp/gnus/nnheader.el
@@ -1,8 +1,7 @@
;;; nnheader.el --- header access macros for Gnus and its backends
-;; Copyright (C) 1987, 1988, 1989, 1990, 1993, 1994,
-;; 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1987-1990, 1993-1998, 2000-2011
+;; Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -27,6 +26,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)
@@ -41,6 +43,8 @@
(require 'mail-utils)
(require 'mm-util)
(require 'gnus-util)
+(autoload 'gnus-range-add "gnus-range")
+(autoload 'gnus-remove-from-range "gnus-range")
;; FIXME none of these are used explicitly in this file.
(autoload 'gnus-sorted-intersection "gnus-range")
(autoload 'gnus-intersection "gnus-range")
@@ -75,7 +79,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 +104,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 +125,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 +367,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 +463,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 +570,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 +661,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 +784,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 +822,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 +1079,39 @@ 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)
+
+(defmacro nnheader-insert-buffer-substring (buffer &optional start end)
+ "Copy string from unibyte buffer to multibyte current buffer."
+ (if (featurep 'xemacs)
+ `(insert-buffer-substring ,buffer ,start ,end)
+ `(if enable-multibyte-characters
+ (insert (with-current-buffer ,buffer
+ (mm-string-to-multibyte
+ ,(if (or start end)
+ `(buffer-substring (or ,start (point-min))
+ (or ,end (point-max)))
+ '(buffer-string)))))
+ (insert-buffer-substring ,buffer ,start ,end))))
+
(when (featurep 'xemacs)
(require 'nnheaderxm))
@@ -1081,5 +1119,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 1e2a9da244f..6882ed63135 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2011 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,1921 @@
;;; 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)
-(require 'nnheader)
-(require 'mm-util)
-(require 'gnus)
-(require 'gnus-range)
-(require 'gnus-start)
-(require 'gnus-int)
+;; For Emacs <22.2 and XEmacs.
+(eval-and-compile
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
-(eval-when-compile (require 'cl))
+(eval-and-compile
+ (require 'nnheader)
+ ;; In Emacs 24, `open-protocol-stream' is an autoloaded alias for
+ ;; `make-network-stream'.
+ (unless (fboundp 'open-protocol-stream)
+ (require 'proto-stream)))
-(autoload 'auth-source-user-or-password "auth-source")
+(eval-when-compile
+ (require 'cl))
-(nnoo-declare nnimap)
+(require 'nnheader)
+(require 'gnus-util)
+(require 'gnus)
+(require 'nnoo)
+(require 'netrc)
+(require 'utf7)
+(require 'tls)
+(require 'parse-time)
+(require 'nnmail)
-(defconst nnimap-version "nnimap 1.0")
+(autoload 'auth-source-forget+ "auth-source")
+(autoload 'auth-source-search "auth-source")
-(defgroup nnimap nil
- "Reading IMAP mail with Gnus."
- :group 'gnus)
+(nnoo-declare nnimap)
(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-user nil
+ "Username to use for authentication to 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 'undecided
+ "How nnimap talks to the IMAP server.
+The value should be either `undecided', `ssl' or `tls',
+`network', `starttls', `plain', or `shell'.
+
+If the value is `undecided', nnimap tries `ssl' first, then falls
+back on `network'.")
+
+(defvoo nnimap-shell-program (if (boundp 'imap-shell-program)
+ (if (listp imap-shell-program)
+ (car imap-shell-program)
+ imap-shell-program)
+ "ssh %s imapd"))
-(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-inbox nil
+ "The mail box where incoming mail arrives and should be split out of.
+For example, \"INBOX\".")
+
+(defvoo nnimap-split-methods nil
+ "How mail is split.
+Uses the same syntax as `nnmail-split-methods'.")
+
+(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 stream-type)
+
+(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")))
+
+(defvar nnimap-quirks
+ '(("QRESYNC" "Zimbra" "QRESYNC ")))
+
+(defvar nnimap-inhibit-logging nil)
+
+(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)
+ (nnheader-remove-cr-followed-by-lf))
+ (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-credentials (address ports user)
+ (let* ((auth-source-creation-prompts
+ '((user . "IMAP user at %h: ")
+ (secret . "IMAP password for %u@%h: ")))
+ (found (nth 0 (auth-source-search :max 1
+ :host address
+ :port ports
+ :user user
+ :require '(:user :secret)
+ :create t))))
+ (if found
+ (list (plist-get found :user)
+ (let ((secret (plist-get found :secret)))
+ (if (functionp secret)
+ (funcall secret)
+ secret))
+ (plist-get found :save-function))
+ nil)))
+
+(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")))))))
+
+(defun nnimap-open-connection (buffer)
+ ;; Be backwards-compatible -- the earlier value of nnimap-stream was
+ ;; `ssl' when nnimap-server-port was nil. Sort of.
+ (when (and nnimap-server-port
+ (eq nnimap-stream 'undecided))
+ (setq nnimap-stream 'ssl))
+ (let ((stream
+ (if (eq nnimap-stream 'undecided)
+ (loop for type in '(ssl network)
+ for stream = (let ((nnimap-stream type))
+ (nnimap-open-connection-1 buffer))
+ while (eq stream 'no-connect)
+ finally (return stream))
+ (nnimap-open-connection-1 buffer))))
+ (if (eq stream 'no-connect)
+ nil
+ stream)))
+
+(defun nnimap-open-connection-1 (buffer)
+ (unless nnimap-keepalive-timer
+ (setq nnimap-keepalive-timer (run-at-time (* 60 15) (* 60 15)
+ 'nnimap-keepalive)))
+ (with-current-buffer (nnimap-make-process-buffer buffer)
+ (let* ((coding-system-for-read 'binary)
+ (coding-system-for-write 'binary)
+ (port nil)
+ (ports
+ (cond
+ ((memq nnimap-stream '(network plain starttls))
+ (nnheader-message 7 "Opening connection to %s..."
+ nnimap-address)
+ '("imap" "143"))
+ ((eq nnimap-stream 'shell)
+ (nnheader-message 7 "Opening connection to %s via shell..."
+ nnimap-address)
+ '("imap"))
+ ((memq nnimap-stream '(ssl tls))
+ (nnheader-message 7 "Opening connection to %s via tls..."
+ nnimap-address)
+ '("imaps" "imap" "993" "143"))
+ (t
+ (error "Unknown stream type: %s" nnimap-stream))))
+ login-result credentials)
+ (when nnimap-server-port
+ (push nnimap-server-port ports))
+ (let* ((stream-list
+ (open-protocol-stream
+ "*nnimap*" (current-buffer) nnimap-address (car ports)
+ :type nnimap-stream
+ :return-list t
+ :shell-command nnimap-shell-program
+ :capability-command "1 CAPABILITY\r\n"
+ :end-of-command "\r\n"
+ :success " OK "
+ :starttls-function
+ (lambda (capabilities)
+ (when (gnus-string-match-p "STARTTLS" capabilities)
+ "1 STARTTLS\r\n"))))
+ (stream (car stream-list))
+ (props (cdr stream-list))
+ (greeting (plist-get props :greeting))
+ (capabilities (plist-get props :capabilities))
+ (stream-type (plist-get props :type)))
+ (when (and stream (not (memq (process-status stream) '(open run))))
+ (setq stream nil))
+ (setf (nnimap-process nnimap-object) stream)
+ (setf (nnimap-stream-type nnimap-object) stream-type)
+ (if (not stream)
+ (progn
+ (nnheader-report 'nnimap "Unable to contact %s:%s via %s"
+ nnimap-address port nnimap-stream)
+ 'no-connect)
+ (gnus-set-process-query-on-exit-flag stream nil)
+ (if (not (gnus-string-match-p "[*.] \\(OK\\|PREAUTH\\)" greeting))
+ (nnheader-report 'nnimap "%s" greeting)
+ ;; Store the greeting (for debugging purposes).
+ (setf (nnimap-greeting nnimap-object) greeting)
+ (setf (nnimap-capabilities nnimap-object)
+ (mapcar #'upcase
+ (split-string capabilities)))
+ (unless (gnus-string-match-p "[*.] PREAUTH" greeting)
+ (if (not (setq credentials
+ (if (eq nnimap-authenticator 'anonymous)
+ (list "anonymous"
+ (message-make-address))
+ ;; Look for the credentials based on
+ ;; the virtual server name and the address
+ (nnimap-credentials
+ (gnus-delete-duplicates
+ (list
+ nnimap-address
+ (nnoo-current-server 'nnimap)))
+ ports
+ nnimap-user))))
+ (setq nnimap-object nil)
+ (let ((nnimap-inhibit-logging t))
+ (setq login-result
+ (nnimap-login (car credentials) (cadr credentials))))
+ (if (car login-result)
+ (progn
+ ;; Save the credentials if a save function exists
+ ;; (such a function will only be passed if a new
+ ;; token was created).
+ (when (functionp (nth 2 credentials))
+ (funcall (nth 2 credentials)))
+ ;; See if CAPABILITY is set as part of login
+ ;; response.
+ (dolist (response (cddr login-result))
+ (when (string= "CAPABILITY" (upcase (car response)))
+ (setf (nnimap-capabilities nnimap-object)
+ (mapcar #'upcase (cdr response))))))
+ ;; 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)
+ (auth-source-forget+ :host host :port 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))))))))
+
+(autoload 'rfc2104-hash "rfc2104")
+
+(defun nnimap-login (user password)
+ (cond
+ ;; Prefer plain LOGIN if it's enabled (since it requires fewer
+ ;; round trips than CRAM-MD5, and it's less likely to be buggy),
+ ;; and we're using an encrypted connection.
+ ((and (not (nnimap-capability "LOGINDISABLED"))
+ (eq (nnimap-stream-type nnimap-object) 'tls))
+ (nnimap-command "LOGIN %S %S" user password))
+ ((nnimap-capability "AUTH=CRAM-MD5")
+ (erase-buffer)
+ (let ((sequence (nnimap-send-command "AUTHENTICATE CRAM-MD5"))
+ (challenge (nnimap-wait-for-line "^\\+\\(.*\\)\n")))
+ (process-send-string
+ (get-buffer-process (current-buffer))
+ (concat
+ (base64-encode-string
+ (concat user " "
+ (rfc2104-hash 'md5 64 16 password
+ (base64-decode-string challenge))))
+ "\r\n"))
+ (nnimap-wait-for-response sequence)))
+ ((not (nnimap-capability "LOGINDISABLED"))
+ (nnimap-command "LOGIN %S %S" user password))
+ ((nnimap-capability "AUTH=PLAIN")
+ (nnimap-command
+ "AUTHENTICATE PLAIN %s"
+ (base64-encode-string
+ (format "\000%s\000%s"
+ (nnimap-quote-specials user)
+ (nnimap-quote-specials password)))))))
+
+(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-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-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-asynchronous-p ()
- t)
+ 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)
+ (nnheader-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)))
+ (if (null article)
+ nil
+ (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)))))))
+
+(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)))
-(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-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 (or (nnimap-get-length) 0))
+ (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 (not 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))
+ (cond
+ ;; shortcut further processing if we're going to delete the articles
+ ((eq nnmail-expiry-target 'delete)
+ (setq deleted-articles articles)
+ t)
+ ;; or just move them to another folder on the same IMAP server
+ ((and (not (functionp nnmail-expiry-target))
+ (gnus-server-equal (gnus-group-method nnmail-expiry-target)
+ (gnus-server-to-method
+ (format "nnimap:%s" server))))
+ (and (nnimap-possibly-change-group group server)
+ (with-current-buffer (nnimap-buffer)
+ (nnheader-message 7 "Expiring articles from %s: %s" group articles)
+ (nnimap-command
+ "UID COPY %s %S"
+ (nnimap-article-ranges (gnus-compress-sequence articles))
+ (utf7-encode (gnus-group-real-name nnmail-expiry-target) t))
+ (setq deleted-articles articles)))
+ t)
+ (t
+ (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-update-group-status (group status &optional server)
+ (when (nnimap-possibly-change-group nil server)
+ (let ((command (assoc
+ status
+ '((subscribe "SUBSCRIBE")
+ (unsubscribe "UNSUBSCRIBE")))))
+ (when command
+ (with-current-buffer (nnimap-buffer)
+ (nnimap-command "%s %S" (cadr command) (utf7-encode group t)))))))
(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)))
-
-(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.
- (with-current-buffer nntp-server-buffer
- ;; Fold continuation lines.
+(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)
+ (when (setq message (or (nnimap-process-quirk "OK Gimap " 'append message)
+ message))
+ ;; 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 (nnimap-ok-p result))
+ (progn
+ (nnheader-report 'nnimap "%s" result)
+ nil)
+ (cons group
+ (or (nnimap-find-uid-response "APPENDUID" (car result))
+ (nnimap-find-article-by-message-id
+ group message-id))))))))))
+
+(defun nnimap-process-quirk (greeting-match type data)
+ (when (and (nnimap-greeting nnimap-object)
+ (string-match greeting-match (nnimap-greeting nnimap-object))
+ (eq type 'append)
+ (string-match "\000" data))
+ (let ((choice (gnus-multiple-choice
+ "Message contains NUL characters. Delete, continue, abort? "
+ '((?d "Delete NUL characters")
+ (?c "Try to APPEND the message as is")
+ (?a "Abort")))))
+ (cond
+ ((eq choice ?a)
+ (nnheader-report 'nnimap "Aborted APPEND due to NUL characters"))
+ ((eq choice ?c)
+ data)
+ (t
+ (with-temp-buffer
+ (insert data)
+ (goto-char (point-min))
+ (while (search-forward "\000" nil t)
+ (replace-match "" t t))
+ (buffer-string)))))))
+
+(defun nnimap-ok-p (value)
+ (and (consp value)
+ (consp (car value))
+ (equal (caar value) "OK")))
+
+(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))
- (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)
- 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))
- t))))
+ (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)))
-(deffoo nnimap-request-scan (&optional group server)
- (nnimap-split-articles group server))
+(deffoo nnimap-request-list (&optional server)
+ (when (nnimap-possibly-change-group nil server)
+ (with-current-buffer nntp-server-buffer
+ (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)
+ 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-newgroups (date &optional server)
- (when (nnimap-possibly-change-server server)
+ (when (nnimap-possibly-change-group nil 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))
- t))
+ (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
+ active
+ modseq)
+ (push
+ (list (nnimap-send-command "EXAMINE %S (%s (%s %s))"
+ (utf7-encode group t)
+ (nnimap-quirk "QRESYNC")
+ 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))))
+
+(defun nnimap-quirk (command)
+ (let ((quirk (assoc command nnimap-quirks)))
+ ;; If this server is of a type that matches a quirk, then return
+ ;; the "quirked" command instead of the proper one.
+ (if (or (null quirk)
+ (not (string-match (nth 1 quirk) (nnimap-greeting nnimap-object))))
+ command
+ (nth 2 quirk))))
+
+(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))))
+ (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))))
+ ;; Tell Gnus whether there are any \Recent messages in any of
+ ;; the groups.
+ (let ((recent (cdr (assoc '%Recent flags))))
+ (when (and active
+ recent
+ (> (car (last recent)) (cdr active)))
+ (push (list (cons (gnus-group-real-name group) 0))
+ nnmail-split-history)))
+ ;; 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)
+ ;; Remove any MODSEQ entries in the buffer, because they may contain
+ ;; numbers that are too large for 32-bit Emacsen.
+ (while (re-search-forward " MODSEQ ([0-9]+)" nil t)
+ (replace-match "" t t))
+ (goto-char (point-min))
+ (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 (re-search-forward "HIGHESTMODSEQ \\([0-9]+\\)"
+ (or end (point-min)) t)
+ (match-string 1)))
+ (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)
+ (let ((p (point)))
+ (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-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))))
+(deffoo nnimap-request-post (&optional server)
+ (setq nnimap-status-string "Read-only server")
+ nil)
-(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)))
+(declare-function gnus-fetch-headers "gnus-sum"
+ (articles &optional limit force-new dependencies))
-
-;;; 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 (header)
+ (let* ((id (mail-header-id header))
+ (refs (split-string
+ (or (mail-header-references 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))))
+ (when result
+ (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)
+ (setf (nnimap-last-command-time nnimap-object) (current-time))
+ (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") " "
+ (if nnimap-inhibit-logging
+ "(inhibited)\n"
+ command)))
+ command)
+
+(defun nnimap-command (&rest args)
+ (erase-buffer)
+ (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)
+ (nnimap-wait-for-line (or regexp "^[*.] .*\n") "[*.] \\([A-Z0-9]+\\)"))
+
+(defun nnimap-wait-for-line (regexp &optional response-regexp)
+ (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 (or response-regexp regexp))
+ (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)))
+ (progn
+ ;; Skip past any "*" lines that the server has
+ ;; output.
+ (while (and (not (bobp))
+ (progn
+ (forward-line -1)
+ (looking-at "\\*"))))
+ (not (looking-at (format "%d .*\n" sequence)))))
+ (when messagep
+ (nnheader-message 7 "nnimap read %dk" (/ (buffer-size) 1000)))
+ (nnheader-accept-process-output process)
+ (goto-char (point-max)))
+ openp)
+ (quit
+ (when debug-on-quit
+ (debug "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"
+ "RFC822.PEEK"))
+ (cond
+ (nnimap-split-download-body-default
+ "[]")
+ ((nnimap-ver4-p)
+ "[HEADER]")
+ (t
+ "[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\\b" 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 14d1abd5bba..eaaac3f88ce 100644
--- a/lisp/gnus/nnir.el
+++ b/lisp/gnus/nnir.el
@@ -1,7 +1,6 @@
;;; nnir.el --- search mail with various search engines -*- coding: iso-8859-1 -*-
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Kai Grojohann <grossjohann@ls6.cs.uni-dortmund.de>
;; Swish-e and Swish++ backends by:
@@ -32,163 +31,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.
-
-;; 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.
+;; Where in the existing gnus manual would this fit best?
-;; 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 T'
+;; (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 +104,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 +129,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,177 +160,188 @@
;; 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:
+;; `nnir-search-engine' as a server variable.
-;; * 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.
-;;
+;;; Code:
-;; Have you got other ideas?
+;;; Setup:
-;;; 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)
(require 'message)
(require 'gnus-util)
(eval-when-compile
(require 'cl))
-(nnoo-declare nnir)
-(nnoo-define-basics nnir)
+;;; Internal Variables:
-(gnus-declare-backend "nnir" 'mail)
+(defvar nnir-current-query nil
+ "Internal: stores current query (= group name).")
+
+(defvar nnir-current-server nil
+ "Internal: stores current server (does it ever change?).")
-(defvar nnir-imap-search-field "TEXT"
- "The IMAP search item when doing an nnir search")
+(defvar nnir-current-group-marked nil
+ "Internal: stores current list of process-marked groups.")
+
+(defvar nnir-artlist nil
+ "Internal: stores search result.")
+
+(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")
+
+;; Imap variables
(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")
+ '(("whole message" . "TEXT")
+ ("subject" . "SUBJECT")
+ ("to" . "TO")
+ ("from" . "FROM")
+ ("body" . "BODY")
+ ("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:
+;;; Helper macros
-(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.
+;; Data type article list.
-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'.
+(defmacro nnir-artlist-length (artlist)
+ "Returns number of articles in artlist."
+ `(length ,artlist))
+
+(defmacro nnir-artlist-article (artlist n)
+ "Returns from ARTLIST the Nth artitem (counting starting at 1)."
+ `(when (> ,n 0)
+ (elt ,artlist (1- ,n))))
+
+(defmacro nnir-artitem-group (artitem)
+ "Returns the group from the ARTITEM."
+ `(elt ,artitem 0))
+
+(defmacro nnir-artitem-number (artitem)
+ "Returns the number from the ARTITEM."
+ `(elt ,artitem 1))
+
+(defmacro nnir-artitem-rsv (artitem)
+ "Returns the Retrieval Status Value (RSV, score) from the ARTITEM."
+ `(elt ,artitem 2))
+
+(defmacro nnir-article-group (article)
+ "Returns the group for ARTICLE"
+ `(nnir-artitem-group (nnir-artlist-article nnir-artlist ,article)))
+
+(defmacro nnir-article-number (article)
+ "Returns the number for ARTICLE"
+ `(nnir-artitem-number (nnir-artlist-article nnir-artlist ,article)))
+
+(defmacro nnir-article-rsv (article)
+ "Returns the rsv for ARTICLE"
+ `(nnir-artitem-rsv (nnir-artlist-article nnir-artlist ,article)))
+
+(defsubst nnir-article-ids (article)
+ "Returns the pair `(nnir id . real id)' of ARTICLE"
+ (cons article (nnir-article-number article)))
+
+(defmacro nnir-categorize (sequence keyfunc &optional valuefunc)
+ "Sorts a sequence into categories and returns a list of the form
+`((key1 (element11 element12)) (key2 (element21 element22))'.
+The category key for a member of the sequence is obtained
+as `(keyfunc member)' and the corresponding element is just
+`member'. If `valuefunc' is non-nil, the element of the list
+is `(valuefunc member)'."
+ `(unless (null ,sequence)
+ (let (value)
+ (mapc
+ (lambda (member)
+ (let ((y (,keyfunc member))
+ (x ,(if valuefunc
+ `(,valuefunc member)
+ 'member)))
+ (if (assoc y value)
+ (push x (cadr (assoc y value)))
+ (push (list y (list x)) value))))
+ ,sequence)
+ value)))
+
+;;; Finish setup:
+
+(require 'gnus-sum)
+
+(eval-when-compile
+ (autoload 'nnimap-buffer "nnimap")
+ (autoload 'nnimap-command "nnimap")
+ (autoload 'nnimap-possibly-change-group "nnimap")
+ (autoload 'gnus-registry-action "gnus-registry")
+ (defvar gnus-registry-install))
+
+
+(nnoo-declare nnir)
+(nnoo-define-basics nnir)
+
+(gnus-declare-backend "nnir" 'mail)
-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)
+(defcustom nnir-ignored-newsgroups ""
+ "*A regexp to match newsgroups in the active file that should
+ be skipped when searching."
+ :type '(regexp)
:group 'nnir)
-;; Search engine to use.
+(defcustom nnir-summary-line-format nil
+ "*The format specification of the lines in an nnir summary buffer.
-(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)
- :group 'nnir)
+All the items from `gnus-summary-line-format' are available, along
+with three items unique to nnir summary buffers:
-;; freeWAIS-sf.
+%Z Search retrieval score value (integer)
+%G Article original full group name (string)
+%g Article original short group name (string)
-(defcustom nnir-wais-program "waissearch"
- "*Name of waissearch executable."
+If nil this will use `gnus-summary-line-format'."
:type '(string)
:group 'nnir)
-(defcustom nnir-wais-database (expand-file-name "~/.wais/mail")
- "*Name of Wais database containing the mail.
+(defcustom nnir-retrieve-headers-override-function nil
+ "*If non-nil, a function that accepts an article list and group
+and populates the `nntp-server-buffer' with the retrieved
+headers. Must return either 'nov or 'headers indicating the
+retrieved header format.
-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)
+If this variable is nil, or if the provided function returns nil for a search
+result, `gnus-retrieve-headers' will be called instead."
+ :type '(function)
: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)
+(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 `(choice ,@(mapcar (lambda (elem) (list 'const (car elem)))
+ nnir-imap-search-arguments))
:group 'nnir)
(defcustom nnir-swish++-configuration-file
@@ -493,14 +370,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 +421,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 +462,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,118 +490,97 @@ 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)
-;;; Internal Variables:
-
-(defvar nnir-current-query nil
- "Internal: stores current query (= group name).")
-
-(defvar nnir-current-server nil
- "Internal: stores current server (does it ever change?).")
+;;; Developer Extension Variable:
-(defvar nnir-current-group-marked nil
- "Internal: stores current list of process-marked groups.")
+(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.
-(defvar nnir-artlist nil
- "Internal: stores search result.")
+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'.
-(defvar nnir-tmp-buffer " *nnir*"
- "Internal: temporary buffer.")
+Add an entry here when adding a new search engine.")
-;;; Code:
+(defcustom nnir-method-default-engines
+ '((nnimap . imap)
+ (nntp . gmane))
+ "*Alist of default search engines keyed by server method."
+ :type `(repeat (cons (choice (const nnimap) (const nttp) (const nnspool)
+ (const nneething) (const nndir) (const nnmbox)
+ (const nnml) (const nnmh) (const nndraft)
+ (const nnfolder) (const nnmaildir))
+ (choice
+ ,@(mapcar (lambda (elem) (list 'const (car elem)))
+ nnir-engines))))
+ :group 'nnir)
;; 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.
(deffoo nnir-open-server (server &optional definitions)
;; Just set the server variables appropriately.
+ (add-hook 'gnus-summary-mode-hook 'nnir-mode)
(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,111 +590,140 @@ 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
- (let ((artlist (copy-sequence articles))
- art artitem artgroup artno artrsv artfullgroup
- novitem novdata foo server)
- (while (not (null artlist))
- (setq art (car artlist))
- (or (numberp art)
- (nnheader-report
- 'nnir
- "nnir-retrieve-headers doesn't grok message ids: %s"
- art))
- (setq artitem (nnir-artlist-article nnir-artlist art))
- (setq artrsv (nnir-artitem-rsv artitem))
- (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))
- ;; 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))
+ (with-current-buffer nntp-server-buffer
+ (let ((gnus-inhibit-demon t)
+ (articles-by-group (nnir-categorize
+ articles nnir-article-group nnir-article-ids))
+ headers)
+ (while (not (null articles-by-group))
+ (let* ((group-articles (pop articles-by-group))
+ (artgroup (car group-articles))
+ (articleids (cadr group-articles))
+ (artlist (sort (mapcar 'cdr articleids) '<))
+ (server (gnus-group-server artgroup))
+ (gnus-override-method (gnus-server-to-method server))
+ parsefunc)
+ ;; (or (numberp art)
+ ;; (nnheader-report
+ ;; 'nnir
+ ;; "nnir-retrieve-headers doesn't grok message ids: %s"
+ ;; art))
+ (nnir-possibly-change-server server)
+ ;; is this needed?
+ (erase-buffer)
+ (case (setq gnus-headers-retrieved-by
+ (or
+ (and
+ nnir-retrieve-headers-override-function
+ (funcall nnir-retrieve-headers-override-function
+ artlist artgroup))
+ (gnus-retrieve-headers artlist artgroup 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)))
+ (setq parsefunc 'nnheader-parse-nov))
(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))))
- ;; 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)))
- (setq novdata (nreverse novdata))
- (set-buffer nntp-server-buffer) (erase-buffer)
- (mapc 'nnheader-insert-nov novdata)
+ (setq parsefunc 'nnheader-parse-head))
+ (t (error "Unknown header type %s while requesting articles \
+ of group %s" gnus-headers-retrieved-by artgroup)))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (let* ((novitem (funcall parsefunc))
+ (artno (mail-header-number novitem))
+ (art (car (rassq artno articleids))))
+ (when art
+ (mail-header-set-number novitem art)
+ (push novitem headers))
+ (forward-line 1)))))
+ (setq headers
+ (sort headers
+ (lambda (x y)
+ (< (mail-header-number x) (mail-header-number y)))))
+ (erase-buffer)
+ (mapc 'nnheader-insert-nov headers)
'nov)))
-(deffoo nnir-request-article (article
- &optional group server to-buffer)
+(deffoo nnir-request-article (article &optional group server to-buffer)
(if (stringp article)
(nnheader-report
'nnir
"nnir-retrieve-headers doesn't grok message ids: %s"
article)
(save-excursion
- (let* ((artitem (nnir-artlist-article nnir-artlist
- article))
- (artfullgroup (nnir-artitem-group artitem))
- (artno (nnir-artitem-number artitem))
- ;; Bug?
- ;; Why must we bind nntp-server-buffer here? It won't
- ;; work if `buf' is used, say. (Of course, the set-buffer
- ;; line below must then be updated, too.)
- (nntp-server-buffer (or to-buffer nntp-server-buffer)))
- (set-buffer nntp-server-buffer)
- (erase-buffer)
+ (let ((artfullgroup (nnir-article-group article))
+ (artno (nnir-article-number article)))
(message "Requesting article %d from group %s"
artno artfullgroup)
- (gnus-request-article artno artfullgroup nntp-server-buffer)
+ (if to-buffer
+ (with-current-buffer to-buffer
+ (let ((gnus-article-decode-hook nil))
+ (gnus-request-article-this-buffer artno artfullgroup)))
+ (gnus-request-article artno artfullgroup))
(cons artfullgroup artno)))))
+(deffoo nnir-request-move-article (article group server accept-form
+ &optional last internal-move-group)
+ (let* ((artfullgroup (nnir-article-group article))
+ (artno (nnir-article-number article))
+ (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)))
+ (unless (gnus-check-backend-function
+ 'request-move-article artfullgroup)
+ (error "The group %s does not support article moving" artfullgroup))
+ (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-request-expire-articles (articles group &optional server force)
+ (if force
+ (let ((articles-by-group (nnir-categorize
+ articles nnir-article-group nnir-article-ids))
+ not-deleted)
+ (while (not (null articles-by-group))
+ (let* ((group-articles (pop articles-by-group))
+ (artgroup (car group-articles))
+ (articleids (cadr group-articles))
+ (artlist (sort (mapcar 'cdr articleids) '<)))
+ (unless (gnus-check-backend-function 'request-expire-articles
+ artgroup)
+ (error "The group %s does not support article deletion" artgroup))
+ (unless (gnus-check-server (gnus-find-method-for-group artgroup))
+ (error "Couldn't open server for group %s" artgroup))
+ (push (gnus-request-expire-articles
+ artlist artgroup force)
+ not-deleted)))
+ (sort (delq nil not-deleted) '<))
+ articles))
+
+(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-article-group cur))
+ (backend-number (nnir-article-number cur)))
+ (gnus-summary-read-group-1 gnus-newsgroup-name t t gnus-summary-buffer
+ nil (list backend-number))))
(nnoo-define-skeleton nnir)
@@ -866,7 +750,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
@@ -874,8 +760,8 @@ ready to be added to the list of search results."
(gnus-replace-in-string dirnam "^[./\\]" "" t)
"[/\\]" "." t)))
- (vector (nnir-group-full-name group server)
- (if (string= server "nnmaildir:")
+ (vector (gnus-group-full-name group server)
+ (if (string= (gnus-group-server server) "nnmaildir")
(nnmaildir-base-name-to-article-number
(substring article 0 (string-match ":" article))
group nil)
@@ -884,94 +770,50 @@ 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)
+ (let ((artn (string-to-number artnum)))
+ (when (> artn 0)
+ (push (vector group artn 100)
+ artlist)
+ (setq arts (1+ arts)))))
+ (and (car result) (cdr (assoc "SEARCH" (cdr result)))))
+ (message "Searching %s... %d matches" group arts)))
+ (message "Searching %s...done" group))
+ (quit nil))
+ (nreverse artlist)))
+ groups)))))
(defun nnir-imap-make-query (criteria qstring)
"Parse the query string and criteria into an appropriate IMAP search
@@ -1027,7 +869,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 +1003,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 +1015,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 +1092,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)))
@@ -1321,7 +1163,7 @@ Tested with swish-e-2.0.1 on Windows NT 4.0."
;; Windows "\\" -> "."
(setq group (gnus-replace-in-string group "\\\\" "."))
- (push (vector (nnir-group-full-name group server)
+ (push (vector (gnus-group-full-name group server)
(string-to-number artno)
(string-to-number score))
artlist))))
@@ -1343,19 +1185,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 +1213,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
@@ -1398,7 +1232,7 @@ Tested with swish-e-2.0.1 on Windows NT 4.0."
score (match-string 3))
(when (string-match prefix dirnam)
(setq dirnam (replace-match "" t t dirnam)))
- (push (vector (nnir-group-full-name
+ (push (vector (gnus-group-full-name
(gnus-replace-in-string dirnam "/" ".") server)
(string-to-number artno)
(string-to-number score))
@@ -1420,10 +1254,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 +1317,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
@@ -1491,73 +1325,138 @@ Tested with Namazu 2.0.6 on a GNU/Linux system."
(directory (cadr (assoc sym (cddr method))))
(regexp (cdr (assoc 'query query)))
(grep-options (cdr (assoc 'grep-options query)))
+ (grouplist (or grouplist (nnir-get-active server)))
artlist)
(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 (gnus-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."
+ (let* ((case-fold-search t)
+ (qstring (cdr (assq 'query query)))
+ (server (cadr (gnus-server-to-method srv)))
+ (groupspec (mapconcat
+ (lambda (x)
+ (if (gnus-string-match-p "gmane" x)
+ (format "group:%s" (gnus-group-short-name x))
+ (error "Can't search non-gmane groups: %s" 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)))
+ (apply 'vector (nreverse (mm-delete-duplicates artlist)))))
;;; 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,107 +1464,67 @@ 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-categorize
+ (or gnus-group-marked
+ (if (gnus-group-group-name)
+ (list (gnus-group-group-name))
+ (cdr (assoc (gnus-group-topic-name)
+ gnus-topic-alist))))
+ gnus-group-server))))
+ (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
+ (or (and (eq nnir-search-engine 'imap)
+ (assq 'criteria q) q)
+ (setq q (nnir-read-parms q nnir-search-engine)))
+ q)
+ server (cadr 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))
-;; ))
-
-(defun nnir-group-full-name (shortname server)
- "For the given group name, return a full Gnus group name.
-The Gnus backend/server information is added."
- (gnus-group-prefixed-name shortname (gnus-server-to-method server)))
+ (nth 1 (assq key (cddr method))))
+ (t nil))))
(defun nnir-possibly-change-server (server)
(unless (and server (nnir-server-opened server))
(nnir-open-server server)))
-;; Data type article list.
-
-(defun nnir-artlist-length (artlist)
- "Returns number of articles in artlist."
- (length artlist))
-
-(defun nnir-artlist-article (artlist n)
- "Returns from ARTLIST the Nth artitem (counting starting at 1)."
- (elt artlist (1- n)))
-
-(defun nnir-artitem-group (artitem)
- "Returns the group from the ARTITEM."
- (elt artitem 0))
-
-(defun nnir-artlist-artitem-group (artlist n)
- "Returns from ARTLIST the group of the Nth artitem (counting from 1)."
- (nnir-artitem-group (nnir-artlist-article artlist n)))
-
-(defun nnir-artitem-number (artitem)
- "Returns the number from the ARTITEM."
- (elt artitem 1))
-
-(defun nnir-artlist-artitem-number (artlist n)
- "Returns from ARTLIST the number of the Nth artitem (counting from 1)."
- (nnir-artitem-number (nnir-artlist-article artlist n)))
-
-(defun nnir-artitem-rsv (artitem)
- "Returns the Retrieval Status Value (RSV, score) from the ARTITEM."
- (elt artitem 2))
-
-(defun nnir-artlist-artitem-rsv (artlist n)
- "Returns from ARTLIST the Retrieval Status Value of the Nth artitem
-\(counting from 1)."
- (nnir-artitem-rsv (nnir-artlist-article artlist n)))
;; unused?
(defun nnir-artlist-groups (artlist)
@@ -1679,9 +1538,73 @@ The Gnus backend/server information is added."
with-dups)
res))
+(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 (or (null nnir-ignored-newsgroups)
+ (string= nnir-ignored-newsgroups ""))
+ (delete-matching-lines nnir-ignored-newsgroups))
+ (if (eq (car method) 'nntp)
+ (while (not (eobp))
+ (ignore-errors
+ (push (mm-string-as-unibyte
+ (gnus-group-full-name
+ (buffer-substring
+ (point)
+ (progn
+ (skip-chars-forward "^ \t")
+ (point))) method))
+ groups))
+ (forward-line))
+ (while (not (eobp))
+ (ignore-errors
+ (push (mm-string-as-unibyte
+ (if (eq (char-after) ?\")
+ (gnus-group-full-name (read cur) method)
+ (let ((p (point)) (name ""))
+ (skip-chars-forward "^ \t\\\\")
+ (setq name (buffer-substring p (point)))
+ (while (eq (char-after) ?\\)
+ (setq p (1+ (point)))
+ (forward-char 2)
+ (skip-chars-forward "^ \t\\\\")
+ (setq name (concat name (buffer-substring
+ p (point)))))
+ (gnus-group-full-name name method))))
+ groups))
+ (forward-line)))))
+ groups))
+
+(defun nnir-registry-action (action data-header from &optional to method)
+ "Call `gnus-registry-action' with the original article group."
+ (gnus-registry-action
+ action
+ data-header
+ (nnir-article-group (mail-header-number data-header))
+ to
+ method))
+
+(defun nnir-mode ()
+ (when (eq (car (gnus-find-method-for-group gnus-newsgroup-name)) 'nnir)
+ (setq gnus-summary-line-format
+ (or nnir-summary-line-format gnus-summary-line-format))
+ (when (and (boundp 'gnus-registry-install)
+ (eq gnus-registry-install t))
+ (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action t)
+ (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action t)
+ (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action t)
+ (add-hook 'gnus-summary-article-delete-hook 'nnir-registry-action t t)
+ (add-hook 'gnus-summary-article-move-hook 'nnir-registry-action t t)
+ (add-hook 'gnus-summary-article-expire-hook 'nnir-registry-action t t))))
+
+
;; 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 57be1b45f11..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, 2011 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 b61260142bd..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, 2011 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 422d5ed5262..8906a036779 100644
--- a/lisp/gnus/nnmail.el
+++ b/lisp/gnus/nnmail.el
@@ -1,7 +1,6 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news, mail
@@ -25,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))))
@@ -104,7 +103,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 +266,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 +615,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 +676,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 +964,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 +1012,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 +1057,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 +1069,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 +1088,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 +1098,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 +1146,42 @@ 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))
+ (not (consp (car-safe 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 +1214,15 @@ 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)
+ (or (equal "" (nth 1 method))
+ (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))
@@ -1894,7 +1916,8 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(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)
+ (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..8e2cd4bdde3 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 :(
@@ -1565,7 +1559,7 @@ by nnmaildir-request-article.")
(t (signal (car err) (cdr err))))))
todo-marks))
set-action (lambda (article)
- (funcall add-action)
+ (funcall add-action article)
(mapcar (lambda (mark)
(unless (memq mark todo-marks)
(funcall del-mark mark)))
@@ -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 ffe221b8d00..b82d6c2ee7b 100644
--- a/lisp/gnus/nnmairix.el
+++ b/lisp/gnus/nnmairix.el
@@ -1,6 +1,6 @@
;;; nnmairix.el --- Mairix back end for Gnus, the Emacs newsreader
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: David Engster <dengste@eml.cc>
;; Keywords: mail searching
@@ -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 f37fa3618d6..aac5a064a7f 100644
--- a/lisp/gnus/nnmbox.el
+++ b/lisp/gnus/nnmbox.el
@@ -1,7 +1,6 @@
;;; nnmbox.el --- mail mbox access for Gnus
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
@@ -79,8 +78,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 +147,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 +171,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 +205,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 +249,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 +287,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 +358,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 +384,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 +404,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 +624,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 +639,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 +709,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 0f0116ad067..5fa1a89cf48 100644
--- a/lisp/gnus/nnmh.el
+++ b/lisp/gnus/nnmh.el
@@ -1,7 +1,6 @@
;;; nnmh.el --- mhspool access for Gnus
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
@@ -149,7 +148,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 +206,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 +257,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 +291,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 +316,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 +578,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 7144e64138a..399008cec1b 100644
--- a/lisp/gnus/nnml.el
+++ b/lisp/gnus/nnml.el
@@ -1,7 +1,7 @@
;;; nnml.el --- mail spool access for Gnus
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-2011 Free Software
+;; Foundation, Inc.
;; Authors: Didier Verna <didier@xemacs.org> (adding compaction)
;; Simon Josefsson <simon@josefsson.org> (adding MARKS)
@@ -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))
@@ -236,7 +235,11 @@ non-nil.")
(nnheader-article-to-file-alist
(setq gpath (nnml-group-pathname (car group-num)
nil server))))))
- (setq path (concat gpath (int-to-string (cdr group-num)))))
+ (nnml-update-file-alist)
+ (setq path (concat gpath (if nnml-use-compressed-files
+ (cdr (assq (cdr group-num)
+ nnml-article-file-alist))
+ (number-to-string (cdr group-num))))))
(setq path (nnml-article-to-file id)))
(cond
((not path)
@@ -255,7 +258,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 +286,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 +408,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 +440,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 +451,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 +464,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 +479,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 +614,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 +656,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 +689,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 +740,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 +772,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 +832,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 +884,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 +904,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 +914,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 +928,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 +939,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 +1001,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 +1022,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 +1037,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 +1237,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 +1319,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 637bc1790a1..bbe47fcf5c0 100644
--- a/lisp/gnus/nnoo.el
+++ b/lisp/gnus/nnoo.el
@@ -1,7 +1,6 @@
;;; nnoo.el --- OO Gnus Backends
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -322,5 +321,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..359050c356c
--- /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-2011 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 (nth 0 (gnus-registry-get-id-key id 'group)))
+ (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 568d2ee80fc..b12700fac64 100644
--- a/lisp/gnus/nnrss.el
+++ b/lisp/gnus/nnrss.el
@@ -1,7 +1,6 @@
;;; nnrss.el --- interfacing with RSS
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
;; Keywords: RSS
@@ -25,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))))
@@ -77,7 +76,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 +113,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 +129,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 +173,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 +191,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 +231,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 +312,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 +354,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 +454,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 +532,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 +556,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 +633,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 +673,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 +816,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 +933,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 +1016,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 +1055,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 c4025a78494..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, 2011 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 8bb6ca99c02..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, 2011 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 a92c336c799..6c23f41132f 100644
--- a/lisp/gnus/nnspool.el
+++ b/lisp/gnus/nnspool.el
@@ -1,7 +1,6 @@
;;; nnspool.el --- spool access for GNU Emacs
-;; Copyright (C) 1988, 1989, 1990, 1993, 1994, 1995, 1996, 1997, 1998,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+;; Copyright (C) 1988-1990, 1993-1998, 2000-2011
;; Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
@@ -109,8 +108,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 +207,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 +218,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 +339,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 +362,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 +398,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 +453,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 6eb97182c2f..aa4b9184dbb 100644
--- a/lisp/gnus/nntp.el
+++ b/lisp/gnus/nntp.el
@@ -1,8 +1,7 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1987-1990, 1992-1998, 2000-2011
+;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -26,6 +25,14 @@
;;; Code:
+;; For Emacs <22.2 and XEmacs.
+(eval-and-compile
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))
+ ;; In Emacs 24, `open-protocol-stream' is an autoloaded alias for
+ ;; `make-network-stream'.
+ (unless (fboundp 'open-protocol-stream)
+ (require 'proto-stream)))
+
(require 'nnheader)
(require 'nnoo)
(require 'gnus-util)
@@ -36,7 +43,7 @@
(eval-when-compile (require 'cl))
-(autoload 'auth-source-user-or-password "auth-source")
+(autoload 'auth-source-search "auth-source")
(defgroup nntp nil
"NNTP access for Gnus."
@@ -72,25 +79,27 @@ to innd, you could say something like:
You probably don't want to do that, though.")
(defvoo nntp-open-connection-function 'nntp-open-network-stream
- "*Function used for connecting to a remote system.
-It will be called with the buffer to output in as argument.
-
-Currently, five such functions are provided (please refer to their
-respective doc string for more information), three of them establishing
-direct connections to the nntp server, and two of them using an indirect
-host.
-
-Direct connections:
-- `nntp-open-network-stream' (the default),
-- `nntp-open-ssl-stream',
-- `nntp-open-tls-stream',
-- `nntp-open-netcat-stream'.
-- `nntp-open-telnet-stream'.
-
-Indirect connections:
-- `nntp-open-via-rlogin-and-netcat',
-- `nntp-open-via-rlogin-and-telnet',
-- `nntp-open-via-telnet-and-telnet'.")
+ "Method for connecting to a remote system.
+It should be a function, which is called with the output buffer
+as its single argument, or one of the following special values:
+
+- `nntp-open-network-stream' specifies a network connection,
+ upgrading to a TLS connection via STARTTLS if possible.
+- `nntp-open-plain-stream' specifies an unencrypted network
+ connection (no STARTTLS upgrade is attempted).
+- `nntp-open-ssl-stream' or `nntp-open-tls-stream' specify a TLS
+ network connection.
+
+Apart from the above special values, valid functions are as
+follows; please refer to their respective doc string for more
+information.
+For direct connections:
+- `nntp-open-netcat-stream'
+- `nntp-open-telnet-stream'
+For indirect connections:
+- `nntp-open-via-rlogin-and-netcat'
+- `nntp-open-via-rlogin-and-telnet'
+- `nntp-open-via-telnet-and-telnet'")
(defvoo nntp-never-echoes-commands nil
"*Non-nil means the nntp server never echoes commands.
@@ -263,6 +272,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,28 +306,13 @@ 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)
-(defvar nntp-ssl-program
- "openssl s_client -quiet -ssl3 -connect %s:%p"
-"A string containing commands for SSL connections.
-Within a string, %s is replaced with the server address and %p with
-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")
@@ -365,19 +364,6 @@ be restored and the command retried."
(throw 'nntp-with-open-group-error t))
-(defmacro nntp-insert-buffer-substring (buffer &optional start end)
- "Copy string from unibyte buffer to multibyte current buffer."
- (if (featurep 'xemacs)
- `(insert-buffer-substring ,buffer ,start ,end)
- `(if enable-multibyte-characters
- (insert (with-current-buffer ,buffer
- (mm-string-to-multibyte
- ,(if (or start end)
- `(buffer-substring (or ,start (point-min))
- (or ,end (point-max)))
- '(buffer-string)))))
- (insert-buffer-substring ,buffer ,start ,end))))
-
(defmacro nntp-copy-to-buffer (buffer start end)
"Copy string from unibyte current buffer to multibyte buffer."
(if (featurep 'xemacs)
@@ -403,7 +389,8 @@ be restored and the command retried."
(cond ((looking-at "480")
(nntp-handle-authinfo process))
((looking-at "482")
- (nnheader-report 'nntp (get 'nntp-authinfo-rejected 'error-message))
+ (nnheader-report 'nntp "%s"
+ (get 'nntp-authinfo-rejected 'error-message))
(signal 'nntp-authinfo-rejected nil))
((looking-at "^.*\n")
(delete-region (point) (progn (forward-line 1) (point)))))
@@ -434,7 +421,7 @@ be restored and the command retried."
(unless discard
(with-current-buffer buffer
(goto-char (point-max))
- (nntp-insert-buffer-substring (process-buffer process))
+ (nnheader-insert-buffer-substring (process-buffer process))
;; Nix out "nntp reading...." message.
(when nntp-have-messaged
(setq nntp-have-messaged nil)
@@ -777,6 +764,72 @@ command whose response triggered the error."
(nntp-copy-to-buffer nntp-server-buffer (point-min) (point-max))
'headers)))))
+(deffoo nntp-retrieve-group-data-early (server infos)
+ "Retrieve group info on INFOS."
+ (nntp-with-open-group nil server
+ (when (nntp-find-connection-buffer nntp-server-buffer)
+ ;; The first time this is run, this variable is `try'. So we
+ ;; try.
+ (when (eq nntp-server-list-active-group 'try)
+ (nntp-try-list-active
+ (gnus-group-real-name (gnus-info-group (car infos)))))
+ (with-current-buffer (nntp-find-connection-buffer nntp-server-buffer)
+ (erase-buffer)
+ (let ((nntp-inhibit-erase t)
+ (command (if nntp-server-list-active-group
+ "LIST ACTIVE" "GROUP")))
+ (dolist (info infos)
+ (nntp-send-command
+ nil command (gnus-group-real-name (gnus-info-group info)))))
+ (length infos)))))
+
+(deffoo nntp-finish-retrieve-group-infos (server infos count)
+ (nntp-with-open-group nil server
+ (let ((buf (nntp-find-connection-buffer nntp-server-buffer))
+ (method (gnus-find-method-for-group
+ (gnus-info-group (car infos))
+ (car infos)))
+ (received 0)
+ (last-point 1))
+ (when (and buf
+ count)
+ (with-current-buffer buf
+ (while (and (gnus-buffer-live-p buf)
+ (progn
+ (goto-char last-point)
+ ;; Count replies.
+ (while (re-search-forward
+ (if nntp-server-list-active-group
+ "^[.]"
+ "^[0-9]")
+ nil t)
+ (incf received))
+ (setq last-point (point))
+ (< received count)))
+ (nntp-accept-response))
+ ;; We now have all the entries. Remove CRs.
+ (nnheader-strip-cr)
+ (if (not nntp-server-list-active-group)
+ (progn
+ (nntp-copy-to-buffer nntp-server-buffer
+ (point-min) (point-max))
+ (gnus-groups-to-gnus-format method gnus-active-hashtb t))
+ ;; We have read active entries, so we just delete the
+ ;; superfluous gunk.
+ (goto-char (point-min))
+ (while (re-search-forward "^[.2-5]" nil t)
+ (delete-region (match-beginning 0)
+ (progn (forward-line 1) (point))))
+ (nntp-copy-to-buffer nntp-server-buffer (point-min) (point-max))
+ (with-current-buffer nntp-server-buffer
+ (gnus-active-to-gnus-format
+ ;; Kludge to use the extended method name if you have
+ ;; an extended one.
+ (if (consp (gnus-info-method (car infos)))
+ (gnus-info-method (car infos))
+ method)
+ gnus-active-hashtb nil t))))))))
+
(deffoo nntp-retrieve-groups (groups &optional server)
"Retrieve group info on GROUPS."
(nntp-with-open-group
@@ -930,7 +983,7 @@ command whose response triggered the error."
(narrow-to-region
(setq point (goto-char (point-max)))
(progn
- (nntp-insert-buffer-substring buf last-point (cdr entry))
+ (nnheader-insert-buffer-substring buf last-point (cdr entry))
(point-max)))
(setq last-point (cdr entry))
(nntp-decode-text)
@@ -962,16 +1015,15 @@ command whose response triggered the error."
(deffoo nntp-request-article (article &optional group server buffer command)
(nntp-with-open-group
- group server
+ group server
(when (nntp-send-command-and-decode
"\r?\n\\.\r?\n" "ARTICLE"
(if (numberp article) (int-to-string article) article))
- (if (and buffer
- (not (equal buffer nntp-server-buffer)))
- (with-current-buffer nntp-server-buffer
- (copy-to-buffer buffer (point-min) (point-max))
- (nntp-find-group-and-number group))
- (nntp-find-group-and-number group)))))
+ (when (and buffer
+ (not (equal buffer nntp-server-buffer)))
+ (with-current-buffer nntp-server-buffer
+ (copy-to-buffer buffer (point-min) (point-max))))
+ (nntp-find-group-and-number group))))
(deffoo nntp-request-head (article &optional group server)
(nntp-with-open-group
@@ -990,7 +1042,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 +1069,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 +1165,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 +1211,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,13 +1224,20 @@ 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-source-user-or-password '("login" "password") nntp-address "nntp"))
- (auth-user (nth 0 auth-info))
- (auth-passwd (nth 1 auth-info))
+ (auth-info
+ (nth 0 (auth-source-search :max 1
+ ;; TODO: allow the virtual server name too
+ :host nntp-address
+ :port '("119" "nntp"))))
+ (auth-user (plist-get auth-info :user))
+ (auth-passwd (plist-get auth-info :secret))
+ (auth-passwd (if (functionp auth-passwd)
+ (funcall auth-passwd)
+ auth-passwd))
(user (or
;; this is preferred to netrc-*
auth-user
@@ -1270,11 +1325,29 @@ password contained in '~/.nntp-authinfo'."
`(lambda ()
(nntp-kill-buffer ,pbuffer)))))
(process
- (condition-case ()
+ (condition-case err
(let ((coding-system-for-read nntp-coding-system-for-read)
- (coding-system-for-write nntp-coding-system-for-write))
- (funcall nntp-open-connection-function pbuffer))
- (error nil)
+ (coding-system-for-write nntp-coding-system-for-write)
+ (map '((nntp-open-network-stream network)
+ (network-only plain) ; compat
+ (nntp-open-plain-stream plain)
+ (nntp-open-ssl-stream tls)
+ (nntp-open-tls-stream tls))))
+ (if (assoc nntp-open-connection-function map)
+ (open-protocol-stream
+ "nntpd" pbuffer nntp-address nntp-port-number
+ :type (cadr (assoc nntp-open-connection-function map))
+ :end-of-command "^\\([2345]\\|[.]\\).*\n"
+ :capability-command "CAPABILITIES\r\n"
+ :success "^3"
+ :starttls-function
+ (lambda (capabilities)
+ (if (not (string-match "STARTTLS" capabilities))
+ nil
+ "STARTTLS\r\n")))
+ (funcall nntp-open-connection-function pbuffer)))
+ (error
+ (nnheader-report 'nntp ">>> %s" err))
(quit
(message "Quit opening connection to %s" nntp-address)
(nntp-kill-buffer pbuffer)
@@ -1282,10 +1355,18 @@ password contained in '~/.nntp-authinfo'."
nil))))
(when timer
(nnheader-cancel-timer timer))
+ (when (and process
+ (not (memq (process-status process) '(open run))))
+ (setq process nil))
(unless process
(nntp-kill-buffer pbuffer))
(when (and (buffer-name pbuffer)
process)
+ (when (and (fboundp 'set-network-process-option)
+ (eq (process-type process) 'network))
+ ;; Use TCP-keepalive so that connections that pass through a NAT router
+ ;; don't hang when left idle.
+ (set-network-process-option process :keepalive t))
(gnus-set-process-query-on-exit-flag process nil)
(if (and (nntp-wait-for process "^2.*\n" buffer nil t)
(memq (process-status process) '(open run)))
@@ -1302,40 +1383,6 @@ password contained in '~/.nntp-authinfo'."
(nntp-kill-buffer (process-buffer process))
nil))))
-(defun nntp-open-network-stream (buffer)
- (open-network-stream "nntpd" buffer nntp-address nntp-port-number))
-
-(autoload 'format-spec "format-spec")
-(autoload 'format-spec-make "format-spec")
-(autoload 'open-tls-stream "tls")
-
-(defun nntp-open-ssl-stream (buffer)
- (let* ((process-connection-type nil)
- (proc (start-process "nntpd" buffer
- shell-file-name
- shell-command-switch
- (format-spec nntp-ssl-program
- (format-spec-make
- ?s nntp-address
- ?p nntp-port-number)))))
- (gnus-set-process-query-on-exit-flag proc nil)
- (with-current-buffer buffer
- (let ((nntp-connection-alist (list proc buffer nil)))
- (nntp-wait-for-string "^\r*20[01]"))
- (beginning-of-line)
- (delete-region (point-min) (point))
- proc)))
-
-(defun nntp-open-tls-stream (buffer)
- (let ((proc (open-tls-stream "nntpd" buffer nntp-address nntp-port-number)))
- (gnus-set-process-query-on-exit-flag proc nil)
- (with-current-buffer buffer
- (let ((nntp-connection-alist (list proc buffer nil)))
- (nntp-wait-for-string "^\r*20[01]"))
- (beginning-of-line)
- (delete-region (point-min) (point))
- proc)))
-
(defun nntp-read-server-type ()
"Find out what the name of the server we have connected to is."
;; Wait for the status string to arrive.
@@ -1358,17 +1405,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
@@ -1427,7 +1464,7 @@ password contained in '~/.nntp-authinfo'."
(goto-char (point-max))
(save-restriction
(narrow-to-region (point) (point))
- (nntp-insert-buffer-substring buf start)
+ (nnheader-insert-buffer-substring buf start)
(when decode
(nntp-decode-text))))))
;; report it.
@@ -1446,7 +1483,7 @@ password contained in '~/.nntp-authinfo'."
(let ((message (buffer-string)))
(while (string-match "[\r\n]+" message)
(setq message (replace-match " " t t message)))
- (nnheader-report 'nntp message)
+ (nnheader-report 'nntp "%s" message)
message))
(defun nntp-accept-process-output (process)
@@ -1655,7 +1692,7 @@ password contained in '~/.nntp-authinfo'."
(when in-process-buffer-p
(set-buffer buf)
(goto-char (point-max))
- (nntp-insert-buffer-substring process-buffer)
+ (nnheader-insert-buffer-substring process-buffer)
(set-buffer process-buffer)
(erase-buffer)
(set-buffer buf))
@@ -1773,7 +1810,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 +2055,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 +2222,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 f446697462a..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, 2011 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 0b22314273b..0cc53ad2332 100644
--- a/lisp/gnus/nnvirtual.el
+++ b/lisp/gnus/nnvirtual.el
@@ -1,7 +1,6 @@
;;; nnvirtual.el --- virtual newsgroups access for Gnus
-;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-2011 Free Software Foundation, Inc.
;; Author: David Moore <dmoore@ucsd.edu>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -93,8 +92,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 +168,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 +212,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 +246,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 +256,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 +294,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 +331,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 +663,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 +682,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 +800,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 1c6bc42b4e0..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, 2011 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 22b34160088..f190bb7cffa 100644
--- a/lisp/gnus/nnweb.el
+++ b/lisp/gnus/nnweb.el
@@ -1,7 +1,6 @@
;;; nnweb.el --- retrieving articles via web search engines
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -104,8 +103,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 +123,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 +145,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 +181,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 +206,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 +395,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 +451,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 +516,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 +603,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 b144363c69a..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, 2011 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 775dd0c929c..6f12d3d63e1 100644
--- a/lisp/gnus/pop3.el
+++ b/lisp/gnus/pop3.el
@@ -1,7 +1,6 @@
;;; pop3.el --- Post Office Protocol (RFC 1460) interface
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Richard L. Pieri <ratinox@peorth.gweep.net>
;; Maintainer: FSF
@@ -33,6 +32,14 @@
;;; Code:
+(eval-when-compile (require 'cl))
+
+(eval-and-compile
+ ;; In Emacs 24, `open-protocol-stream' is an autoloaded alias for
+ ;; `make-network-stream'.
+ (unless (fboundp 'open-protocol-stream)
+ (require 'proto-stream)))
+
(require 'mail-utils)
(defvar parse-time-months)
@@ -81,6 +88,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 +130,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 +144,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 +241,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."
@@ -197,10 +264,6 @@ to %s might not give the result you'd expect." pop3-leave-mail-on-server)
(pop3-quit process)
message-count))
-(autoload 'open-tls-stream "tls")
-(autoload 'starttls-open-stream "starttls")
-(autoload 'starttls-negotiate "starttls") ; avoid warning
-
(defcustom pop3-stream-type nil
"*Transport security type for POP3 connexions.
This may be either nil (plain connexion), `ssl' (use an
@@ -214,77 +277,52 @@ 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)))
+ result)
+ (with-current-buffer
+ (get-buffer-create (concat " trace of POP session to "
+ mailhost))
(erase-buffer)
(setq pop3-read-point (point-min))
- (setq process
- (cond
- ((or (eq pop3-stream-type 'ssl)
- (and (not pop3-stream-type) (member port '(995 "pop3s"))))
- ;; gnutls-cli, openssl don't accept service names
- (if (or (equal port "pop3s")
- (null port))
- (setq port 995))
- (let ((process (open-tls-stream "POP" (current-buffer)
- mailhost port)))
- (when process
- ;; There's a load of info printed that needs deleting.
- (let ((again 't))
- ;; repeat until
- ;; - either we received the +OK line
- ;; - or accept-process-output timed out without getting
- ;; anything
- (while (and again
- (setq again (memq (process-status process)
- '(open run))))
- (setq again (pop3-accept-process-output process))
- (goto-char (point-max))
- (forward-line -1)
- (cond ((looking-at "\\+OK")
- (setq again nil)
- (delete-region (point-min) (point)))
- ((not again)
- (pop3-quit process)
- (error "POP SSL connexion failed")))))
- process)))
- ((eq pop3-stream-type 'starttls)
- ;; gnutls-cli, openssl don't accept service names
- (if (equal port "pop3")
- (setq port 110))
- ;; Delay STLS until server greeting is read (Bug#7438).
- (starttls-open-stream "POP" (current-buffer)
- mailhost (or port 110)))
- (t
- (open-network-stream "POP" (current-buffer) mailhost port))))
- (let ((response (pop3-read-response process t)))
- (setq pop3-timestamp
- (substring response (or (string-match "<" response) 0)
- (+ 1 (or (string-match ">" response) -1)))))
- (when (eq pop3-stream-type 'starttls)
- (pop3-send-command process "STLS")
- (let ((response (pop3-read-response process t)))
- (if (and response (string-match "+OK" response))
- (starttls-negotiate process)
- (pop3-quit process)
- (error "POP server doesn't support starttls"))))
- process)))
+ (setq result
+ (open-protocol-stream
+ "POP" (current-buffer) mailhost port
+ :type (cond
+ ((or (eq pop3-stream-type 'ssl)
+ (and (not pop3-stream-type)
+ (member port '(995 "pop3s"))))
+ 'tls)
+ (t
+ (or pop3-stream-type 'network)))
+ :capability-command "CAPA\r\n"
+ :end-of-command "^\\.\r?\n\\|^\\(-ERR\\|+OK \\).*\n"
+ :success "^\\+OK.*\n"
+ :return-list t
+ :starttls-function
+ (lambda (capabilities)
+ (and (string-match "\\bSTLS\\b" capabilities)
+ "STLS\r\n"))))
+ (when result
+ (let ((response (plist-get (cdr result) :greeting)))
+ (setq pop3-timestamp
+ (substring response (or (string-match "<" response) 0)
+ (+ 1 (or (string-match ">" response) -1)))))
+ (pop3-set-process-query-on-exit-flag (car result) nil)
+ (car result)))))
;; 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 +338,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 +438,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 +486,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 +528,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 +565,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 +658,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 b2338194eb3..584e24177af 100644
--- a/lisp/gnus/qp.el
+++ b/lisp/gnus/qp.el
@@ -1,7 +1,6 @@
;;; qp.el --- Quoted-Printable functions
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: mail, extensions
@@ -164,5 +163,4 @@ encode lines starting with \"From\"."
(provide 'qp)
-;; arch-tag: db89e52a-e4a1-4b69-926f-f434f04216ba
;;; qp.el ends here
diff --git a/lisp/gnus/registry.el b/lisp/gnus/registry.el
new file mode 100644
index 00000000000..b5cc3ec0e2b
--- /dev/null
+++ b/lisp/gnus/registry.el
@@ -0,0 +1,476 @@
+;;; registry.el --- Track and remember data items by various fields
+
+;; Copyright (C) 2011 Free Software Foundation, Inc.
+
+;; Author: Teodor Zlatanov <tzz@lifelogs.com>
+;; Keywords: data
+
+;; 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 provides a general-purpose EIEIO-based registry
+;; database with persistence, initialized with these fields:
+
+;; version: a float, 0.1 currently (don't change it)
+
+;; max-hard: an integer, default 5000000
+
+;; max-soft: an integer, default 50000
+
+;; precious: a list of symbols
+
+;; tracked: a list of symbols
+
+;; tracker: a hashtable tuned for 100 symbols to track (you should
+;; only access this with the :lookup2-function and the
+;; :lookup2+-function)
+
+;; data: a hashtable with default size 10K and resize threshold 2.0
+;; (this reflects the expected usage so override it if you know better)
+
+;; ...plus methods to do all the work: `registry-search',
+;; `registry-lookup', `registry-lookup-secondary',
+;; `registry-lookup-secondary-value', `registry-insert',
+;; `registry-delete', `registry-prune', `registry-size' which see
+
+;; and with the following properties:
+
+;; Every piece of data has a unique ID and some general-purpose fields
+;; (F1=D1, F2=D2, F3=(a b c)...) expressed as an alist, e.g.
+
+;; ((F1 D1) (F2 D2) (F3 a b c))
+
+;; Note that whether a field has one or many pieces of data, the data
+;; is always a list of values.
+
+;; The user decides which fields are "precious", F2 for example. At
+;; PRUNE TIME (when the :prune-function is called), the registry will
+;; trim any entries without the F2 field until the size is :max-soft
+;; or less. No entries with the F2 field will be removed at PRUNE
+;; TIME.
+
+;; When an entry is inserted, the registry will reject new entries
+;; if they bring it over the max-hard limit, even if they have the F2
+;; field.
+
+;; The user decides which fields are "tracked", F1 for example. Any
+;; new entry is then indexed by all the tracked fields so it can be
+;; quickly looked up that way. The data is always a list (see example
+;; above) and each list element is indexed.
+
+;; Precious and tracked field names must be symbols. All other
+;; fields can be any other Emacs Lisp types.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(eval-when-compile
+ (when (null (ignore-errors (require 'ert)))
+ (defmacro* ert-deftest (name () &body docstring-keys-and-body))))
+
+(ignore-errors
+ (require 'ert))
+(eval-and-compile
+ (or (ignore-errors (progn
+ (require 'eieio)
+ (require 'eieio-base)))
+ ;; gnus-fallback-lib/ from gnus/lisp/gnus-fallback-lib
+ (ignore-errors
+ (let ((load-path (cons (expand-file-name
+ "gnus-fallback-lib/eieio"
+ (file-name-directory (locate-library "gnus")))
+ load-path)))
+ (require 'eieio)
+ (require 'eieio-base)))
+ (error
+ "eieio not found in `load-path' or gnus-fallback-lib/ directory.")))
+
+(defclass registry-db (eieio-persistent)
+ ((version :initarg :version
+ :initform 0.1
+ :type float
+ :custom float
+ :documentation "The registry version.")
+ (max-hard :initarg :max-hard
+ :initform 5000000
+ :type integer
+ :custom integer
+ :documentation "Never accept more than this many elements.")
+ (max-soft :initarg :max-soft
+ :initform 50000
+ :type integer
+ :custom integer
+ :documentation "Prune as much as possible to get to this size.")
+ (tracked :initarg :tracked
+ :initform nil
+ :type t
+ :documentation "The tracked (indexed) fields, a list of symbols.")
+ (precious :initarg :precious
+ :initform nil
+ :type t
+ :documentation "The precious fields, a list of symbols.")
+ (tracker :initarg :tracker
+ :type hash-table
+ :documentation "The field tracking hashtable.")
+ (data :initarg :data
+ :type hash-table
+ :documentation "The data hashtable.")))
+
+(eval-and-compile
+ (defmethod initialize-instance :AFTER ((this registry-db) slots)
+ "Set value of data slot of THIS after initialization."
+ (with-slots (data tracker) this
+ (unless (member :data slots)
+ (setq data
+ (make-hash-table :size 10000 :rehash-size 2.0 :test 'equal)))
+ (unless (member :tracker slots)
+ (setq tracker (make-hash-table :size 100 :rehash-size 2.0)))))
+
+ (defmethod registry-lookup ((db registry-db) keys)
+ "Search for KEYS in the registry-db THIS.
+Returns a alist of the key followed by the entry in a list, not a cons cell."
+ (let ((data (oref db :data)))
+ (delq nil
+ (mapcar
+ (lambda (k)
+ (when (gethash k data)
+ (list k (gethash k data))))
+ keys))))
+
+ (defmethod registry-lookup-breaks-before-lexbind ((db registry-db) keys)
+ "Search for KEYS in the registry-db THIS.
+Returns a alist of the key followed by the entry in a list, not a cons cell."
+ (let ((data (oref db :data)))
+ (delq nil
+ (loop for key in keys
+ when (gethash key data)
+ collect (list key (gethash key data))))))
+
+ (defmethod registry-lookup-secondary ((db registry-db) tracksym
+ &optional create)
+ "Search for TRACKSYM in the registry-db THIS.
+When CREATE is not nil, create the secondary index hashtable if needed."
+ (let ((h (gethash tracksym (oref db :tracker))))
+ (if h
+ h
+ (when create
+ (puthash tracksym
+ (make-hash-table :size 800 :rehash-size 2.0 :test 'equal)
+ (oref db :tracker))
+ (gethash tracksym (oref db :tracker))))))
+
+ (defmethod registry-lookup-secondary-value ((db registry-db) tracksym val
+ &optional set)
+ "Search for TRACKSYM with value VAL in the registry-db THIS.
+When SET is not nil, set it for VAL (use t for an empty list)."
+ ;; either we're asked for creation or there should be an existing index
+ (when (or set (registry-lookup-secondary db tracksym))
+ ;; set the entry if requested,
+ (when set
+ (puthash val (if (eq t set) '() set)
+ (registry-lookup-secondary db tracksym t)))
+ (gethash val (registry-lookup-secondary db tracksym)))))
+
+(defun registry--match (mode entry check-list)
+ ;; for all members
+ (when check-list
+ (let ((key (nth 0 (nth 0 check-list)))
+ (vals (cdr-safe (nth 0 check-list)))
+ found)
+ (while (and key vals (not found))
+ (setq found (case mode
+ (:member
+ (member (car-safe vals) (cdr-safe (assoc key entry))))
+ (:regex
+ (string-match (car vals)
+ (mapconcat
+ 'prin1-to-string
+ (cdr-safe (assoc key entry))
+ "\0"))))
+ vals (cdr-safe vals)))
+ (or found
+ (registry--match mode entry (cdr-safe check-list))))))
+
+(eval-and-compile
+ (defmethod registry-search ((db registry-db) &rest spec)
+ "Search for SPEC across the registry-db THIS.
+For example calling with :member '(a 1 2) will match entry '((a 3 1)).
+Calling with :all t (any non-nil value) will match all.
+Calling with :regex '\(a \"h.llo\") will match entry '((a \"hullo\" \"bye\").
+The test order is to check :all first, then :member, then :regex."
+ (when db
+ (let ((all (plist-get spec :all))
+ (member (plist-get spec :member))
+ (regex (plist-get spec :regex)))
+ (loop for k being the hash-keys of (oref db :data)
+ using (hash-values v)
+ when (or
+ ;; :all non-nil returns all
+ all
+ ;; member matching
+ (and member (registry--match :member v member))
+ ;; regex matching
+ (and regex (registry--match :regex v regex)))
+ collect k))))
+
+ (defmethod registry-delete ((db registry-db) keys assert &rest spec)
+ "Delete KEYS from the registry-db THIS.
+If KEYS is nil, use SPEC to do a search.
+Updates the secondary ('tracked') indices as well.
+With assert non-nil, errors out if the key does not exist already."
+ (let* ((data (oref db :data))
+ (keys (or keys
+ (apply 'registry-search db spec)))
+ (tracked (oref db :tracked)))
+
+ (dolist (key keys)
+ (let ((entry (gethash key data)))
+ (when assert
+ (assert entry nil
+ "Key %s does not exists in database" key))
+ ;; clean entry from the secondary indices
+ (dolist (tr tracked)
+ ;; is this tracked symbol indexed?
+ (when (registry-lookup-secondary db tr)
+ ;; for every value in the entry under that key...
+ (dolist (val (cdr-safe (assq tr entry)))
+ (let* ((value-keys (registry-lookup-secondary-value
+ db tr val)))
+ (when (member key value-keys)
+ ;; override the previous value
+ (registry-lookup-secondary-value
+ db tr val
+ ;; with the indexed keys MINUS the current key
+ ;; (we pass t when the list is empty)
+ (or (delete key value-keys) t)))))))
+ (remhash key data)))
+ keys))
+
+ (defmethod registry-full ((db registry-db))
+ "Checks if registry-db THIS is full."
+ (>= (registry-size db)
+ (oref db :max-hard)))
+
+ (defmethod registry-insert ((db registry-db) key entry)
+ "Insert ENTRY under KEY into the registry-db THIS.
+Updates the secondary ('tracked') indices as well.
+Errors out if the key exists already."
+
+ (assert (not (gethash key (oref db :data))) nil
+ "Key already exists in database")
+
+ (assert (not (registry-full db))
+ nil
+ "registry max-hard size limit reached")
+
+ ;; store the entry
+ (puthash key entry (oref db :data))
+
+ ;; store the secondary indices
+ (dolist (tr (oref db :tracked))
+ ;; for every value in the entry under that key...
+ (dolist (val (cdr-safe (assq tr entry)))
+ (let* ((value-keys (registry-lookup-secondary-value db tr val)))
+ (pushnew key value-keys :test 'equal)
+ (registry-lookup-secondary-value db tr val value-keys))))
+ entry)
+
+ (defmethod registry-reindex ((db registry-db))
+ "Rebuild the secondary indices of registry-db THIS."
+ (let ((count 0)
+ (expected (* (length (oref db :tracked)) (registry-size db))))
+ (dolist (tr (oref db :tracked))
+ (let (values)
+ (maphash
+ (lambda (key v)
+ (incf count)
+ (when (and (< 0 expected)
+ (= 0 (mod count 1000)))
+ (message "reindexing: %d of %d (%.2f%%)"
+ count expected (/ (* 100 count) expected)))
+ (dolist (val (cdr-safe (assq tr v)))
+ (let* ((value-keys (registry-lookup-secondary-value db tr val)))
+ (push key value-keys)
+ (registry-lookup-secondary-value db tr val value-keys))))
+ (oref db :data))))))
+
+ (defmethod registry-size ((db registry-db))
+ "Returns the size of the registry-db object THIS.
+This is the key count of the :data slot."
+ (hash-table-count (oref db :data)))
+
+ (defmethod registry-prune ((db registry-db) &optional sortfun)
+ "Prunes the registry-db object THIS.
+Removes only entries without the :precious keys if it can,
+then removes oldest entries first.
+Returns the number of deleted entries.
+If SORTFUN is given, tries to keep entries that sort *higher*.
+SORTFUN is passed only the two keys so it must look them up directly."
+ (dolist (collector '(registry-prune-soft-candidates
+ registry-prune-hard-candidates))
+ (let* ((size (registry-size db))
+ (collected (funcall collector db))
+ (limit (nth 0 collected))
+ (candidates (nth 1 collected))
+ ;; sort the candidates if SORTFUN was given
+ (candidates (if sortfun (sort candidates sortfun) candidates))
+ (candidates-count (length candidates))
+ ;; are we over max-soft?
+ (prune-needed (> size limit)))
+
+ ;; while we have more candidates than we need to remove...
+ (while (and (> candidates-count (- size limit)) candidates)
+ (decf candidates-count)
+ (setq candidates (cdr candidates)))
+
+ (registry-delete db candidates nil)
+ (length candidates))))
+
+ (defmethod registry-prune-soft-candidates ((db registry-db))
+ "Collects pruning candidates from the registry-db object THIS.
+Proposes only entries without the :precious keys."
+ (let* ((precious (oref db :precious))
+ (precious-p (lambda (entry-key)
+ (cdr (memq (car entry-key) precious))))
+ (data (oref db :data))
+ (limit (oref db :max-soft))
+ (candidates (loop for k being the hash-keys of data
+ using (hash-values v)
+ when (notany precious-p v)
+ collect k)))
+ (list limit candidates)))
+
+ (defmethod registry-prune-hard-candidates ((db registry-db))
+ "Collects pruning candidates from the registry-db object THIS.
+Proposes any entries over the max-hard limit minus 10."
+ (let* ((data (oref db :data))
+ ;; prune to 10 below the max-hard limit so we're not
+ ;; pruning all the time
+ (limit (- (oref db :max-hard) 10))
+ (candidates (loop for k being the hash-keys of data
+ collect k)))
+ (list limit candidates))))
+
+(ert-deftest registry-instantiation-test ()
+ (should (registry-db "Testing")))
+
+(ert-deftest registry-match-test ()
+ (let ((entry '((hello "goodbye" "bye") (blank))))
+
+ (message "Testing :regex matching")
+ (should (registry--match :regex entry '((hello "nye" "bye"))))
+ (should (registry--match :regex entry '((hello "good"))))
+ (should-not (registry--match :regex entry '((hello "nye"))))
+ (should-not (registry--match :regex entry '((hello))))
+
+ (message "Testing :member matching")
+ (should (registry--match :member entry '((hello "bye"))))
+ (should (registry--match :member entry '((hello "goodbye"))))
+ (should-not (registry--match :member entry '((hello "good"))))
+ (should-not (registry--match :member entry '((hello "nye"))))
+ (should-not (registry--match :member entry '((hello)))))
+ (message "Done with matching testing."))
+
+(defun registry-make-testable-db (n &optional name file)
+ (let* ((db (registry-db
+ (or name "Testing")
+ :file (or file "unused")
+ :max-hard n
+ :max-soft 0 ; keep nothing not precious
+ :precious '(extra more-extra)
+ :tracked '(sender subject groups))))
+ (dotimes (i n)
+ (registry-insert db i `((sender "me")
+ (subject "about you")
+ (more-extra) ; empty data key should be pruned
+ ;; first 5 entries will NOT have this extra data
+ ,@(when (< 5 i) (list (list 'extra "more data")))
+ (groups ,(number-to-string i)))))
+ db))
+
+(ert-deftest registry-usage-test ()
+ (let* ((n 100)
+ (db (registry-make-testable-db n)))
+ (message "size %d" n)
+ (should (= n (registry-size db)))
+ (message "max-hard test")
+ (should-error (registry-insert db "new" '()))
+ (message "Individual lookup")
+ (should (= 58 (caadr (registry-lookup db '(1 58 99)))))
+ (message "Grouped individual lookup")
+ (should (= 3 (length (registry-lookup db '(1 58 99)))))
+ (when (boundp 'lexical-binding)
+ (message "Individual lookup (breaks before lexbind)")
+ (should (= 58
+ (caadr (registry-lookup-breaks-before-lexbind db '(1 58 99)))))
+ (message "Grouped individual lookup (breaks before lexbind)")
+ (should (= 3
+ (length (registry-lookup-breaks-before-lexbind db
+ '(1 58 99))))))
+ (message "Search")
+ (should (= n (length (registry-search db :all t))))
+ (should (= n (length (registry-search db :member '((sender "me"))))))
+ (message "Secondary index search")
+ (should (= n (length (registry-lookup-secondary-value db 'sender "me"))))
+ (should (equal '(74) (registry-lookup-secondary-value db 'groups "74")))
+ (message "Delete")
+ (should (registry-delete db '(1) t))
+ (decf n)
+ (message "Search after delete")
+ (should (= n (length (registry-search db :all t))))
+ (message "Secondary search after delete")
+ (should (= n (length (registry-lookup-secondary-value db 'sender "me"))))
+ ;; (message "Pruning")
+ ;; (let* ((tokeep (registry-search db :member '((extra "more data"))))
+ ;; (count (- n (length tokeep)))
+ ;; (pruned (registry-prune db))
+ ;; (prune-count (length pruned)))
+ ;; (message "Expecting to prune %d entries and pruned %d"
+ ;; count prune-count)
+ ;; (should (and (= count 5)
+ ;; (= count prune-count))))
+ (message "Done with usage testing.")))
+
+(ert-deftest registry-persistence-test ()
+ (let* ((n 100)
+ (tempfile (make-temp-file "registry-persistence-"))
+ (name "persistence tester")
+ (db (registry-make-testable-db n name tempfile))
+ size back)
+ (message "Saving to %s" tempfile)
+ (eieio-persistent-save db)
+ (setq size (nth 7 (file-attributes tempfile)))
+ (message "Saved to %s: size %d" tempfile size)
+ (should (< 0 size))
+ (with-temp-buffer
+ (insert-file-contents-literally tempfile)
+ (should (looking-at (concat ";; Object "
+ name
+ "\n;; EIEIO PERSISTENT OBJECT"))))
+ (message "Reading object back")
+ (setq back (eieio-persistent-read tempfile))
+ (should back)
+ (message "Read object back: %d keys, expected %d==%d"
+ (registry-size back) n (registry-size db))
+ (should (= (registry-size back) n))
+ (should (= (registry-size back) (registry-size db)))
+ (delete-file tempfile))
+ (message "Done with persistence testing."))
+
+(provide 'registry)
+;;; registry.el ends here
diff --git a/lisp/gnus/rfc1843.el b/lisp/gnus/rfc1843.el
index 11a163aac88..019dc6ed8a2 100644
--- a/lisp/gnus/rfc1843.el
+++ b/lisp/gnus/rfc1843.el
@@ -1,7 +1,6 @@
;;; rfc1843.el --- HZ (rfc1843) decoding
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
;; Keywords: news HZ HZ+ mail i18n
@@ -32,7 +31,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 +165,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 +190,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 126ba33e5c1..d9aaf88b046 100644
--- a/lisp/gnus/rfc2045.el
+++ b/lisp/gnus/rfc2045.el
@@ -1,7 +1,6 @@
;;; rfc2045.el --- Functions for decoding rfc2045 headers
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; This file is part of GNU Emacs.
@@ -39,5 +38,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 67dd9bd47ca..e82192b91d6 100644
--- a/lisp/gnus/rfc2047.el
+++ b/lisp/gnus/rfc2047.el
@@ -1,7 +1,6 @@
;;; rfc2047.el --- functions for encoding and decoding rfc2047 messages
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
@@ -31,7 +30,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 +341,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 +422,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 +650,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 +824,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 +846,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 +885,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 +918,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 +1160,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 6afe5d939fd..158cf4bae22 100644
--- a/lisp/gnus/rfc2104.el
+++ b/lisp/gnus/rfc2104.el
@@ -1,7 +1,6 @@
;;; rfc2104.el --- RFC2104 Hashed Message Authentication Codes
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Simon Josefsson <jas@pdc.kth.se>
;; Keywords: mail
@@ -122,5 +121,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 65590bb6955..306b67cd7c1 100644
--- a/lisp/gnus/rfc2231.el
+++ b/lisp/gnus/rfc2231.el
@@ -1,7 +1,6 @@
;;; rfc2231.el --- Functions for decoding rfc2231 headers
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; This file is part of GNU Emacs.
@@ -185,11 +184,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 +303,4 @@ the result of this function."
(provide 'rfc2231)
-;; arch-tag: c3ab751d-d108-406a-b301-68882ad8cd63
;;; rfc2231.el ends here
diff --git a/lisp/gnus/rtree.el b/lisp/gnus/rtree.el
new file mode 100644
index 00000000000..869ca4f0069
--- /dev/null
+++ b/lisp/gnus/rtree.el
@@ -0,0 +1,278 @@
+;;; rtree.el --- functions for manipulating range trees
+
+;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
+
+;; Author: 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:
+
+;; A "range tree" is a binary tree that stores ranges. They are
+;; similar to interval trees, but do not allow overlapping intervals.
+
+;; A range is an ordered list of number intervals, like this:
+
+;; ((10 . 25) 56 78 (98 . 201))
+
+;; Common operations, like lookup, deletion and insertion are O(n) in
+;; a range, but an rtree is O(log n) in all these operations.
+;; Transformation between a range and an rtree is O(n).
+
+;; The rtrees are quite simple. The structure of each node is
+
+;; (cons (cons low high) (cons left right))
+
+;; That is, they are three cons cells, where the car of the top cell
+;; is the actual range, and the cdr has the left and right child. The
+;; rtrees aren't automatically balanced, but are balanced when
+;; created, and can be rebalanced when deemed necessary.
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl))
+
+(defmacro rtree-make-node ()
+ `(list (list nil) nil))
+
+(defmacro rtree-set-left (node left)
+ `(setcar (cdr ,node) ,left))
+
+(defmacro rtree-set-right (node right)
+ `(setcdr (cdr ,node) ,right))
+
+(defmacro rtree-set-range (node range)
+ `(setcar ,node ,range))
+
+(defmacro rtree-low (node)
+ `(caar ,node))
+
+(defmacro rtree-high (node)
+ `(cdar ,node))
+
+(defmacro rtree-set-low (node number)
+ `(setcar (car ,node) ,number))
+
+(defmacro rtree-set-high (node number)
+ `(setcdr (car ,node) ,number))
+
+(defmacro rtree-left (node)
+ `(cadr ,node))
+
+(defmacro rtree-right (node)
+ `(cddr ,node))
+
+(defmacro rtree-range (node)
+ `(car ,node))
+
+(defsubst rtree-normalise-range (range)
+ (when (numberp range)
+ (setq range (cons range range)))
+ range)
+
+(defun rtree-make (range)
+ "Make an rtree from RANGE."
+ ;; Normalize the range.
+ (unless (listp (cdr-safe range))
+ (setq range (list range)))
+ (rtree-make-1 (cons nil range) (length range)))
+
+(defun rtree-make-1 (range length)
+ (let ((mid (/ length 2))
+ (node (rtree-make-node)))
+ (when (> mid 0)
+ (rtree-set-left node (rtree-make-1 range mid)))
+ (rtree-set-range node (rtree-normalise-range (cadr range)))
+ (setcdr range (cddr range))
+ (when (> (- length mid 1) 0)
+ (rtree-set-right node (rtree-make-1 range (- length mid 1))))
+ node))
+
+(defun rtree-memq (tree number)
+ "Return non-nil if NUMBER is present in TREE."
+ (while (and tree
+ (not (and (>= number (rtree-low tree))
+ (<= number (rtree-high tree)))))
+ (setq tree
+ (if (< number (rtree-low tree))
+ (rtree-left tree)
+ (rtree-right tree))))
+ tree)
+
+(defun rtree-add (tree number)
+ "Add NUMBER to TREE."
+ (while tree
+ (cond
+ ;; It's already present, so we don't have to do anything.
+ ((and (>= number (rtree-low tree))
+ (<= number (rtree-high tree)))
+ (setq tree nil))
+ ((< number (rtree-low tree))
+ (cond
+ ;; Extend the low range.
+ ((= number (1- (rtree-low tree)))
+ (rtree-set-low tree number)
+ ;; Check whether we need to merge this node with the child.
+ (when (and (rtree-left tree)
+ (= (rtree-high (rtree-left tree)) (1- number)))
+ ;; Extend the range to the low from the child.
+ (rtree-set-low tree (rtree-low (rtree-left tree)))
+ ;; The child can't have a right child, so just transplant the
+ ;; child's left tree to our left tree.
+ (rtree-set-left tree (rtree-left (rtree-left tree))))
+ (setq tree nil))
+ ;; Descend further to the left.
+ ((rtree-left tree)
+ (setq tree (rtree-left tree)))
+ ;; Add a new node.
+ (t
+ (let ((new-node (rtree-make-node)))
+ (rtree-set-low new-node number)
+ (rtree-set-high new-node number)
+ (rtree-set-left tree new-node)
+ (setq tree nil)))))
+ (t
+ (cond
+ ;; Extend the high range.
+ ((= number (1+ (rtree-high tree)))
+ (rtree-set-high tree number)
+ ;; Check whether we need to merge this node with the child.
+ (when (and (rtree-right tree)
+ (= (rtree-low (rtree-right tree)) (1+ number)))
+ ;; Extend the range to the high from the child.
+ (rtree-set-high tree (rtree-high (rtree-right tree)))
+ ;; The child can't have a left child, so just transplant the
+ ;; child's left right to our right tree.
+ (rtree-set-right tree (rtree-right (rtree-right tree))))
+ (setq tree nil))
+ ;; Descend further to the right.
+ ((rtree-right tree)
+ (setq tree (rtree-right tree)))
+ ;; Add a new node.
+ (t
+ (let ((new-node (rtree-make-node)))
+ (rtree-set-low new-node number)
+ (rtree-set-high new-node number)
+ (rtree-set-right tree new-node)
+ (setq tree nil))))))))
+
+(defun rtree-delq (tree number)
+ "Remove NUMBER from TREE destructively. Returns the new tree."
+ (let ((result tree)
+ prev)
+ (while tree
+ (cond
+ ((< number (rtree-low tree))
+ (setq prev tree
+ tree (rtree-left tree)))
+ ((> number (rtree-high tree))
+ (setq prev tree
+ tree (rtree-right tree)))
+ ;; The number is in this node.
+ (t
+ (cond
+ ;; The only entry; delete the node.
+ ((= (rtree-low tree) (rtree-high tree))
+ (cond
+ ;; Two children. Replace with successor value.
+ ((and (rtree-left tree) (rtree-right tree))
+ (let ((parent tree)
+ (successor (rtree-right tree)))
+ (while (rtree-left successor)
+ (setq parent successor
+ successor (rtree-left successor)))
+ ;; We now have the leftmost child of our right child.
+ (rtree-set-range tree (rtree-range successor))
+ ;; Transplant the child (if any) to the parent.
+ (rtree-set-left parent (rtree-right successor))))
+ (t
+ (let ((rest (or (rtree-left tree)
+ (rtree-right tree))))
+ ;; One or zero children. Remove the node.
+ (cond
+ ((null prev)
+ (setq result rest))
+ ((eq (rtree-left prev) tree)
+ (rtree-set-left prev rest))
+ (t
+ (rtree-set-right prev rest)))))))
+ ;; The lowest in the range; just adjust.
+ ((= number (rtree-low tree))
+ (rtree-set-low tree (1+ number)))
+ ;; The highest in the range; just adjust.
+ ((= number (rtree-high tree))
+ (rtree-set-high tree (1- number)))
+ ;; We have to split this range.
+ (t
+ (let ((new-node (rtree-make-node)))
+ (rtree-set-low new-node (rtree-low tree))
+ (rtree-set-high new-node (1- number))
+ (rtree-set-low tree (1+ number))
+ (cond
+ ;; Two children; insert the new node as the predecessor
+ ;; node.
+ ((and (rtree-left tree) (rtree-right tree))
+ (let ((predecessor (rtree-left tree)))
+ (while (rtree-right predecessor)
+ (setq predecessor (rtree-right predecessor)))
+ (rtree-set-right predecessor new-node)))
+ ((rtree-left tree)
+ (rtree-set-right new-node tree)
+ (rtree-set-left new-node (rtree-left tree))
+ (rtree-set-left tree nil)
+ (cond
+ ((null prev)
+ (setq result new-node))
+ ((eq (rtree-left prev) tree)
+ (rtree-set-left prev new-node))
+ (t
+ (rtree-set-right prev new-node))))
+ (t
+ (rtree-set-left tree new-node))))))
+ (setq tree nil))))
+ result))
+
+(defun rtree-extract (tree)
+ "Convert TREE to range form."
+ (let (stack result)
+ (while (or stack
+ tree)
+ (if tree
+ (progn
+ (push tree stack)
+ (setq tree (rtree-right tree)))
+ (setq tree (pop stack))
+ (push (if (= (rtree-low tree)
+ (rtree-high tree))
+ (rtree-low tree)
+ (rtree-range tree))
+ result)
+ (setq tree (rtree-left tree))))
+ result))
+
+(defun rtree-length (tree)
+ "Return the number of numbers stored in TREE."
+ (if (null tree)
+ 0
+ (+ (rtree-length (rtree-left tree))
+ (1+ (- (rtree-high tree)
+ (rtree-low tree)))
+ (rtree-length (rtree-right tree)))))
+
+(provide 'rtree)
+
+;;; rtree.el ends here
diff --git a/lisp/gnus/score-mode.el b/lisp/gnus/score-mode.el
index 8deb5f4d642..a7ed6bc0cb8 100644
--- a/lisp/gnus/score-mode.el
+++ b/lisp/gnus/score-mode.el
@@ -1,7 +1,6 @@
;;; score-mode.el --- mode for editing Gnus score files
-;; Copyright (C) 1996, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 2001-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news, mail
@@ -116,5 +115,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..36dd65f4a2d
--- /dev/null
+++ b/lisp/gnus/shr-color.el
@@ -0,0 +1,361 @@
+;;; shr-color.el --- Simple HTML Renderer color management
+
+;; Copyright (C) 2010-2011 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-to-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-name-to-rgb fg))
+ (bg-norm (color-name-to-rgb bg)))
+ (if (or (null fg-norm)
+ (null bg-norm))
+ (list bg fg)
+ (let* ((fg-lab (apply 'color-srgb-to-lab fg-norm))
+ (bg-lab (apply 'color-srgb-to-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-to-srgb bg-lab))))
+ (apply 'format "#%02x%02x%02x"
+ (mapcar (lambda (x) (* (max (min 1 x) 0) 255))
+ (apply 'color-lab-to-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..75c6d5d9ce7
--- /dev/null
+++ b/lisp/gnus/shr.el
@@ -0,0 +1,1337 @@
+;;; shr.el --- Simple HTML Renderer
+
+;; Copyright (C) 2010-2011 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)
+
+(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.
+May either be an integer specifying a fixed width in characters,
+or nil, meaning that the full width of the window should be
+used."
+ :type '(choice (integer :tag "Fixed width in characters")
+ (const :tag "Use the width of the window" nil))
+ :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.")
+
+(defvar shr-put-image-function 'shr-put-image
+ "Function called to put image and alt string.")
+
+(defface shr-strike-through '((t (:strike-through t)))
+ "Font for <s> elements."
+ :group 'shr)
+
+(defface shr-link
+ '((t (:inherit link)))
+ "Font for link elements."
+ :group 'shr)
+
+;;; 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-stylesheet nil)
+(defvar shr-base nil)
+
+(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.
+
+(defun shr-visit-file (file)
+ (interactive "fHTML file name: ")
+ (pop-to-buffer "*html*")
+ (erase-buffer)
+ (shr-insert-document
+ (with-temp-buffer
+ (insert-file-contents file)
+ (libxml-parse-html-region (point-min) (point-max)))))
+
+;;;###autoload
+(defun shr-insert-document (dom)
+ (setq shr-content-cache nil)
+ (let ((shr-state nil)
+ (shr-start nil)
+ (shr-base nil)
+ (shr-width (or shr-width (window-width))))
+ (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))))
+ (shr-stylesheet shr-stylesheet)
+ (start (point)))
+ (when style
+ (if (string-match "color" style)
+ (setq shr-stylesheet (nconc (shr-parse-style style)
+ shr-stylesheet))
+ (setq style nil)))
+ (if (fboundp function)
+ (funcall function (cdr dom))
+ (shr-generic (cdr dom)))
+ ;; If style is set, then this node has set the color.
+ (when style
+ (shr-colorize-region start (point)
+ (cdr (assq 'color shr-stylesheet))
+ (cdr (assq 'background-color shr-stylesheet))))))
+
+(defun shr-generic (cont)
+ (dolist (sub cont)
+ (cond
+ ((eq (car sub) 'text)
+ (shr-insert (cdr sub)))
+ ((listp (cdr sub))
+ (shr-descend sub)))))
+
+(defmacro shr-char-breakable-p (char)
+ "Return non-nil if a line can be broken before and after CHAR."
+ `(aref fill-find-break-point-function-table ,char))
+(defmacro shr-char-nospace-p (char)
+ "Return non-nil if no space is required before and after CHAR."
+ `(aref fill-nospace-between-words-table ,char))
+
+;; KINSOKU is a Japanese word meaning a rule that should not be violated.
+;; In Emacs, it is a term used for characters, e.g. punctuation marks,
+;; parentheses, and so on, that should not be placed in the beginning
+;; of a line or the end of a line.
+(defmacro shr-char-kinsoku-bol-p (char)
+ "Return non-nil if a line ought not to begin with CHAR."
+ `(aref (char-category-set ,char) ?>))
+(defmacro shr-char-kinsoku-eol-p (char)
+ "Return non-nil if a line ought not to end with CHAR."
+ `(aref (char-category-set ,char) ?<))
+(unless (shr-char-kinsoku-bol-p (make-char 'japanese-jisx0208 33 35))
+ (load "kinsoku" nil t))
+
+(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))
+ ;; 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 (> (current-column) shr-indentation)
+ (eq (preceding-char) ? )
+ (or (= (line-beginning-position) (1- (point)))
+ (and (shr-char-breakable-p
+ (setq prev (char-after (- (point) 2))))
+ (shr-char-kinsoku-bol-p prev))
+ (and (shr-char-nospace-p prev)
+ (shr-char-nospace-p (aref elem 0)))))
+ (delete-char -1)))
+ ;; 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)))
+ (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 ((bp (point))
+ failed)
+ (while (not (or (setq failed (= (current-column) shr-indentation))
+ (eq (preceding-char) ? )
+ (eq (following-char) ? )
+ (shr-char-breakable-p (preceding-char))
+ (shr-char-breakable-p (following-char))
+ (if (eq (preceding-char) ?')
+ (not (memq (char-after (- (point) 2))
+ (list nil ?\n ? )))
+ (and (shr-char-kinsoku-bol-p (preceding-char))
+ (shr-char-breakable-p (following-char))
+ (not (shr-char-kinsoku-bol-p (following-char)))))
+ (shr-char-kinsoku-eol-p (following-char))))
+ (backward-char 1))
+ (if (and (not (or failed (eolp)))
+ (eq (preceding-char) ?'))
+ (while (not (or (setq failed (eolp))
+ (eq (following-char) ? )
+ (shr-char-breakable-p (following-char))
+ (shr-char-kinsoku-eol-p (following-char))))
+ (forward-char 1)))
+ (if failed
+ ;; There's no breakable point, so we give it up.
+ (let (found)
+ (goto-char bp)
+ (unless shr-kinsoku-shorten
+ (while (and (setq found (re-search-forward
+ "\\(\\c>\\)\\| \\|\\c<\\|\\c|"
+ (line-end-position) 'move))
+ (eq (preceding-char) ?')))
+ (if (and found (not (match-beginning 1)))
+ (goto-char (match-beginning 0)))))
+ (or
+ (eolp)
+ ;; 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 ? )))
+ (shr-char-kinsoku-eol-p (preceding-char)))
+ (backward-char 1))
+ (when (setq failed (= (current-column) shr-indentation))
+ ;; There's no breakable point that doesn't violate kinsoku,
+ ;; so we look for the second best position.
+ (while (and (progn
+ (forward-char 1)
+ (<= (current-column) shr-width))
+ (progn
+ (setq bp (point))
+ (shr-char-kinsoku-eol-p (following-char)))))
+ (goto-char bp)))
+ ((shr-char-kinsoku-eol-p (preceding-char))
+ (if (shr-char-kinsoku-eol-p (following-char))
+ ;; There are consecutive kinsoku-eol characters.
+ (setq failed t)
+ (let ((count 4))
+ (while
+ (progn
+ (backward-char 1)
+ (and (> (setq count (1- count)) 0)
+ (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
+ (or (shr-char-kinsoku-eol-p (preceding-char))
+ (shr-char-kinsoku-bol-p (following-char)))))))
+ (if (setq failed (= (current-column) shr-indentation))
+ ;; There's no breakable point that doesn't violate kinsoku,
+ ;; so we go to the second best position.
+ (if (looking-at "\\(\\c<+\\)\\c<")
+ (goto-char (match-end 1))
+ (forward-char 1)))))
+ (t
+ (if (shr-char-kinsoku-bol-p (preceding-char))
+ ;; There are consecutive kinsoku-bol characters.
+ (setq failed t)
+ (let ((count 4))
+ (while (and (>= (setq count (1- count)) 0)
+ (shr-char-kinsoku-bol-p (following-char))
+ (shr-char-breakable-p (following-char)))
+ (forward-char 1))))))
+ (when (eq (following-char) ? )
+ (forward-char 1))))
+ (not failed)))
+
+(defun shr-expand-url (url)
+ (cond
+ ;; Absolute URL.
+ ((or (not url)
+ (string-match "\\`[a-z]*:" url)
+ (not shr-base))
+ url)
+ ((and (not (string-match "/\\'" shr-base))
+ (not (string-match "\\`/" url)))
+ (concat shr-base "/" url))
+ (t
+ (concat shr-base url))))
+
+(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
+ (save-excursion
+ (let ((alt (buffer-substring start end))
+ (inhibit-read-only t))
+ (delete-region start end)
+ (goto-char start)
+ (funcall shr-put-image-function data alt)))))))
+ (kill-buffer (current-buffer)))
+
+(defun shr-put-image (data alt)
+ "Put image DATA with a string ALT. Return image."
+ (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 "*")))
+ image)
+ (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)))
+ (when (and (fboundp 'create-animated-image)
+ (eq (image-type data nil t) 'gif))
+ (setq image (create-animated-image data 'gif t)))
+ 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. Note that START and END should be merkers."
+ `(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)
+ (funcall shr-put-image-function
+ image (buffer-substring-no-properties start end))
+ (delete-region (point) 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 &optional title)
+ (widget-convert-button
+ 'url-link start (point)
+ :help-echo (if title (format "%s (%s)" url title) url)
+ :keymap shr-map
+ url)
+ (put-text-property start (point) 'face 'shr-link)
+ (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-colorize-region (start end fg &optional bg)
+ (when (or fg bg)
+ (let ((new-colors (shr-color-check fg bg)))
+ (when new-colors
+ (when fg
+ (shr-put-color start end :foreground (cadr new-colors)))
+ (when bg
+ (shr-put-color start end :background (car new-colors))))
+ new-colors)))
+
+;; Put a color in the region, but avoid putting colors on blank
+;; text at the start of the line, and the newline at the end, to avoid
+;; ugliness. Also, don't overwrite any existing color information,
+;; since this can be called recursively, and we want the "inner" color
+;; to win.
+(defun shr-put-color (start end type color)
+ (save-excursion
+ (goto-char start)
+ (while (< (point) end)
+ (when (and (bolp)
+ (not (eq type :background)))
+ (skip-chars-forward " "))
+ (when (> (line-end-position) (point))
+ (shr-put-color-1 (point) (min (line-end-position) end) type color))
+ (if (< (line-end-position) end)
+ (forward-line 1)
+ (goto-char end)))
+ (when (and (eq type :background)
+ (= shr-table-depth 0))
+ (shr-expand-newlines start end color))))
+
+(defun shr-expand-newlines (start end color)
+ (save-restriction
+ ;; Skip past all white space at the start and ends.
+ (goto-char start)
+ (skip-chars-forward " \t\n")
+ (beginning-of-line)
+ (setq start (point))
+ (goto-char end)
+ (skip-chars-backward " \t\n")
+ (forward-line 1)
+ (setq end (point))
+ (narrow-to-region start end)
+ (let ((width (shr-natural-width))
+ column)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (end-of-line)
+ (when (and (< (setq column (current-column)) width)
+ (< (setq column (shr-previous-newline-padding-width column))
+ width))
+ (let ((overlay (make-overlay (point) (1+ (point)))))
+ (overlay-put overlay 'before-string
+ (concat
+ (mapconcat
+ (lambda (overlay)
+ (let ((string (plist-get
+ (overlay-properties overlay)
+ 'before-string)))
+ (if (not string)
+ ""
+ (overlay-put overlay 'before-string "")
+ string)))
+ (overlays-at (point))
+ "")
+ (propertize (make-string (- width column) ? )
+ 'face (list :background color))))))
+ (forward-line 1)))))
+
+(defun shr-previous-newline-padding-width (width)
+ (let ((overlays (overlays-at (point)))
+ (previous-width 0))
+ (if (null overlays)
+ width
+ (dolist (overlay overlays)
+ (setq previous-width
+ (+ previous-width
+ (length (plist-get (overlay-properties overlay)
+ 'before-string)))))
+ (+ width previous-width))))
+
+(defun shr-put-color-1 (start end type color)
+ (let* ((old-props (get-text-property start 'face))
+ (do-put (and (listp old-props)
+ (not (memq type old-props))))
+ change)
+ (while (< start end)
+ (setq change (next-single-property-change start 'face nil end))
+ (when do-put
+ (put-text-property start change 'face
+ (nconc (list type color) old-props)))
+ (setq old-props (get-text-property change 'face))
+ (setq do-put (and (listp old-props)
+ (not (memq type old-props))))
+ (setq start change))
+ (when (and do-put
+ (> end start))
+ (put-text-property start end 'face
+ (nconc (list type color old-props))))))
+
+;;; Tag-specific rendering rules.
+
+(defun shr-tag-body (cont)
+ (let* ((start (point))
+ (fgcolor (cdr (or (assq :fgcolor cont)
+ (assq :text cont))))
+ (bgcolor (cdr (assq :bgcolor cont)))
+ (shr-stylesheet (list (cons 'color fgcolor)
+ (cons 'background-color bgcolor))))
+ (shr-generic cont)
+ (shr-colorize-region start (point) fgcolor bgcolor)))
+
+(defun shr-tag-style (cont)
+ )
+
+(defun shr-tag-script (cont)
+ )
+
+(defun shr-tag-sup (cont)
+ (let ((start (point)))
+ (shr-generic cont)
+ (put-text-property start (point) 'display '(raise 0.5))))
+
+(defun shr-tag-sub (cont)
+ (let ((start (point)))
+ (shr-generic cont)
+ (put-text-property start (point) 'display '(raise -0.5))))
+
+(defun shr-tag-label (cont)
+ (shr-generic cont)
+ (shr-ensure-paragraph))
+
+(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-s (cont)
+ (shr-fontize-cont cont 'shr-strike-through))
+
+(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-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-base (cont)
+ (setq shr-base (cdr (assq :href cont))))
+
+(defun shr-tag-a (cont)
+ (let ((url (cdr (assq :href cont)))
+ (title (cdr (assq :title cont)))
+ (start (point))
+ shr-start)
+ (shr-generic cont)
+ (shr-urlify (or shr-start start) (shr-expand-url url) title)))
+
+(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 (shr-expand-url 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 (shr-expand-url 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 (shr-expand-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)
+ (funcall shr-put-image-function 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))
+ (funcall shr-put-image-function (shr-get-image-data url) alt))
+ (t
+ (insert alt)
+ (funcall
+ (if (fboundp 'url-queue-retrieve)
+ 'url-queue-retrieve
+ '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-stylesheet (nconc (list (cons 'color color))
+ shr-stylesheet)))
+ (shr-generic cont)
+ (when color
+ (shr-colorize-region start (point) color
+ (cdr (assq 'background-color shr-stylesheet))))))
+
+;;; 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)))
+ (start (point))
+ (shr-stylesheet (nconc (list (cons 'background-color bgcolor))
+ shr-stylesheet))
+ (nheader (if header (shr-max-columns header)))
+ (nbody (if body (shr-max-columns body)))
+ (nfooter (if footer (shr-max-columns footer))))
+ (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)))))
+ (when bgcolor
+ (shr-colorize-region start (point) (cdr (assq 'color shr-stylesheet))
+ bgcolor))))
+
+(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)
+ (let ((start (point)))
+ (insert (make-string (string-width (car lines)) ? )
+ shr-table-vertical-line)
+ (when (nth 4 column)
+ (shr-put-color start (1- (point)) :background (nth 4 column))))
+ (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)
+ (with-temp-buffer
+ (let ((bgcolor (cdr (assq :bgcolor cont)))
+ (fgcolor (cdr (assq :fgcolor cont)))
+ (style (cdr (assq :style cont)))
+ (shr-stylesheet shr-stylesheet)
+ overlays actual-colors)
+ (when style
+ (setq style (and (string-match "color" style)
+ (shr-parse-style style))))
+ (when bgcolor
+ (setq style (nconc (list (cons 'background-color bgcolor)) style)))
+ (when fgcolor
+ (setq style (nconc (list (cons 'color fgcolor)) style)))
+ (when style
+ (setq shr-stylesheet (append style shr-stylesheet)))
+ (let ((cache (cdr (assoc (cons width cont) shr-content-cache))))
+ (if cache
+ (progn
+ (insert (car cache))
+ (let ((end (length (car cache))))
+ (dolist (overlay (cadr cache))
+ (let ((new-overlay
+ (make-overlay (1+ (- end (nth 0 overlay)))
+ (1+ (- end (nth 1 overlay)))))
+ (properties (nth 2 overlay)))
+ (while properties
+ (overlay-put new-overlay
+ (pop properties) (pop properties)))))))
+ (let ((shr-width width)
+ (shr-indentation 0))
+ (shr-descend (cons 'td cont)))
+ (delete-region
+ (point)
+ (+ (point)
+ (skip-chars-backward " \t\n")))
+ (push (list (cons width cont) (buffer-string)
+ (shr-overlays-in-region (point-min) (point-max)))
+ 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)))
+ (when style
+ (setq actual-colors
+ (shr-colorize-region
+ (point-min) (point-max)
+ (cdr (assq 'color shr-stylesheet))
+ (cdr (assq 'background-color shr-stylesheet))))))
+ (if fill
+ (list max
+ (count-lines (point-min) (point-max))
+ (split-string (buffer-string) "\n")
+ (shr-collect-overlays)
+ (car actual-colors))
+ (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 fcf8bfc575b..5c2e775a211 100644
--- a/lisp/gnus/sieve-manage.el
+++ b/lisp/gnus/sieve-manage.el
@@ -1,7 +1,6 @@
;;; sieve-manage.el --- Implementation of the managesive protocol in elisp
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;; Author: Simon Josefsson <simon@josefsson.org>
@@ -43,7 +42,6 @@
;; `sieve-manage-close'
;; close a server connection.
;;
-;; `sieve-manage-authenticate'
;; `sieve-manage-listscripts'
;; `sieve-manage-deletescript'
;; `sieve-manage-getscript'
@@ -51,14 +49,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 +69,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 +78,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-search "auth-source")
;; User customizable variables:
@@ -100,11 +97,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 +150,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 +184,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 +269,77 @@ 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* ((auth-info (auth-source-search :host sieve-manage-server
+ :port "sieve"
+ :max 1
+ :create t))
+ (user-name (or (plist-get (nth 0 auth-info) :user) ""))
+ (user-password (or (plist-get (nth 0 auth-info) :secret) ""))
+ (user-password (if (functionp user-password)
+ (funcall user-password)
+ user-password))
+ (client (sasl-make-client (sasl-find-mechanism (list mech))
+ user-name "sieve" sieve-manage-server))
+ (sasl-read-passphrase
+ ;; We *need* to copy the password, because sasl will modify it
+ ;; somehow.
+ `(lambda (prompt) ,(copy-sequence 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,13 +394,14 @@ 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))))
+ (or port (setq port sieve-manage-default-port))
+ (setq buffer (or buffer (format " *sieve* %s:%s" server port)))
(with-current-buffer (get-buffer-create buffer)
(mapc 'make-local-variable sieve-manage-local-variables)
(sieve-manage-disable-multibyte)
(buffer-disable-undo)
(setq sieve-manage-server (or server sieve-manage-server))
- (setq sieve-manage-port (or port sieve-manage-port))
+ (setq sieve-manage-port port)
(setq sieve-manage-stream (or stream sieve-manage-stream))
(message "sieve: Connecting to %s..." sieve-manage-server)
(if (let ((sieve-manage-stream
@@ -506,6 +452,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 +486,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 +645,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 dfbfdde6b57..efd28affacb 100644
--- a/lisp/gnus/sieve-mode.el
+++ b/lisp/gnus/sieve-mode.el
@@ -1,7 +1,6 @@
;;; sieve-mode.el --- Sieve code editing commands for Emacs
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;; Author: Simon Josefsson <simon@josefsson.org>
@@ -49,7 +48,6 @@
(autoload 'sieve-manage "sieve")
(autoload 'sieve-upload "sieve")
-(require 'easymenu)
(eval-when-compile
(require 'font-lock))
@@ -186,6 +184,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 +215,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 6f235eecf6b..2111d34eac5 100644
--- a/lisp/gnus/sieve.el
+++ b/lisp/gnus/sieve.el
@@ -1,6 +1,6 @@
;;; sieve.el --- Utilities to manage sieve scripts
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;; Author: Simon Josefsson <simon@josefsson.org>
@@ -98,39 +98,40 @@ require \"fileinto\";
(defvar sieve-manage-buffer nil)
(defvar sieve-buffer-header-end nil)
+(defvar sieve-buffer-script-name nil
+ "The real script name of the buffer.")
+(make-local-variable 'sieve-buffer-script-name)
;; Sieve-manage mode:
-(defvar sieve-manage-mode-map nil
+(defvar sieve-manage-mode-map
+ (let ((map (make-sparse-keymap)))
+ ;; various
+ (define-key map "?" 'sieve-help)
+ (define-key map "h" 'sieve-help)
+ (define-key map "q" 'sieve-bury-buffer)
+ ;; activating
+ (define-key map "m" 'sieve-activate)
+ (define-key map "u" 'sieve-deactivate)
+ (define-key map "\M-\C-?" 'sieve-deactivate-all)
+ ;; navigation keys
+ (define-key map "\C-p" 'sieve-prev-line)
+ (define-key map [up] 'sieve-prev-line)
+ (define-key map "\C-n" 'sieve-next-line)
+ (define-key map [down] 'sieve-next-line)
+ (define-key map " " 'sieve-next-line)
+ (define-key map "n" 'sieve-next-line)
+ (define-key map "p" 'sieve-prev-line)
+ (define-key map "\C-m" 'sieve-edit-script)
+ (define-key map "f" 'sieve-edit-script)
+ (define-key map "o" 'sieve-edit-script-other-window)
+ (define-key map "r" 'sieve-remove)
+ (define-key map "q" 'sieve-manage-quit)
+ (define-key map [(down-mouse-2)] 'sieve-edit-script)
+ (define-key map [(down-mouse-3)] 'sieve-manage-mode-menu)
+ map)
"Keymap for `sieve-manage-mode'.")
-(if sieve-manage-mode-map
- ()
- (setq sieve-manage-mode-map (make-sparse-keymap))
- (suppress-keymap sieve-manage-mode-map)
- ;; various
- (define-key sieve-manage-mode-map "?" 'sieve-help)
- (define-key sieve-manage-mode-map "h" 'sieve-help)
- (define-key sieve-manage-mode-map "q" 'sieve-bury-buffer)
- ;; activating
- (define-key sieve-manage-mode-map "m" 'sieve-activate)
- (define-key sieve-manage-mode-map "u" 'sieve-deactivate)
- (define-key sieve-manage-mode-map "\M-\C-?" 'sieve-deactivate-all)
- ;; navigation keys
- (define-key sieve-manage-mode-map "\C-p" 'sieve-prev-line)
- (define-key sieve-manage-mode-map [up] 'sieve-prev-line)
- (define-key sieve-manage-mode-map "\C-n" 'sieve-next-line)
- (define-key sieve-manage-mode-map [down] 'sieve-next-line)
- (define-key sieve-manage-mode-map " " 'sieve-next-line)
- (define-key sieve-manage-mode-map "n" 'sieve-next-line)
- (define-key sieve-manage-mode-map "p" 'sieve-prev-line)
- (define-key sieve-manage-mode-map "\C-m" 'sieve-edit-script)
- (define-key sieve-manage-mode-map "f" 'sieve-edit-script)
- (define-key sieve-manage-mode-map "o" 'sieve-edit-script-other-window)
- (define-key sieve-manage-mode-map "r" 'sieve-remove)
- (define-key sieve-manage-mode-map [(down-mouse-2)] 'sieve-edit-script)
- (define-key sieve-manage-mode-map [(down-mouse-3)] 'sieve-manage-mode-menu))
-
(easy-menu-define sieve-manage-mode-menu sieve-manage-mode-map
"Sieve Menu."
'("Manage Sieve"
@@ -138,21 +139,21 @@ require \"fileinto\";
["Activate script" sieve-activate t]
["Deactivate script" sieve-deactivate t]))
-(define-derived-mode sieve-manage-mode fundamental-mode "SIEVE"
+(define-derived-mode sieve-manage-mode fundamental-mode "Sieve-manage"
"Mode used for sieve script management."
- (setq mode-name "SIEVE")
(buffer-disable-undo (current-buffer))
(setq truncate-lines t)
(easy-menu-add sieve-manage-mode-menu sieve-manage-mode-map))
(put 'sieve-manage-mode 'mode-class 'special)
-;; This is necessary to allow correct handling of \\[cvs-mode-diff-map]
-;; in substitute-command-keys.
-;(fset 'sieve-manage-mode-map sieve-manage-mode-map)
-
;; Commands used in sieve-manage mode:
+(defun sieve-manage-quit ()
+ "Quit."
+ (interactive)
+ (kill-buffer (current-buffer)))
+
(defun sieve-activate (&optional pos)
(interactive "d")
(let ((name (sieve-script-at-point)) err)
@@ -204,7 +205,10 @@ require \"fileinto\";
(switch-to-buffer (get-buffer-create "template.siv"))
(insert sieve-template))
(sieve-mode)
- (message "Press C-c C-l to upload script to server.")))
+ (setq sieve-buffer-script-name name)
+ (message
+ (substitute-command-keys
+ "Press \\[sieve-upload] to upload script to server."))))
(defmacro sieve-change-region (&rest body)
"Turns off sieve-region before executing BODY, then re-enables it after.
@@ -320,11 +324,13 @@ 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
+ (or ;; open server
+ (set (make-local-variable 'sieve-manage-buffer)
+ (sieve-manage-open server))
+ (error "Error opening server %s" server))
+ (sieve-manage-authenticate)))
(defun sieve-refresh-scriptlist ()
(interactive)
@@ -335,13 +341,18 @@ Server : " server ":" (or port "2000") "
;; get list of script names and print them
(let ((scripts (sieve-manage-listscripts sieve-manage-buffer)))
(if (null scripts)
- (insert (format (concat "No scripts on server, press RET on %s to "
- "create a new script.\n") sieve-new-script))
- (insert (format (concat "%d script%s on server, press RET on a script "
- "name edits it, or\npress RET on %s to create "
- "a new script.\n") (length scripts)
- (if (eq (length scripts) 1) "" "s")
- sieve-new-script)))
+ (insert
+ (substitute-command-keys
+ (format
+ "No scripts on server, press \\[sieve-edit-script] on %s to create a new script.\n"
+ sieve-new-script)))
+ (insert
+ (substitute-command-keys
+ (format (concat "%d script%s on server, press \\[sieve-edit-script] on a script "
+ "name edits it, or\npress \\[sieve-edit-script] on %s to create "
+ "a new script.\n") (length scripts)
+ (if (eq (length scripts) 1) "" "s")
+ sieve-new-script))))
(save-excursion
(sieve-insert-scripts (list sieve-new-script))
(sieve-insert-scripts scripts)))
@@ -361,15 +372,15 @@ Server : " server ":" (or port "2000") "
;;;###autoload
(defun sieve-upload (&optional name)
(interactive)
- (unless name
- (setq name (buffer-name)))
(when (or (get-buffer sieve-buffer) (call-interactively 'sieve-manage))
(let ((script (buffer-string)) err)
(with-current-buffer (get-buffer sieve-buffer)
- (setq err (sieve-manage-putscript name script sieve-manage-buffer))
+ (setq err (sieve-manage-putscript
+ (or name sieve-buffer-script-name (buffer-name))
+ script sieve-manage-buffer))
(if (sieve-manage-ok-p err)
- (message (concat
- "Sieve upload done. Use `C-c RET' to manage scripts."))
+ (message (substitute-command-keys
+ "Sieve upload done. Use \\[sieve-manage] to manage scripts."))
(message "Sieve upload failed: %s" (nth 2 err)))))))
;;;###autoload
@@ -380,5 +391,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 0692966fbff..2f5c74220ea 100644
--- a/lisp/gnus/smiley.el
+++ b/lisp/gnus/smiley.el
@@ -1,7 +1,6 @@
;;; smiley.el --- displaying smiley faces
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Author: Dave Love <fx@gnu.org>
;; Keywords: news mail multimedia
@@ -102,7 +101,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 +119,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 +227,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 0ae7bbb5c84..5a7079883e6 100644
--- a/lisp/gnus/smime.el
+++ b/lisp/gnus/smime.el
@@ -1,7 +1,6 @@
;;; smime.el --- S/MIME support library
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Author: Simon Josefsson <simon@josefsson.org>
;; Keywords: SMIME X.509 PEM OpenSSL
@@ -119,7 +118,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 +370,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 +425,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 +450,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 +496,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 +584,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 +644,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 +664,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 +696,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 +716,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 4b492f02fab..95b5fb578f4 100644
--- a/lisp/gnus/spam-report.el
+++ b/lisp/gnus/spam-report.el
@@ -1,7 +1,6 @@
;;; spam-report.el --- Reporting spam
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Ted Zlatanov <tzz@lifelogs.com>
;; Keywords: network, spam, mail, gmane, report
@@ -95,12 +94,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 +108,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 +255,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 +266,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 +291,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 +383,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 afa0d502bc5..b56d0c416ef 100644
--- a/lisp/gnus/spam-stat.el
+++ b/lisp/gnus/spam-stat.el
@@ -1,6 +1,6 @@
;;; spam-stat.el --- detecting spam based on statistics
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Alex Schroeder <alex@gnu.org>
;; Keywords: network
@@ -557,6 +557,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 +673,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 585f78d6d44..88e2037f5e7 100644
--- a/lisp/gnus/spam-wash.el
+++ b/lisp/gnus/spam-wash.el
@@ -1,6 +1,6 @@
;;; spam-wash.el --- wash spam before analysis
-;; Copyright (C) 2004, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2004, 2007-2011 Free Software Foundation, Inc.
;; Author: Andrew Cohen <cohen@andy.bu.edu>
;; Keywords: mail
@@ -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 8d7ed9fdd06..cbffeeab69e 100644
--- a/lisp/gnus/spam.el
+++ b/lisp/gnus/spam.el
@@ -1,7 +1,6 @@
;;; spam.el --- Identifying spam
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Maintainer: Ted Zlatanov <tzz@lifelogs.com>
@@ -39,15 +38,15 @@
;;{{{ 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))))
(eval-when-compile (require 'cl))
-(require 'message) ;for the message-fetch-field functions
+(require 'message) ;for the message-fetch-field functions
(require 'gnus-sum)
-(require 'gnus-uu) ; because of key prefix issues
+(require 'gnus-uu) ; because of key prefix issues
;;; for the definitions of group content classification and spam processors
(require 'gnus)
@@ -69,9 +68,9 @@
;; autoload gnus-registry
(autoload 'gnus-registry-group-count "gnus-registry")
-(autoload 'gnus-registry-add-group "gnus-registry")
-(autoload 'gnus-registry-store-extra-entry "gnus-registry")
-(autoload 'gnus-registry-fetch-extra "gnus-registry")
+(autoload 'gnus-registry-get-id-key "gnus-registry")
+(autoload 'gnus-registry-set-id-key "gnus-registry")
+(autoload 'gnus-registry-handle-action "gnus-registry")
;; autoload dns-query
(autoload 'dns-query "dns")
@@ -93,12 +92,16 @@ Populated by `spam-install-backend-super'.")
"Exit behavior at the time of summary exit.
Note that setting the `spam-use-move' or `spam-use-copy' backends on
a group through group/topic parameters overrides this mechanism."
- :type '(choice (const 'default :tag
- "Move spam out of all groups. Move ham out of spam groups.")
- (const 'move-all :tag
- "Move spam out of all groups. Move ham out of all groups.")
- (const 'move-none :tag
- "Never move spam or ham out of any groups."))
+ :type '(choice
+ (const
+ 'default
+ :tag "Move spam out of all groups and ham out of spam groups.")
+ (const
+ 'move-all
+ :tag "Move spam out of all groups and ham out of all groups.")
+ (const
+ 'move-none
+ :tag "Never move spam or ham out of any groups."))
:group 'spam)
(defcustom spam-directory (nnheader-concat gnus-directory "spam/")
@@ -296,27 +299,27 @@ them."
:group 'spam)
(defcustom spam-install-hooks (or
- spam-use-dig
- spam-use-gmane-xref
- spam-use-blacklist
- spam-use-whitelist
- spam-use-whitelist-exclusive
- spam-use-blackholes
- spam-use-hashcash
- spam-use-regex-headers
- spam-use-regex-body
- spam-use-bogofilter
- spam-use-bogofilter-headers
- spam-use-spamassassin
- spam-use-spamassassin-headers
- spam-use-bsfilter
- spam-use-bsfilter-headers
- spam-use-BBDB
- spam-use-BBDB-exclusive
- spam-use-ifile
- spam-use-stat
- spam-use-spamoracle
- spam-use-crm114)
+ spam-use-dig
+ spam-use-gmane-xref
+ spam-use-blacklist
+ spam-use-whitelist
+ spam-use-whitelist-exclusive
+ spam-use-blackholes
+ spam-use-hashcash
+ spam-use-regex-headers
+ spam-use-regex-body
+ spam-use-bogofilter
+ spam-use-bogofilter-headers
+ spam-use-spamassassin
+ spam-use-spamassassin-headers
+ spam-use-bsfilter
+ spam-use-bsfilter-headers
+ spam-use-BBDB
+ spam-use-BBDB-exclusive
+ spam-use-ifile
+ spam-use-stat
+ spam-use-spamoracle
+ spam-use-crm114)
"Whether the spam hooks should be installed.
Default to t if one of the spam-use-* variables is set."
:group 'spam
@@ -330,8 +333,8 @@ Default to t if one of the spam-use-* variables is set."
;;; TODO: deprecate this variable, it's confusing since it's a list of strings,
;;; not regular expressions
(defcustom spam-junk-mailgroups (cons
- spam-split-group
- '("mail.junk" "poste.pourriel"))
+ spam-split-group
+ '("mail.junk" "poste.pourriel"))
"Mailgroups with spam contents.
All unmarked article in such group receive the spam mark on group entry."
:type '(repeat (string :tag "Group"))
@@ -345,7 +348,7 @@ Only meaningful if you enable `spam-use-gmane-xref'."
:group 'spam)
(defcustom spam-blackhole-servers '("bl.spamcop.net" "relays.ordb.org"
- "dev.null.dk" "relays.visi.com")
+ "dev.null.dk" "relays.visi.com")
"List of blackhole servers.
Only meaningful if you enable `spam-use-blackholes'."
:type '(repeat (string :tag "Server"))
@@ -405,9 +408,9 @@ Only meaningful if you enable `spam-use-regex-body'."
(defcustom spam-summary-score-preferred-header nil
"Preferred header to use for `spam-summary-score'."
:type '(choice :tag "Header name"
- (symbol :tag "SpamAssassin etc" X-Spam-Status)
- (symbol :tag "Bogofilter" X-Bogosity)
- (const :tag "No preference, take best guess." nil))
+ (symbol :tag "SpamAssassin etc" X-Spam-Status)
+ (symbol :tag "Bogofilter" X-Bogosity)
+ (const :tag "No preference, take best guess." nil))
:group 'spam)
(defgroup spam-ifile nil
@@ -419,7 +422,7 @@ Only meaningful if you enable `spam-use-regex-body'."
(defcustom spam-ifile-program (executable-find "ifile")
"Name of the ifile program."
:type '(choice (file :tag "Location of ifile")
- (const :tag "ifile is not installed"))
+ (const :tag "ifile is not installed"))
:group 'spam-ifile)
(make-obsolete-variable 'spam-ifile-database-path 'spam-ifile-database
@@ -427,7 +430,7 @@ Only meaningful if you enable `spam-use-regex-body'."
(defcustom spam-ifile-database nil
"File name of the ifile database."
:type '(choice (file :tag "Location of the ifile database")
- (const :tag "Use the default"))
+ (const :tag "Use the default"))
:group 'spam-ifile)
(defcustom spam-ifile-spam-category "spam"
@@ -439,7 +442,7 @@ Only meaningful if you enable `spam-use-regex-body'."
"Name of the ham ifile category.
If nil, the current group name will be used."
:type '(choice (string :tag "Use a fixed category")
- (const :tag "Use the current group name"))
+ (const :tag "Use the current group name"))
:group 'spam-ifile)
(defcustom spam-ifile-all-categories nil
@@ -458,7 +461,7 @@ your main source of newsgroup names."
(defcustom spam-bogofilter-program (executable-find "bogofilter")
"Name of the Bogofilter program."
:type '(choice (file :tag "Location of bogofilter")
- (const :tag "Bogofilter is not installed"))
+ (const :tag "Bogofilter is not installed"))
:group 'spam-bogofilter)
(defvar spam-bogofilter-valid 'unknown "Is the bogofilter version valid?")
@@ -497,8 +500,8 @@ your main source of newsgroup names."
"Location of the Bogofilter database.
When nil, use the default location."
:type '(choice (directory
- :tag "Location of the Bogofilter database directory")
- (const :tag "Use the default"))
+ :tag "Location of the Bogofilter database directory")
+ (const :tag "Use the default"))
:group 'spam-bogofilter)
(defgroup spam-bsfilter nil
@@ -510,7 +513,7 @@ When nil, use the default location."
(defcustom spam-bsfilter-program (executable-find "bsfilter")
"Name of the Bsfilter program."
:type '(choice (file :tag "Location of bsfilter")
- (const :tag "Bsfilter is not installed"))
+ (const :tag "Bsfilter is not installed"))
:group 'spam-bsfilter)
(defcustom spam-bsfilter-header "X-Spam-Flag"
@@ -546,8 +549,8 @@ When nil, use the default location."
(defcustom spam-bsfilter-database-directory nil
"Directory path of the Bsfilter databases."
:type '(choice (directory
- :tag "Location of the Bsfilter database directory")
- (const :tag "Use the default"))
+ :tag "Location of the Bsfilter database directory")
+ (const :tag "Use the default"))
:group 'spam-bsfilter)
(defgroup spam-spamoracle nil
@@ -558,13 +561,13 @@ When nil, use the default location."
"Location of spamoracle database file.
When nil, use the default spamoracle database."
:type '(choice (directory :tag "Location of spamoracle database file.")
- (const :tag "Use the default"))
+ (const :tag "Use the default"))
:group 'spam-spamoracle)
(defcustom spam-spamoracle-binary (executable-find "spamoracle")
"Location of the spamoracle binary."
:type '(choice (directory :tag "Location of the spamoracle binary")
- (const :tag "Use the default"))
+ (const :tag "Use the default"))
:group 'spam-spamoracle)
(defgroup spam-spamassassin nil
@@ -578,7 +581,7 @@ When nil, use the default spamoracle database."
Hint: set this to \"spamc\" if you have spamd running. See the spamc and
spamd man pages for more information on these programs."
:type '(choice (file :tag "Location of spamc")
- (const :tag "spamassassin is not installed"))
+ (const :tag "spamassassin is not installed"))
:group 'spam-spamassassin)
(defcustom spam-spamassassin-arguments ()
@@ -608,7 +611,7 @@ identification"
(defcustom spam-sa-learn-program (executable-find "sa-learn")
"Name of the sa-learn program."
:type '(choice (file :tag "Location of spamassassin")
- (const :tag "spamassassin is not installed"))
+ (const :tag "spamassassin is not installed"))
:group 'spam-spamassassin)
(defcustom spam-sa-learn-rebuild t
@@ -642,7 +645,7 @@ order for SpamAssassin to recognize the new registered spam."
(defcustom spam-crm114-program (executable-find "mailfilter.crm")
"File path of the CRM114 Mailfilter executable program."
:type '(choice (file :tag "Location of CRM114 Mailfilter")
- (const :tag "CRM114 Mailfilter is not installed"))
+ (const :tag "CRM114 Mailfilter is not installed"))
:group 'spam-crm114)
(defcustom spam-crm114-header "X-CRM114-Status"
@@ -678,8 +681,8 @@ order for SpamAssassin to recognize the new registered spam."
(defcustom spam-crm114-database-directory nil
"Directory path of the CRM114 Mailfilter databases."
:type '(choice (directory
- :tag "Location of the CRM114 Mailfilter database directory")
- (const :tag "Use the default"))
+ :tag "Location of the CRM114 Mailfilter database directory")
+ (const :tag "Use the default"))
:group 'spam-crm114)
;;; Key bindings for spam control.
@@ -689,14 +692,15 @@ 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'.")
(defvar spam-caches (make-hash-table
- :size 10
- :test 'equal)
+ :size 10
+ :test 'equal)
"Cache of spam detection entries.")
(defvar spam-old-articles nil
@@ -735,11 +739,11 @@ When either list is nil, the other is returned."
(if (and list1 list2)
;; we have two non-nil lists
(progn
- (dolist (item (append list1 list2))
- (when (and (memq item list1) (memq item list2))
- (setq list1 (delq item list1))
- (setq list2 (delq item list2))))
- (append list1 list2))
+ (dolist (item (append list1 list2))
+ (when (and (memq item list1) (memq item list2))
+ (setq list1 (delq item list1))
+ (setq list2 (delq item list2))))
+ (append list1 list2))
;; if either of the lists was nil, return the other one
(if list1 list1 list2)))
@@ -747,9 +751,9 @@ When either list is nil, the other is returned."
"Checks if MARK is considered a ham mark in GROUP."
(when (stringp group)
(let* ((marks (spam-group-ham-marks group spam))
- (marks (if (symbolp mark)
- marks
- (mapcar 'symbol-value marks))))
+ (marks (if (symbolp mark)
+ marks
+ (mapcar 'symbol-value marks))))
(memq mark marks))))
(defun spam-group-spam-mark-p (group mark)
@@ -760,10 +764,10 @@ When either list is nil, the other is returned."
"In GROUP, get all the ham marks."
(when (stringp group)
(let* ((marks (if spam
- (gnus-parameter-spam-marks group)
- (gnus-parameter-ham-marks group)))
- (marks (car marks))
- (marks (if (listp (car marks)) (car marks) marks)))
+ (gnus-parameter-spam-marks group)
+ (gnus-parameter-ham-marks group)))
+ (marks (car marks))
+ (marks (if (listp (car marks)) (car marks) marks)))
marks)))
(defun spam-group-spam-marks (group)
@@ -774,15 +778,15 @@ When either list is nil, the other is returned."
"Is GROUP a spam group?"
(if (and (stringp group) (< 0 (length group)))
(or (member group spam-junk-mailgroups)
- (memq 'gnus-group-spam-classification-spam
- (gnus-parameter-spam-contents group)))
+ (memq 'gnus-group-spam-classification-spam
+ (gnus-parameter-spam-contents group)))
nil))
(defun spam-group-ham-contents-p (group)
"Is GROUP a ham group?"
(if (stringp group)
(memq 'gnus-group-spam-classification-ham
- (gnus-parameter-spam-contents group))
+ (gnus-parameter-spam-contents group))
nil))
(defun spam-classifications ()
@@ -811,20 +815,20 @@ When either list is nil, the other is returned."
(defun spam-list-articles (articles classification)
(let ((mark-check (if (eq classification 'spam)
- 'spam-group-spam-mark-p
- 'spam-group-ham-mark-p))
- alist mark-cache-yes mark-cache-no)
+ 'spam-group-spam-mark-p
+ 'spam-group-ham-mark-p))
+ alist mark-cache-yes mark-cache-no)
(dolist (article articles)
(let ((mark (gnus-summary-article-mark article)))
- (unless (or (memq mark mark-cache-yes)
- (memq mark mark-cache-no))
- (if (funcall mark-check
- gnus-newsgroup-name
- mark)
- (push mark mark-cache-yes)
- (push mark mark-cache-no)))
- (when (memq mark mark-cache-yes)
- (push article alist))))
+ (unless (or (memq mark mark-cache-yes)
+ (memq mark mark-cache-no))
+ (if (funcall mark-check
+ gnus-newsgroup-name
+ mark)
+ (push mark mark-cache-yes)
+ (push mark mark-cache-no)))
+ (when (memq mark mark-cache-yes)
+ (push article alist))))
alist))
;;}}}
@@ -840,13 +844,13 @@ backend is STATISTICAL."
(setq spam-backends (add-to-list 'spam-backends backend))
(while properties
(let ((property (pop properties))
- (value (pop properties)))
+ (value (pop properties)))
(if (spam-backend-property-valid-p property)
- (put backend property value)
- (gnus-error
- 5
- "spam-install-backend-super got an invalid property %s"
- property)))))
+ (put backend property value)
+ (gnus-error
+ 5
+ "spam-install-backend-super got an invalid property %s"
+ property)))))
(defun spam-backend-list (&optional type)
"Return a list of all the backend symbols, constrained by TYPE.
@@ -855,16 +859,16 @@ When TYPE is 'mover, only mover backends are returned."
(let (list)
(dolist (backend spam-backends)
(when (or
- (null type) ;either no type was requested
- ;; or the type is 'mover and the backend is a mover
- (and
- (eq type 'mover)
- (spam-backend-mover-p backend))
- ;; or the type is 'non-mover and the backend is not a mover
- (and
- (eq type 'non-mover)
- (not (spam-backend-mover-p backend))))
- (push backend list)))
+ (null type) ;either no type was requested
+ ;; or the type is 'mover and the backend is a mover
+ (and
+ (eq type 'mover)
+ (spam-backend-mover-p backend))
+ ;; or the type is 'non-mover and the backend is not a mover
+ (and
+ (eq type 'non-mover)
+ (not (spam-backend-mover-p backend))))
+ (push backend list)))
list))
(defun spam-backend-check (backend)
@@ -888,16 +892,16 @@ that the message is definitely a spam."
"Return information about BACKEND."
(if (spam-backend-valid-p backend)
(let (info)
- (setq info (format "Backend %s has the following properties:\n"
- backend))
- (dolist (property (spam-backend-properties))
- (setq info (format "%s%s=%s\n"
- info
- property
- (get backend property))))
- info)
+ (setq info (format "Backend %s has the following properties:\n"
+ backend))
+ (dolist (property (spam-backend-properties))
+ (setq info (format "%s%s=%s\n"
+ info
+ property
+ (get backend property))))
+ info)
(gnus-error 5 "spam-backend-info was asked about an invalid backend %s"
- backend)))
+ backend)))
(defun spam-backend-function (backend classification type)
"Get the BACKEND function for CLASSIFICATION and TYPE.
@@ -907,11 +911,11 @@ CLASSIFICATION is 'ham or 'spam."
(spam-classification-valid-p classification)
(spam-backend-function-type-valid-p type))
(let ((retrieval
- (intern
- (format "spam-backend-%s-%s-function"
- classification
- type))))
- (funcall retrieval backend))
+ (intern
+ (format "spam-backend-%s-%s-function"
+ classification
+ type))))
+ (funcall retrieval backend))
(gnus-error
5
"%s was passed invalid backend %s, classification %s, or type %s"
@@ -921,15 +925,15 @@ CLASSIFICATION is 'ham or 'spam."
type)))
(defun spam-backend-article-list-property (classification
- &optional unregister)
+ &optional unregister)
"Property name of article list with CLASSIFICATION and UNREGISTER."
(let* ((r (if unregister "unregister" "register"))
- (prop (format "%s-%s" classification r)))
+ (prop (format "%s-%s" classification r)))
prop))
(defun spam-backend-get-article-todo-list (backend
- classification
- &optional unregister)
+ classification
+ &optional unregister)
"Get the articles to be processed for BACKEND and CLASSIFICATION.
With UNREGISTER, get articles to be unregistered.
This is a temporary storage function - nothing here persists."
@@ -937,7 +941,8 @@ This is a temporary storage function - nothing here persists."
backend
(intern (spam-backend-article-list-property classification unregister))))
-(defun spam-backend-put-article-todo-list (backend classification list &optional unregister)
+(defun spam-backend-put-article-todo-list (backend classification list
+ &optional unregister)
"Set the LIST of articles to be processed for BACKEND and CLASSIFICATION.
With UNREGISTER, set articles to be unregistered.
This is a temporary storage function - nothing here persists."
@@ -1035,125 +1040,125 @@ backends)."
;;{{{ backend installations
(spam-install-checkonly-backend 'spam-use-blackholes
- 'spam-check-blackholes)
+ 'spam-check-blackholes)
(spam-install-checkonly-backend 'spam-use-hashcash
- 'spam-check-hashcash)
+ 'spam-check-hashcash)
(spam-install-checkonly-backend 'spam-use-spamassassin-headers
- 'spam-check-spamassassin-headers)
+ 'spam-check-spamassassin-headers)
(spam-install-checkonly-backend 'spam-use-bogofilter-headers
- 'spam-check-bogofilter-headers)
+ 'spam-check-bogofilter-headers)
(spam-install-checkonly-backend 'spam-use-bsfilter-headers
- 'spam-check-bsfilter-headers)
+ 'spam-check-bsfilter-headers)
(spam-install-checkonly-backend 'spam-use-gmane-xref
- 'spam-check-gmane-xref)
+ 'spam-check-gmane-xref)
(spam-install-checkonly-backend 'spam-use-regex-headers
- 'spam-check-regex-headers)
+ 'spam-check-regex-headers)
(spam-install-statistical-checkonly-backend 'spam-use-regex-body
- 'spam-check-regex-body)
+ 'spam-check-regex-body)
-;; TODO: NOTE: spam-use-ham-copy is now obsolete, use (ham spam-use-copy) instead
+;; TODO: NOTE: spam-use-ham-copy is now obsolete, use (ham spam-use-copy)
(spam-install-mover-backend 'spam-use-move
- 'spam-move-ham-routine
- 'spam-move-spam-routine
- nil
- nil)
+ 'spam-move-ham-routine
+ 'spam-move-spam-routine
+ nil
+ nil)
(spam-install-nocheck-backend 'spam-use-copy
- 'spam-copy-ham-routine
- 'spam-copy-spam-routine
- nil
- nil)
+ 'spam-copy-ham-routine
+ 'spam-copy-spam-routine
+ nil
+ nil)
(spam-install-nocheck-backend 'spam-use-gmane
- 'spam-report-gmane-unregister-routine
- 'spam-report-gmane-register-routine
- 'spam-report-gmane-register-routine
- 'spam-report-gmane-unregister-routine)
+ 'spam-report-gmane-unregister-routine
+ 'spam-report-gmane-register-routine
+ 'spam-report-gmane-register-routine
+ 'spam-report-gmane-unregister-routine)
(spam-install-nocheck-backend 'spam-use-resend
- 'spam-report-resend-register-ham-routine
- 'spam-report-resend-register-routine
- nil
- nil)
+ 'spam-report-resend-register-ham-routine
+ 'spam-report-resend-register-routine
+ nil
+ nil)
(spam-install-backend 'spam-use-BBDB
- 'spam-check-BBDB
- 'spam-BBDB-register-routine
- nil
- 'spam-BBDB-unregister-routine
- nil)
+ 'spam-check-BBDB
+ 'spam-BBDB-register-routine
+ nil
+ 'spam-BBDB-unregister-routine
+ nil)
(spam-install-backend-alias 'spam-use-BBDB 'spam-use-BBDB-exclusive)
(spam-install-backend 'spam-use-blacklist
- 'spam-check-blacklist
- nil
- 'spam-blacklist-register-routine
- nil
- 'spam-blacklist-unregister-routine)
+ 'spam-check-blacklist
+ nil
+ 'spam-blacklist-register-routine
+ nil
+ 'spam-blacklist-unregister-routine)
(spam-install-backend 'spam-use-whitelist
- 'spam-check-whitelist
- 'spam-whitelist-register-routine
- nil
- 'spam-whitelist-unregister-routine
- nil)
+ 'spam-check-whitelist
+ 'spam-whitelist-register-routine
+ nil
+ 'spam-whitelist-unregister-routine
+ nil)
(spam-install-statistical-backend 'spam-use-ifile
- 'spam-check-ifile
- 'spam-ifile-register-ham-routine
- 'spam-ifile-register-spam-routine
- 'spam-ifile-unregister-ham-routine
- 'spam-ifile-unregister-spam-routine)
+ 'spam-check-ifile
+ 'spam-ifile-register-ham-routine
+ 'spam-ifile-register-spam-routine
+ 'spam-ifile-unregister-ham-routine
+ 'spam-ifile-unregister-spam-routine)
(spam-install-statistical-backend 'spam-use-spamoracle
- 'spam-check-spamoracle
- 'spam-spamoracle-learn-ham
- 'spam-spamoracle-learn-spam
- 'spam-spamoracle-unlearn-ham
- 'spam-spamoracle-unlearn-spam)
+ 'spam-check-spamoracle
+ 'spam-spamoracle-learn-ham
+ 'spam-spamoracle-learn-spam
+ 'spam-spamoracle-unlearn-ham
+ 'spam-spamoracle-unlearn-spam)
(spam-install-statistical-backend 'spam-use-stat
- 'spam-check-stat
- 'spam-stat-register-ham-routine
- 'spam-stat-register-spam-routine
- 'spam-stat-unregister-ham-routine
- 'spam-stat-unregister-spam-routine)
+ 'spam-check-stat
+ 'spam-stat-register-ham-routine
+ 'spam-stat-register-spam-routine
+ 'spam-stat-unregister-ham-routine
+ 'spam-stat-unregister-spam-routine)
(spam-install-statistical-backend 'spam-use-spamassassin
- 'spam-check-spamassassin
- 'spam-spamassassin-register-ham-routine
- 'spam-spamassassin-register-spam-routine
- 'spam-spamassassin-unregister-ham-routine
- 'spam-spamassassin-unregister-spam-routine)
+ 'spam-check-spamassassin
+ 'spam-spamassassin-register-ham-routine
+ 'spam-spamassassin-register-spam-routine
+ 'spam-spamassassin-unregister-ham-routine
+ 'spam-spamassassin-unregister-spam-routine)
(spam-install-statistical-backend 'spam-use-bogofilter
- 'spam-check-bogofilter
- 'spam-bogofilter-register-ham-routine
- 'spam-bogofilter-register-spam-routine
- 'spam-bogofilter-unregister-ham-routine
- 'spam-bogofilter-unregister-spam-routine)
+ 'spam-check-bogofilter
+ 'spam-bogofilter-register-ham-routine
+ 'spam-bogofilter-register-spam-routine
+ 'spam-bogofilter-unregister-ham-routine
+ 'spam-bogofilter-unregister-spam-routine)
(spam-install-statistical-backend 'spam-use-bsfilter
- 'spam-check-bsfilter
- 'spam-bsfilter-register-ham-routine
- 'spam-bsfilter-register-spam-routine
- 'spam-bsfilter-unregister-ham-routine
- 'spam-bsfilter-unregister-spam-routine)
+ 'spam-check-bsfilter
+ 'spam-bsfilter-register-ham-routine
+ 'spam-bsfilter-register-spam-routine
+ 'spam-bsfilter-unregister-ham-routine
+ 'spam-bsfilter-unregister-spam-routine)
(spam-install-statistical-backend 'spam-use-crm114
- 'spam-check-crm114
- 'spam-crm114-register-ham-routine
- 'spam-crm114-register-spam-routine
- 'spam-crm114-unregister-ham-routine
- 'spam-crm114-unregister-spam-routine)
+ 'spam-check-crm114
+ 'spam-crm114-register-ham-routine
+ 'spam-crm114-register-spam-routine
+ 'spam-crm114-unregister-ham-routine
+ 'spam-crm114-unregister-spam-routine)
;;}}}
;;{{{ scoring and summary formatting
@@ -1161,31 +1166,31 @@ backends)."
"Return the extra headers spam.el thinks are necessary."
(let (list)
(when (or spam-use-spamassassin
- spam-use-spamassassin-headers
- spam-use-regex-headers)
+ spam-use-spamassassin-headers
+ spam-use-regex-headers)
(push 'X-Spam-Status list))
(when (or spam-use-bogofilter
- spam-use-regex-headers)
+ spam-use-regex-headers)
(push 'X-Bogosity list))
(when (or spam-use-crm114
- spam-use-regex-headers)
+ spam-use-regex-headers)
(push 'X-CRM114-Status list))
list))
(defun spam-user-format-function-S (headers)
(when headers
(format "%3.2f"
- (spam-summary-score headers spam-summary-score-preferred-header))))
+ (spam-summary-score headers spam-summary-score-preferred-header))))
(defun spam-article-sort-by-spam-status (h1 h2)
"Sort articles by score."
(let (result)
(dolist (header (spam-necessary-extra-headers))
(let ((s1 (spam-summary-score h1 header))
- (s2 (spam-summary-score h2 header)))
+ (s2 (spam-summary-score h2 header)))
(unless (= s1 s2)
- (setq result (< s1 s2))
- (return))))
+ (setq result (< s1 s2))
+ (return))))
result))
(defvar spam-spamassassin-score-regexp
@@ -1222,13 +1227,13 @@ With SPECIFIC-HEADER, returns only that header's score.
Will not return a nil score."
(let (score)
(dolist (header
- (if specific-header
- (list specific-header)
- (spam-necessary-extra-headers)))
+ (if specific-header
+ (list specific-header)
+ (spam-necessary-extra-headers)))
(setq score
- (spam-extra-header-to-number header headers))
+ (spam-extra-header-to-number header headers))
(when score
- (return)))
+ (return)))
(or score 0)))
(defun spam-generic-score (&optional recheck)
@@ -1255,15 +1260,15 @@ Will not return a nil score."
(let (found)
(dolist (backend (spam-backend-list))
(when (and (spam-backend-statistical-p backend)
- (or (symbol-value backend)
- (memq backend force-symbols)))
- (setq found backend)))
+ (or (symbol-value backend)
+ (memq backend force-symbols)))
+ (setq found backend)))
found))
(defvar spam-list-of-processors
;; note the nil processors are not defined in gnus.el
'((gnus-group-spam-exit-processor-bogofilter spam spam-use-bogofilter)
- (gnus-group-spam-exit-processor-bsfilter spam spam-use-bsfilter)
+ (gnus-group-spam-exit-processor-bsfilter spam spam-use-bsfilter)
(gnus-group-spam-exit-processor-blacklist spam spam-use-blacklist)
(gnus-group-spam-exit-processor-ifile spam spam-use-ifile)
(gnus-group-spam-exit-processor-stat spam spam-use-stat)
@@ -1286,6 +1291,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.
@@ -1294,38 +1300,38 @@ gnus.el and in spam-list-of-processors. In the case of mover
backends, checks the setting of `spam-summary-exit-behavior' in
addition to the set values for the group."
(if (and (stringp group)
- (symbolp backend))
+ (symbolp backend))
(let ((old-style (assq backend spam-list-of-processors))
- (parameters (nth 0 (gnus-parameter-spam-process group)))
- found)
- (if old-style ; old-style processor
- (spam-group-processor-p group (nth 2 old-style) (nth 1 old-style))
- ;; now search for the parameter
- (dolist (parameter parameters)
- (when (and (null found)
- (listp parameter)
- (eq classification (nth 0 parameter))
- (eq backend (nth 1 parameter)))
- (setq found t)))
-
- ;; now, if the parameter was not found, do the
- ;; spam-summary-exit-behavior-logic for mover backends
- (unless found
- (when (spam-backend-mover-p backend)
- (setq
- found
- (cond
- ((eq spam-summary-exit-behavior 'move-all) t)
- ((eq spam-summary-exit-behavior 'move-none) nil)
- ((eq spam-summary-exit-behavior 'default)
- (or (eq classification 'spam) ;move spam out of all groups
- ;; move ham out of spam groups
- (and (eq classification 'ham)
- (spam-group-spam-contents-p group))))
- (t (gnus-error 5 "Unknown spam-summary-exit-behavior: %s"
- spam-summary-exit-behavior))))))
-
- found))
+ (parameters (nth 0 (gnus-parameter-spam-process group)))
+ found)
+ (if old-style ; old-style processor
+ (spam-group-processor-p group (nth 2 old-style) (nth 1 old-style))
+ ;; now search for the parameter
+ (dolist (parameter parameters)
+ (when (and (null found)
+ (listp parameter)
+ (eq classification (nth 0 parameter))
+ (eq backend (nth 1 parameter)))
+ (setq found t)))
+
+ ;; now, if the parameter was not found, do the
+ ;; spam-summary-exit-behavior-logic for mover backends
+ (unless found
+ (when (spam-backend-mover-p backend)
+ (setq
+ found
+ (cond
+ ((eq spam-summary-exit-behavior 'move-all) t)
+ ((eq spam-summary-exit-behavior 'move-none) nil)
+ ((eq spam-summary-exit-behavior 'default)
+ (or (eq classification 'spam) ;move spam out of all groups
+ ;; move ham out of spam groups
+ (and (eq classification 'ham)
+ (spam-group-spam-contents-p group))))
+ (t (gnus-error 5 "Unknown spam-summary-exit-behavior: %s"
+ spam-summary-exit-behavior))))))
+
+ found))
nil))
;;}}}
@@ -1337,21 +1343,21 @@ addition to the set values for the group."
;; group parameters
(when (spam-group-spam-contents-p gnus-newsgroup-name)
(gnus-message 6 "Marking %s articles as spam"
- (if spam-mark-only-unseen-as-spam
- "unseen"
- "unread"))
+ (if spam-mark-only-unseen-as-spam
+ "unseen"
+ "unread"))
(let ((articles (if spam-mark-only-unseen-as-spam
- gnus-newsgroup-unseen
- gnus-newsgroup-unreads)))
+ gnus-newsgroup-unseen
+ gnus-newsgroup-unreads)))
(if spam-mark-new-messages-in-spam-group-as-spam
- (dolist (article articles)
- (gnus-summary-mark-article article gnus-spam-mark))
- (gnus-message 9 "Did not mark new messages as spam.")))))
+ (dolist (article articles)
+ (gnus-summary-mark-article article gnus-spam-mark))
+ (gnus-message 9 "Did not mark new messages as spam.")))))
(defun spam-summary-prepare ()
(setq spam-old-articles
- (list (cons 'ham (spam-list-articles gnus-newsgroup-articles 'ham))
- (cons 'spam (spam-list-articles gnus-newsgroup-articles 'spam))))
+ (list (cons 'ham (spam-list-articles gnus-newsgroup-articles 'ham))
+ (cons 'spam (spam-list-articles gnus-newsgroup-articles 'spam))))
(spam-mark-junk-as-spam-routine))
;; The spam processors are invoked for any group, spam or ham or neither
@@ -1367,46 +1373,46 @@ addition to the set values for the group."
;; we have to iterate over the processors, or else we'll be too slow
(dolist (classification (spam-classifications))
(let* ((old-articles (cdr-safe (assq classification spam-old-articles)))
- (new-articles (spam-list-articles
- gnus-newsgroup-articles
- classification))
- (changed-articles (spam-set-difference new-articles old-articles)))
- ;; now that we have the changed articles, we go through the processors
- (dolist (backend (spam-backend-list))
- (let (unregister-list)
- (dolist (article changed-articles)
- (let ((id (spam-fetch-field-message-id-fast article)))
- (when (spam-log-unregistration-needed-p
- id 'process classification backend)
- (push article unregister-list))))
- ;; call spam-register-routine with specific articles to unregister,
- ;; when there are articles to unregister and the check is enabled
- (when (and unregister-list (symbol-value backend))
- (spam-backend-put-article-todo-list backend
- classification
- unregister-list
- t))))))
+ (new-articles (spam-list-articles
+ gnus-newsgroup-articles
+ classification))
+ (changed-articles (spam-set-difference new-articles old-articles)))
+ ;; now that we have the changed articles, we go through the processors
+ (dolist (backend (spam-backend-list))
+ (let (unregister-list)
+ (dolist (article changed-articles)
+ (let ((id (spam-fetch-field-message-id-fast article)))
+ (when (spam-log-unregistration-needed-p
+ id 'process classification backend)
+ (push article unregister-list))))
+ ;; call spam-register-routine with specific articles to unregister,
+ ;; when there are articles to unregister and the check is enabled
+ (when (and unregister-list (symbol-value backend))
+ (spam-backend-put-article-todo-list backend
+ classification
+ unregister-list
+ t))))))
;; do the non-moving backends first, then the moving ones
(dolist (backend-type '(non-mover mover))
(dolist (classification (spam-classifications))
- (dolist (backend (spam-backend-list backend-type))
- (when (spam-group-processor-p
- gnus-newsgroup-name
- backend
- classification)
- (spam-backend-put-article-todo-list backend
- classification
- (spam-list-articles
- gnus-newsgroup-articles
- classification))))))
+ (dolist (backend (spam-backend-list backend-type))
+ (when (spam-group-processor-p
+ gnus-newsgroup-name
+ backend
+ classification)
+ (spam-backend-put-article-todo-list backend
+ classification
+ (spam-list-articles
+ gnus-newsgroup-articles
+ classification))))))
(spam-resolve-registrations-routine) ; do the registrations now
;; we mark all the leftover spam articles as expired at the end
(dolist (article (spam-list-articles
- gnus-newsgroup-articles
- 'spam))
+ gnus-newsgroup-articles
+ 'spam))
(gnus-summary-mark-article article gnus-expirable-mark)))
(setq spam-old-articles nil))
@@ -1427,67 +1433,94 @@ addition to the set values for the group."
(gnus-summary-kill-process-mark)
(let ((backend-supports-deletions
- (gnus-check-backend-function
- 'request-move-article gnus-newsgroup-name))
- (respool-method (gnus-find-method-for-group gnus-newsgroup-name))
- article mark deletep respool)
+ (gnus-check-backend-function
+ 'request-move-article gnus-newsgroup-name))
+ (respool-method (gnus-find-method-for-group gnus-newsgroup-name))
+ article mark deletep respool valid-move-destinations)
(when (member 'respool groups)
- (setq respool t) ; boolean for later
+ (setq respool t) ; boolean for later
(setq groups '("fake"))) ; when respooling, groups are dynamic so fake it
+ ;; exclude invalid move destinations
+ (dolist (group groups)
+ (unless
+ (or
+ (and
+ (eq classification 'spam)
+ (spam-group-spam-contents-p gnus-newsgroup-name)
+ (spam-group-spam-contents-p group)
+ (gnus-message
+ 3
+ "Sorry, can't move spam from spam group %s to spam group %s"
+ gnus-newsgroup-name
+ group))
+ (and
+ (eq classification 'ham)
+ (spam-group-ham-contents-p gnus-newsgroup-name)
+ (spam-group-ham-contents-p group)
+ (gnus-message
+ 3
+ "Sorry, can't move ham from ham group %s to ham group %s"
+ gnus-newsgroup-name
+ group)))
+ (push group valid-move-destinations)))
+
+ (setq groups (nreverse valid-move-destinations))
+
;; now do the actual move
(dolist (group groups)
+
(when (and articles (stringp group))
- ;; first, mark the article with the process mark and, if needed,
- ;; the unread or expired mark (for ham and spam respectively)
+ ;; first, mark the article with the process mark and, if needed,
+ ;; the unread or expired mark (for ham and spam respectively)
+ (dolist (article articles)
+ (when (and (eq classification 'ham)
+ spam-mark-ham-unread-before-move-from-spam-group)
+ (gnus-message 9 "Marking ham article %d unread before move"
+ article)
+ (gnus-summary-mark-article article gnus-unread-mark))
+ (when (and (eq classification 'spam)
+ (not copy))
+ (gnus-message 9 "Marking spam article %d expirable before move"
+ article)
+ (gnus-summary-mark-article article gnus-expirable-mark))
+ (gnus-summary-set-process-mark article)
+
+ (if respool ; respooling is with a "fake" group
+ (let ((spam-split-disabled
+ (or spam-split-disabled
+ (and (eq classification 'ham)
+ spam-disable-spam-split-during-ham-respool))))
+ (gnus-message 9 "Respooling article %d with method %s"
+ article respool-method)
+ (gnus-summary-respool-article nil respool-method))
+ ;; else, we are not respooling
+ (if (or (not backend-supports-deletions)
+ (> (length groups) 1))
+ (progn ; if copying, copy and set deletep
+ (gnus-message 9 "Copying article %d to group %s"
+ article group)
+ (gnus-summary-copy-article nil group)
+ (setq deletep t))
+ (gnus-message 9 "Moving article %d to group %s"
+ article group)
+ (gnus-summary-move-article nil group)))))) ; else move articles
+
+ ;; now delete the articles, unless a) copy is t, and there was a copy done
+ ;; b) a move was done to a single group
+ ;; c) backend-supports-deletions is nil
+ (unless copy
+ (when (and deletep backend-supports-deletions)
(dolist (article articles)
- (when (and (eq classification 'ham)
- spam-mark-ham-unread-before-move-from-spam-group)
- (gnus-message 9 "Marking ham article %d unread before move"
- article)
- (gnus-summary-mark-article article gnus-unread-mark))
- (when (and (eq classification 'spam)
- (not copy))
- (gnus-message 9 "Marking spam article %d expirable before move"
- article)
- (gnus-summary-mark-article article gnus-expirable-mark))
(gnus-summary-set-process-mark article)
-
- (if respool ; respooling is with a "fake" group
- (let ((spam-split-disabled
- (or spam-split-disabled
- (and (eq classification 'ham)
- spam-disable-spam-split-during-ham-respool))))
- (gnus-message 9 "Respooling article %d with method %s"
- article respool-method)
- (gnus-summary-respool-article nil respool-method))
- (if (or (not backend-supports-deletions) ; else, we are not respooling
- (> (length groups) 1))
- (progn ; if copying, copy and set deletep
- (gnus-message 9 "Copying article %d to group %s"
- article group)
- (gnus-summary-copy-article nil group)
- (setq deletep t))
- (gnus-message 9 "Moving article %d to group %s"
- article group)
- (gnus-summary-move-article nil group))))) ; else move articles
-
- ;; now delete the articles, unless a) copy is t, and there was a copy done
- ;; b) a move was done to a single group
- ;; c) backend-supports-deletions is nil
- (unless copy
- (when (and deletep backend-supports-deletions)
- (dolist (article articles)
- (gnus-summary-set-process-mark article)
- (gnus-message 9 "Deleting article %d" article))
- (when articles
- (let ((gnus-novice-user nil)) ; don't ask me if I'm sure
- (gnus-summary-delete-article nil)))))
-
- (gnus-summary-yank-process-mark)
- (length articles))))
+ (gnus-message 9 "Deleting article %d" article))
+ (when articles
+ (let ((gnus-novice-user nil)) ; don't ask me if I'm sure
+ (gnus-summary-delete-article nil)))))
+ (gnus-summary-yank-process-mark)
+ (length articles)))
(defun spam-copy-spam-routine (articles)
(spam-copy-or-move-routine
@@ -1535,44 +1568,44 @@ addition to the set values for the group."
;; (nnml-possibly-change-directory
;; (gnus-group-real-name gnus-newsgroup-name))
;; (setq article-filename (expand-file-name
-;; (int-to-string article) nnml-current-directory)))
+;; (int-to-string article) nnml-current-directory)))
;; (if (file-exists-p article-filename)
-;; article-filename
+;; article-filename
;; nil)))
(defun spam-fetch-field-fast (article field &optional prepared-data-header)
- "Fetch a FIELD for ARTICLE quickly, using the internal gnus-data-list function.
+ "Fetch a FIELD for ARTICLE with the internal `gnus-data-list' function.
When PREPARED-DATA-HEADER is given, don't look in the Gnus data.
When FIELD is 'number, ARTICLE can be any number (since we want
to find it out)."
(when (numberp article)
(let* ((data-header (or prepared-data-header
- (spam-fetch-article-header article))))
+ (spam-fetch-article-header article))))
(if (arrayp data-header)
- (cond
- ((equal field 'number)
- (mail-header-number data-header))
- ((equal field 'from)
- (mail-header-from data-header))
- ((equal field 'message-id)
- (mail-header-message-id data-header))
- ((equal field 'subject)
- (mail-header-subject data-header))
- ((equal field 'references)
- (mail-header-references data-header))
- ((equal field 'date)
- (mail-header-date data-header))
- ((equal field 'xref)
- (mail-header-xref data-header))
- ((equal field 'extra)
- (mail-header-extra data-header))
- (t
- (gnus-error
- 5
- "spam-fetch-field-fast: unknown field %s requested"
- field)
- nil))
- (gnus-message 6 "Article %d has a nil data header" article)))))
+ (cond
+ ((equal field 'number)
+ (mail-header-number data-header))
+ ((equal field 'from)
+ (mail-header-from data-header))
+ ((equal field 'message-id)
+ (mail-header-message-id data-header))
+ ((equal field 'subject)
+ (mail-header-subject data-header))
+ ((equal field 'references)
+ (mail-header-references data-header))
+ ((equal field 'date)
+ (mail-header-date data-header))
+ ((equal field 'xref)
+ (mail-header-xref data-header))
+ ((equal field 'extra)
+ (mail-header-extra data-header))
+ (t
+ (gnus-error
+ 5
+ "spam-fetch-field-fast: unknown field %s requested"
+ field)
+ nil))
+ (gnus-message 6 "Article %d has a nil data header" article)))))
(defun spam-fetch-field-from-fast (article &optional prepared-data-header)
(spam-fetch-field-fast article 'from prepared-data-header))
@@ -1586,27 +1619,26 @@ to find it out)."
(defun spam-generate-fake-headers (article)
(let ((dh (spam-fetch-article-header article)))
(if dh
- (concat
- (format
- ;; 80-character limit makes for strange constructs
- (concat "From: %s\nSubject: %s\nMessage-ID: %s\n"
- "Date: %s\nReferences: %s\nXref: %s\n")
- (spam-fetch-field-fast article 'from dh)
- (spam-fetch-field-fast article 'subject dh)
- (spam-fetch-field-fast article 'message-id dh)
- (spam-fetch-field-fast article 'date dh)
- (spam-fetch-field-fast article 'references dh)
- (spam-fetch-field-fast article 'xref dh))
- (when (spam-fetch-field-fast article 'extra dh)
- (format "%s\n" (spam-fetch-field-fast article 'extra dh))))
+ (concat
+ (format
+ ;; 80-character limit makes for strange constructs
+ (concat "From: %s\nSubject: %s\nMessage-ID: %s\n"
+ "Date: %s\nReferences: %s\nXref: %s\n")
+ (spam-fetch-field-fast article 'from dh)
+ (spam-fetch-field-fast article 'subject dh)
+ (spam-fetch-field-fast article 'message-id dh)
+ (spam-fetch-field-fast article 'date dh)
+ (spam-fetch-field-fast article 'references dh)
+ (spam-fetch-field-fast article 'xref dh))
+ (when (spam-fetch-field-fast article 'extra dh)
+ (format "%s\n" (spam-fetch-field-fast article 'extra dh))))
(gnus-message
5
"spam-generate-fake-headers: article %d didn't have a valid header"
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))))
;;}}}
@@ -1626,122 +1658,121 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(unless spam-split-disabled
(let ((spam-split-group-choice spam-split-group))
(dolist (check specific-checks)
- (when (stringp check)
- (setq spam-split-group-choice check)
- (setq specific-checks (delq check specific-checks))))
+ (when (stringp check)
+ (setq spam-split-group-choice check)
+ (setq specific-checks (delq check specific-checks))))
(let ((spam-split-group spam-split-group-choice)
- (widening-needed-check (spam-widening-needed-p specific-checks)))
- (save-excursion
- (save-restriction
- (when widening-needed-check
- (widen)
- (gnus-message 8 "spam-split: widening the buffer (%s requires it)"
- widening-needed-check))
- (let ((backends (spam-backend-list))
- decision)
- (while (and backends (not decision))
- (let* ((backend (pop backends))
- (check-function (spam-backend-check backend))
- (spam-split-group (if spam-split-symbolic-return
- 'spam
- spam-split-group)))
- (when (or
- ;; either, given specific checks, this is one of them
- (memq backend specific-checks)
- ;; or, given no specific checks, spam-use-CHECK is set
- (and (null specific-checks) (symbol-value backend)))
- (gnus-message 6 "spam-split: calling the %s function"
- check-function)
- (setq decision (funcall check-function))
- ;; if we got a decision at all, save the current check
- (when decision
- (setq spam-split-last-successful-check backend))
-
- (when (eq decision 'spam)
- (unless spam-split-symbolic-return
- (gnus-error
- 5
- (format "spam-split got %s but %s is nil"
- decision
- spam-split-symbolic-return)))))))
- (if (eq decision t)
- (if spam-split-symbolic-return-positive 'ham nil)
- decision))))))))
+ (widening-needed-check (spam-widening-needed-p specific-checks)))
+ (save-excursion
+ (save-restriction
+ (when widening-needed-check
+ (widen)
+ (gnus-message 8 "spam-split: widening the buffer (%s requires it)"
+ widening-needed-check))
+ (let ((backends (spam-backend-list))
+ decision)
+ (while (and backends (not decision))
+ (let* ((backend (pop backends))
+ (check-function (spam-backend-check backend))
+ (spam-split-group (if spam-split-symbolic-return
+ 'spam
+ spam-split-group)))
+ (when (or
+ ;; either, given specific checks, this is one of them
+ (memq backend specific-checks)
+ ;; or, given no specific checks, spam-use-CHECK is set
+ (and (null specific-checks) (symbol-value backend)))
+ (gnus-message 6 "spam-split: calling the %s function"
+ check-function)
+ (setq decision (funcall check-function))
+ ;; if we got a decision at all, save the current check
+ (when decision
+ (setq spam-split-last-successful-check backend))
+
+ (when (eq decision 'spam)
+ (unless spam-split-symbolic-return
+ (gnus-error
+ 5
+ (format "spam-split got %s but %s is nil"
+ decision
+ spam-split-symbolic-return)))))))
+ (if (eq decision t)
+ (if spam-split-symbolic-return-positive 'ham nil)
+ decision))))))))
(defun spam-find-spam ()
"Detect spam in the current newsgroup using `spam-split'."
(interactive)
(let* ((group gnus-newsgroup-name)
- (autodetect (gnus-parameter-spam-autodetect group))
- (methods (gnus-parameter-spam-autodetect-methods group))
- (first-method (nth 0 methods))
- (articles (if spam-autodetect-recheck-messages
- gnus-newsgroup-articles
- gnus-newsgroup-unseen))
- article-cannot-be-faked)
+ (autodetect (gnus-parameter-spam-autodetect group))
+ (methods (gnus-parameter-spam-autodetect-methods group))
+ (first-method (nth 0 methods))
+ (articles (if spam-autodetect-recheck-messages
+ gnus-newsgroup-articles
+ gnus-newsgroup-unseen))
+ article-cannot-be-faked)
(dolist (backend methods)
(when (spam-backend-statistical-p backend)
- (setq article-cannot-be-faked t)
- (return)))
+ (setq article-cannot-be-faked t)
+ (return)))
(when (memq 'default methods)
(setq article-cannot-be-faked t))
(when (and autodetect
- (not (equal first-method 'none)))
+ (not (equal first-method 'none)))
(mapcar
(lambda (article)
- (let ((id (spam-fetch-field-message-id-fast article))
- (subject (spam-fetch-field-subject-fast article))
- (sender (spam-fetch-field-from-fast article))
- registry-lookup)
-
- (unless id
- (gnus-message 6 "Article %d has no message ID!" article))
-
- (when (and id spam-log-to-registry)
- (setq registry-lookup (spam-log-registration-type id 'incoming))
- (when registry-lookup
- (gnus-message
- 9
- "spam-find-spam: message %s was already registered incoming"
- id)))
-
- (let* ((spam-split-symbolic-return t)
- (spam-split-symbolic-return-positive t)
- (fake-headers (spam-generate-fake-headers article))
- (split-return
- (or registry-lookup
- (with-temp-buffer
- (if article-cannot-be-faked
- (gnus-request-article-this-buffer
- article
- group)
- ;; else, we fake the article
- (when fake-headers (insert fake-headers)))
- (if (or (null first-method)
- (equal first-method 'default))
- (spam-split)
- (apply 'spam-split methods))))))
- (if (equal split-return 'spam)
- (gnus-summary-mark-article article gnus-spam-mark))
-
- (when (and id split-return spam-log-to-registry)
- (when (zerop (gnus-registry-group-count id))
- (gnus-registry-add-group
- id group subject sender))
-
- (unless registry-lookup
- (spam-log-processing-to-registry
- id
- 'incoming
- split-return
- spam-split-last-successful-check
- group))))))
+ (let ((id (spam-fetch-field-message-id-fast article))
+ (subject (spam-fetch-field-subject-fast article))
+ (sender (spam-fetch-field-from-fast article))
+ registry-lookup)
+
+ (unless id
+ (gnus-message 6 "Article %d has no message ID!" article))
+
+ (when (and id spam-log-to-registry)
+ (setq registry-lookup (spam-log-registration-type id 'incoming))
+ (when registry-lookup
+ (gnus-message
+ 9
+ "spam-find-spam: message %s was already registered incoming"
+ id)))
+
+ (let* ((spam-split-symbolic-return t)
+ (spam-split-symbolic-return-positive t)
+ (fake-headers (spam-generate-fake-headers article))
+ (split-return
+ (or registry-lookup
+ (with-temp-buffer
+ (if article-cannot-be-faked
+ (gnus-request-article-this-buffer
+ article
+ group)
+ ;; else, we fake the article
+ (when fake-headers (insert fake-headers)))
+ (if (or (null first-method)
+ (equal first-method 'default))
+ (spam-split)
+ (apply 'spam-split methods))))))
+ (if (equal split-return 'spam)
+ (gnus-summary-mark-article article gnus-spam-mark))
+
+ (when (and id split-return spam-log-to-registry)
+ (when (zerop (gnus-registry-group-count id))
+ (gnus-registry-handle-action id nil group subject sender))
+
+ (unless registry-lookup
+ (spam-log-processing-to-registry
+ id
+ 'incoming
+ split-return
+ spam-split-last-successful-check
+ group))))))
articles))))
;;}}}
@@ -1753,104 +1784,104 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(dolist (backend-type '(non-mover mover))
(dolist (classification (spam-classifications))
(dolist (backend (spam-backend-list backend-type))
- (let ((rlist (spam-backend-get-article-todo-list
- backend classification))
- (ulist (spam-backend-get-article-todo-list
- backend classification t))
- (delcount 0))
-
- ;; clear the old lists right away
- (spam-backend-put-article-todo-list backend
- classification
- nil
- nil)
- (spam-backend-put-article-todo-list backend
- classification
- nil
- t)
-
- ;; eliminate duplicates
- (dolist (article (copy-sequence ulist))
- (when (memq article rlist)
- (incf delcount)
- (setq rlist (delq article rlist))
- (setq ulist (delq article ulist))))
-
- (unless (zerop delcount)
- (gnus-message
- 9
- "%d messages were saved the trouble of unregistering and then registering"
- delcount))
-
- ;; unregister articles
- (unless (zerop (length ulist))
- (let ((num (spam-unregister-routine classification backend ulist)))
- (when (> num 0)
- (gnus-message
- 6
- "%d %s messages were unregistered by backend %s."
- num
- classification
- backend))))
-
- ;; register articles
- (unless (zerop (length rlist))
- (let ((num (spam-register-routine classification backend rlist)))
- (when (> num 0)
- (gnus-message
- 6
- "%d %s messages were registered by backend %s."
- num
- classification
- backend)))))))))
+ (let ((rlist (spam-backend-get-article-todo-list
+ backend classification))
+ (ulist (spam-backend-get-article-todo-list
+ backend classification t))
+ (delcount 0))
+
+ ;; clear the old lists right away
+ (spam-backend-put-article-todo-list backend
+ classification
+ nil
+ nil)
+ (spam-backend-put-article-todo-list backend
+ classification
+ nil
+ t)
+
+ ;; eliminate duplicates
+ (dolist (article (copy-sequence ulist))
+ (when (memq article rlist)
+ (incf delcount)
+ (setq rlist (delq article rlist))
+ (setq ulist (delq article ulist))))
+
+ (unless (zerop delcount)
+ (gnus-message
+ 9
+ "%d messages did not have to unregister and then register"
+ delcount))
+
+ ;; unregister articles
+ (unless (zerop (length ulist))
+ (let ((num (spam-unregister-routine classification backend ulist)))
+ (when (> num 0)
+ (gnus-message
+ 6
+ "%d %s messages were unregistered by backend %s."
+ num
+ classification
+ backend))))
+
+ ;; register articles
+ (unless (zerop (length rlist))
+ (let ((num (spam-register-routine classification backend rlist)))
+ (when (> num 0)
+ (gnus-message
+ 6
+ "%d %s messages were registered by backend %s."
+ num
+ classification
+ backend)))))))))
(defun spam-unregister-routine (classification
- backend
- specific-articles)
+ backend
+ specific-articles)
(spam-register-routine classification backend specific-articles t))
(defun spam-register-routine (classification
- backend
- specific-articles
- &optional unregister)
+ backend
+ specific-articles
+ &optional unregister)
(when (and (spam-classification-valid-p classification)
- (spam-backend-valid-p backend))
+ (spam-backend-valid-p backend))
(let* ((register-function
- (spam-backend-function backend classification 'registration))
- (unregister-function
- (spam-backend-function backend classification 'unregistration))
- (run-function (if unregister
- unregister-function
- register-function))
- (log-function (if unregister
- 'spam-log-undo-registration
- 'spam-log-processing-to-registry))
- article articles)
+ (spam-backend-function backend classification 'registration))
+ (unregister-function
+ (spam-backend-function backend classification 'unregistration))
+ (run-function (if unregister
+ unregister-function
+ register-function))
+ (log-function (if unregister
+ 'spam-log-undo-registration
+ 'spam-log-processing-to-registry))
+ article articles)
(when run-function
- ;; make list of articles, using specific-articles if given
- (setq articles (or specific-articles
- (spam-list-articles
- gnus-newsgroup-articles
- classification)))
- ;; process them
+ ;; make list of articles, using specific-articles if given
+ (setq articles (or specific-articles
+ (spam-list-articles
+ gnus-newsgroup-articles
+ classification)))
+ ;; process them
(when (> (length articles) 0)
- (gnus-message 5 "%s %d %s articles as %s using backend %s"
- (if unregister "Unregistering" "Registering")
- (length articles)
- (if specific-articles "specific" "")
- classification
- backend)
- (funcall run-function articles)
- ;; now log all the registrations (or undo them, depending on
- ;; unregister)
- (dolist (article articles)
- (funcall log-function
- (spam-fetch-field-message-id-fast article)
- 'process
- classification
- backend
- gnus-newsgroup-name))))
+ (gnus-message 5 "%s %d %s articles as %s using backend %s"
+ (if unregister "Unregistering" "Registering")
+ (length articles)
+ (if specific-articles "specific" "")
+ classification
+ backend)
+ (funcall run-function articles)
+ ;; now log all the registrations (or undo them, depending on
+ ;; unregister)
+ (dolist (article articles)
+ (funcall log-function
+ (spam-fetch-field-message-id-fast article)
+ 'process
+ classification
+ backend
+ gnus-newsgroup-name))))
;; return the number of articles processed
(length articles))))
@@ -1858,50 +1889,48 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(defun spam-log-processing-to-registry (id type classification backend group)
(when spam-log-to-registry
(if (and (stringp id)
- (stringp group)
- (spam-process-type-valid-p type)
- (spam-classification-valid-p classification)
- (spam-backend-valid-p backend))
- (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type)))
- (cell (list classification backend group)))
- (push cell cell-list)
- (gnus-registry-store-extra-entry
- id
- type
- cell-list))
+ (stringp group)
+ (spam-process-type-valid-p type)
+ (spam-classification-valid-p classification)
+ (spam-backend-valid-p backend))
+ (let ((cell-list (gnus-registry-get-id-key id type))
+ (cell (list classification backend group)))
+ (push cell cell-list)
+ (gnus-registry-set-id-key id type cell-list))
(gnus-error
7
- (format "%s call with bad ID, type, classification, spam-backend, or group"
- "spam-log-processing-to-registry")))))
+ (format
+ "%s call with bad ID, type, classification, spam-backend, or group"
+ "spam-log-processing-to-registry")))))
;;; check if a ham- or spam-processor registration has been done
(defun spam-log-registered-p (id type)
(when spam-log-to-registry
(if (and (stringp id)
- (spam-process-type-valid-p type))
- (cdr-safe (gnus-registry-fetch-extra id type))
+ (spam-process-type-valid-p type))
+ (gnus-registry-get-id-key id type)
(progn
- (gnus-error
- 7
- (format "%s called with bad ID, type, classification, or spam-backend"
- "spam-log-registered-p"))
- nil))))
+ (gnus-error
+ 7
+ (format "%s called with bad ID, type, classification, or spam-backend"
+ "spam-log-registered-p"))
+ nil))))
;;; check what a ham- or spam-processor registration says
;;; returns nil if conflicting registrations are found
(defun spam-log-registration-type (id type)
(let ((count 0)
- decision)
+ decision)
(dolist (reg (spam-log-registered-p id type))
(let ((classification (nth 0 reg)))
- (when (spam-classification-valid-p classification)
- (when (and decision
- (not (eq classification decision)))
- (setq count (+ 1 count)))
- (setq decision classification))))
+ (when (spam-classification-valid-p classification)
+ (when (and decision
+ (not (eq classification decision)))
+ (setq count (+ 1 count)))
+ (setq decision classification))))
(if (< 0 count)
- nil
+ nil
decision)))
@@ -1909,47 +1938,46 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(defun spam-log-unregistration-needed-p (id type classification backend)
(when spam-log-to-registry
(if (and (stringp id)
- (spam-process-type-valid-p type)
- (spam-classification-valid-p classification)
- (spam-backend-valid-p backend))
- (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type)))
- found)
- (dolist (cell cell-list)
- (unless found
- (when (and (eq classification (nth 0 cell))
- (eq backend (nth 1 cell)))
- (setq found t))))
- found)
+ (spam-process-type-valid-p type)
+ (spam-classification-valid-p classification)
+ (spam-backend-valid-p backend))
+ (let ((cell-list (gnus-registry-get-id-key id type))
+ found)
+ (dolist (cell cell-list)
+ (unless found
+ (when (and (eq classification (nth 0 cell))
+ (eq backend (nth 1 cell)))
+ (setq found t))))
+ found)
(progn
- (gnus-error
- 7
- (format "%s called with bad ID, type, classification, or spam-backend"
- "spam-log-unregistration-needed-p"))
- nil))))
+ (gnus-error
+ 7
+ (format "%s called with bad ID, type, classification, or spam-backend"
+ "spam-log-unregistration-needed-p"))
+ nil))))
;;; undo a ham- or spam-processor registration (the group is not used)
-(defun spam-log-undo-registration (id type classification backend &optional group)
+(defun spam-log-undo-registration (id type classification backend
+ &optional group)
(when (and spam-log-to-registry
- (spam-log-unregistration-needed-p id type classification backend))
+ (spam-log-unregistration-needed-p id type classification backend))
(if (and (stringp id)
- (spam-process-type-valid-p type)
- (spam-classification-valid-p classification)
- (spam-backend-valid-p backend))
- (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type)))
- new-cell-list found)
- (dolist (cell cell-list)
- (unless (and (eq classification (nth 0 cell))
- (eq backend (nth 1 cell)))
- (push cell new-cell-list)))
- (gnus-registry-store-extra-entry
- id
- type
- new-cell-list))
+ (spam-process-type-valid-p type)
+ (spam-classification-valid-p classification)
+ (spam-backend-valid-p backend))
+ (let ((cell-list (gnus-registry-get-id-key id type))
+ new-cell-list found)
+ (dolist (cell cell-list)
+ (unless (and (eq classification (nth 0 cell))
+ (eq backend (nth 1 cell)))
+ (push cell new-cell-list)))
+ (gnus-registry-set-id-key id type new-cell-list))
(progn
- (gnus-error 7 (format "%s call with bad ID, type, spam-backend, or group"
- "spam-log-undo-registration"))
- nil))))
+ (gnus-error 7 (format
+ "%s call with bad ID, type, spam-backend, or group"
+ "spam-log-undo-registration"))
+ nil))))
;;}}}
@@ -1958,12 +1986,12 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
;;{{{ Gmane xrefs
(defun spam-check-gmane-xref ()
(let ((header (or
- (message-fetch-field "Xref")
- (message-fetch-field "Newsgroups"))))
- (when header ; return nil when no header
+ (message-fetch-field "Xref")
+ (message-fetch-field "Newsgroups"))))
+ (when header ; return nil when no header
(when (string-match spam-gmane-xref-spam-group
- header)
- spam-split-group))))
+ header)
+ spam-split-group))))
;;}}}
@@ -1971,7 +1999,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(defun spam-check-regex-body ()
(let ((spam-regex-headers-ham spam-regex-body-ham)
- (spam-regex-headers-spam spam-regex-body-spam))
+ (spam-regex-headers-spam spam-regex-body-spam))
(spam-check-regex-headers t)))
;;}}}
@@ -1980,20 +2008,20 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(defun spam-check-regex-headers (&optional body)
(let ((type (if body "body" "header"))
- ret found)
+ ret found)
(dolist (h-regex spam-regex-headers-ham)
(unless found
- (goto-char (point-min))
- (when (re-search-forward h-regex nil t)
- (message "Ham regex %s search positive." type)
- (setq found t))))
+ (goto-char (point-min))
+ (when (re-search-forward h-regex nil t)
+ (message "Ham regex %s search positive." type)
+ (setq found t))))
(dolist (s-regex spam-regex-headers-spam)
(unless found
- (goto-char (point-min))
- (when (re-search-forward s-regex nil t)
- (message "Spam regex %s search positive." type)
- (setq found t)
- (setq ret spam-split-group))))
+ (goto-char (point-min))
+ (when (re-search-forward s-regex nil t)
+ (message "Spam regex %s search positive." type)
+ (setq found t)
+ (setq ret spam-split-group))))
ret))
;;}}}
@@ -2003,44 +2031,44 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(defun spam-reverse-ip-string (ip)
(when (stringp ip)
(mapconcat 'identity
- (nreverse (split-string ip "\\."))
- ".")))
+ (nreverse (split-string ip "\\."))
+ ".")))
(defun spam-check-blackholes ()
"Check the Received headers for blackholed relays."
(let ((headers (message-fetch-field "received"))
- ips matches)
+ ips matches)
(when headers
(with-temp-buffer
- (insert headers)
- (goto-char (point-min))
- (gnus-message 6 "Checking headers for relay addresses")
- (while (re-search-forward
- "\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" nil t)
- (gnus-message 9 "Blackhole search found host IP %s." (match-string 1))
- (push (spam-reverse-ip-string (match-string 1))
- ips)))
+ (insert headers)
+ (goto-char (point-min))
+ (gnus-message 6 "Checking headers for relay addresses")
+ (while (re-search-forward
+ "\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" nil t)
+ (gnus-message 9 "Blackhole search found host IP %s." (match-string 1))
+ (push (spam-reverse-ip-string (match-string 1))
+ ips)))
(dolist (server spam-blackhole-servers)
- (dolist (ip ips)
- (unless (and spam-blackhole-good-server-regex
- ;; match the good-server-regex against the reversed (again) IP string
- (string-match
- spam-blackhole-good-server-regex
- (spam-reverse-ip-string ip)))
- (unless matches
- (let ((query-string (concat ip "." server)))
- (if spam-use-dig
- (let ((query-result (query-dig query-string)))
- (when query-result
- (gnus-message 6 "(DIG): positive blackhole check '%s'"
- query-result)
- (push (list ip server query-result)
- matches)))
- ;; else, if not using dig.el
- (when (dns-query query-string)
- (gnus-message 6 "positive blackhole check")
- (push (list ip server (dns-query query-string 'TXT))
- matches)))))))))
+ (dolist (ip ips)
+ (unless (and spam-blackhole-good-server-regex
+ ;; match against the reversed (again) IP string
+ (string-match
+ spam-blackhole-good-server-regex
+ (spam-reverse-ip-string ip)))
+ (unless matches
+ (let ((query-string (concat ip "." server)))
+ (if spam-use-dig
+ (let ((query-result (query-dig query-string)))
+ (when query-result
+ (gnus-message 6 "(DIG): positive blackhole check '%s'"
+ query-result)
+ (push (list ip server query-result)
+ matches)))
+ ;; else, if not using dig.el
+ (when (dns-query query-string)
+ (gnus-message 6 "positive blackhole check")
+ (push (list ip server (dns-query query-string 'TXT))
+ matches)))))))))
(when matches
spam-split-group)))
;;}}}
@@ -2049,7 +2077,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(defun spam-check-hashcash ()
"Check the headers for hashcash payments."
- (ignore-errors (mail-check-payment))) ;mail-check-payment returns a boolean
+ (ignore-errors (mail-check-payment))) ;mail-check-payment returns a boolean
;;}}}
@@ -2070,16 +2098,16 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(eval-and-compile
(when (condition-case nil
- (progn
- (require 'bbdb)
- (require 'bbdb-com))
- (file-error
- ;; `bbdb-records' should not be bound as an autoload function
- ;; before loading bbdb because of `bbdb-hashtable-size'.
- (defalias 'bbdb-records 'ignore)
- (defalias 'spam-BBDB-register-routine 'ignore)
- (defalias 'spam-enter-ham-BBDB 'ignore)
- nil))
+ (progn
+ (require 'bbdb)
+ (require 'bbdb-com))
+ (file-error
+ ;; `bbdb-records' should not be bound as an autoload function
+ ;; before loading bbdb because of `bbdb-hashtable-size'.
+ (defalias 'bbdb-records 'ignore)
+ (defalias 'spam-BBDB-register-routine 'ignore)
+ (defalias 'spam-enter-ham-BBDB 'ignore)
+ nil))
;; when the BBDB changes, we want to clear out our cache
(defun spam-clear-cache-BBDB (&rest immaterial)
@@ -2090,32 +2118,32 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(defun spam-enter-ham-BBDB (addresses &optional remove)
"Enter an address into the BBDB; implies ham (non-spam) sender"
(dolist (from addresses)
- (when (stringp from)
- (let* ((parsed-address (gnus-extract-address-components from))
- (name (or (nth 0 parsed-address) "Ham Sender"))
- (remove-function (if remove
- 'bbdb-delete-record-internal
- 'ignore))
- (net-address (nth 1 parsed-address))
- (record (and net-address
- (bbdb-search-simple nil net-address))))
- (when net-address
- (gnus-message 6 "%s address %s %s BBDB"
- (if remove "Deleting" "Adding")
- from
- (if remove "from" "to"))
- (if record
- (funcall remove-function record)
- (bbdb-create-internal name nil net-address nil nil
- "ham sender added by spam.el")))))))
+ (when (stringp from)
+ (let* ((parsed-address (gnus-extract-address-components from))
+ (name (or (nth 0 parsed-address) "Ham Sender"))
+ (remove-function (if remove
+ 'bbdb-delete-record-internal
+ 'ignore))
+ (net-address (nth 1 parsed-address))
+ (record (and net-address
+ (bbdb-search-simple nil net-address))))
+ (when net-address
+ (gnus-message 6 "%s address %s %s BBDB"
+ (if remove "Deleting" "Adding")
+ from
+ (if remove "from" "to"))
+ (if record
+ (funcall remove-function record)
+ (bbdb-create-internal name nil net-address nil nil
+ "ham sender added by spam.el")))))))
(defun spam-BBDB-register-routine (articles &optional unregister)
(let (addresses)
- (dolist (article articles)
- (when (stringp (spam-fetch-field-from-fast article))
- (push (spam-fetch-field-from-fast article) addresses)))
- ;; now do the register/unregister action
- (spam-enter-ham-BBDB addresses unregister)))
+ (dolist (article articles)
+ (when (stringp (spam-fetch-field-from-fast article))
+ (push (spam-fetch-field-from-fast article) addresses)))
+ ;; now do the register/unregister action
+ (spam-enter-ham-BBDB addresses unregister)))
(defun spam-BBDB-unregister-routine (articles)
(spam-BBDB-register-routine articles t))
@@ -2123,32 +2151,32 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(defun spam-check-BBDB ()
"Mail from people in the BBDB is classified as ham or non-spam"
(let ((who (message-fetch-field "from"))
- bbdb-cache bbdb-hashtable)
- (when spam-cache-lookups
- (setq bbdb-cache (gethash 'spam-use-BBDB spam-caches))
- (unless bbdb-cache
- (setq bbdb-cache (make-vector 17 0)) ; a good starting hash value
- ;; this is based on the expanded (bbdb-hashtable) macro
- ;; without the debugging support
- (with-current-buffer (bbdb-buffer)
- (save-excursion
- (save-window-excursion
- (bbdb-records nil t)
- (mapatoms
- (lambda (symbol)
- (intern (downcase (symbol-name symbol)) bbdb-cache))
- bbdb-hashtable))))
- (puthash 'spam-use-BBDB bbdb-cache spam-caches)))
- (when who
- (setq who (nth 1 (gnus-extract-address-components who)))
- (if
- (if spam-cache-lookups
- (intern-soft (downcase who) bbdb-cache)
- (bbdb-search-simple nil who))
- t
- (if spam-use-BBDB-exclusive
- spam-split-group
- nil)))))))
+ bbdb-cache bbdb-hashtable)
+ (when spam-cache-lookups
+ (setq bbdb-cache (gethash 'spam-use-BBDB spam-caches))
+ (unless bbdb-cache
+ (setq bbdb-cache (make-vector 17 0)) ; a good starting hash value
+ ;; this is based on the expanded (bbdb-hashtable) macro
+ ;; without the debugging support
+ (with-current-buffer (bbdb-buffer)
+ (save-excursion
+ (save-window-excursion
+ (bbdb-records nil t)
+ (mapatoms
+ (lambda (symbol)
+ (intern (downcase (symbol-name symbol)) bbdb-cache))
+ bbdb-hashtable))))
+ (puthash 'spam-use-BBDB bbdb-cache spam-caches)))
+ (when who
+ (setq who (nth 1 (gnus-extract-address-components who)))
+ (if
+ (if spam-cache-lookups
+ (intern-soft (downcase who) bbdb-cache)
+ (bbdb-search-simple nil who))
+ t
+ (if spam-use-BBDB-exclusive
+ spam-split-group
+ nil)))))))
;;}}}
@@ -2168,45 +2196,44 @@ See `spam-ifile-database'."
(defun spam-check-ifile ()
"Check the ifile backend for the classification of this message."
(let ((article-buffer-name (buffer-name))
- category return)
+ category return)
(with-temp-buffer
(let ((temp-buffer-name (buffer-name))
- (db-param (spam-get-ifile-database-parameter)))
- (save-excursion
- (set-buffer article-buffer-name)
- (apply 'call-process-region
- (point-min) (point-max) spam-ifile-program
- nil temp-buffer-name nil "-c"
- (if db-param `(,db-param "-q") `("-q"))))
- ;; check the return now (we're back in the temp buffer)
- (goto-char (point-min))
- (if (not (eobp))
- (setq category (buffer-substring (point) (point-at-eol))))
- (when (not (zerop (length category))) ; we need a category here
- (if spam-ifile-all-categories
- (setq return category)
- ;; else, if spam-ifile-all-categories is not set...
- (when (string-equal spam-ifile-spam-category category)
- (setq return spam-split-group)))))) ; note return is nil otherwise
+ (db-param (spam-get-ifile-database-parameter)))
+ (with-current-buffer article-buffer-name
+ (apply 'call-process-region
+ (point-min) (point-max) spam-ifile-program
+ nil temp-buffer-name nil "-c"
+ (if db-param `(,db-param "-q") `("-q"))))
+ ;; check the return now (we're back in the temp buffer)
+ (goto-char (point-min))
+ (if (not (eobp))
+ (setq category (buffer-substring (point) (point-at-eol))))
+ (when (not (zerop (length category))) ; we need a category here
+ (if spam-ifile-all-categories
+ (setq return category)
+ ;; else, if spam-ifile-all-categories is not set...
+ (when (string-equal spam-ifile-spam-category category)
+ (setq return spam-split-group)))))) ; note return is nil otherwise
return))
(defun spam-ifile-register-with-ifile (articles category &optional unregister)
"Register an article, given as a string, with a category.
Uses `gnus-newsgroup-name' if category is nil (for ham registration)."
(let ((category (or category gnus-newsgroup-name))
- (add-or-delete-option (if unregister "-d" "-i"))
- (db (spam-get-ifile-database-parameter))
- parameters)
+ (add-or-delete-option (if unregister "-d" "-i"))
+ (db (spam-get-ifile-database-parameter))
+ parameters)
(with-temp-buffer
(dolist (article articles)
- (let ((article-string (spam-get-article-as-string article)))
- (when (stringp article-string)
- (insert article-string))))
+ (let ((article-string (spam-get-article-as-string article)))
+ (when (stringp article-string)
+ (insert article-string))))
(apply 'call-process-region
- (point-min) (point-max) spam-ifile-program
- nil nil nil
- add-or-delete-option category
- (if db `(,db "-h") `("-h"))))))
+ (point-min) (point-max) spam-ifile-program
+ nil nil nil
+ add-or-delete-option category
+ (if db `(,db "-h") `("-h"))))))
(defun spam-ifile-register-spam-routine (articles &optional unregister)
(spam-ifile-register-with-ifile articles spam-ifile-spam-category unregister))
@@ -2235,40 +2262,40 @@ Uses `gnus-newsgroup-name' if category is nil (for ham registration)."
(eval-and-compile
(when (condition-case nil
- (let ((spam-stat-install-hooks nil))
- (require 'spam-stat))
- (file-error
- (defalias 'spam-stat-register-ham-routine 'ignore)
- (defalias 'spam-stat-register-spam-routine 'ignore)
- nil))
+ (let ((spam-stat-install-hooks nil))
+ (require 'spam-stat))
+ (file-error
+ (defalias 'spam-stat-register-ham-routine 'ignore)
+ (defalias 'spam-stat-register-spam-routine 'ignore)
+ nil))
(defun spam-check-stat ()
"Check the spam-stat backend for the classification of this message"
(let ((spam-stat-split-fancy-spam-group spam-split-group) ; override
- (spam-stat-buffer (buffer-name)) ; stat the current buffer
- category return)
- (spam-stat-split-fancy)))
+ (spam-stat-buffer (buffer-name)) ; stat the current buffer
+ category return)
+ (spam-stat-split-fancy)))
(defun spam-stat-register-spam-routine (articles &optional unregister)
(dolist (article articles)
- (let ((article-string (spam-get-article-as-string article)))
- (with-temp-buffer
- (insert article-string)
- (if unregister
- (spam-stat-buffer-change-to-non-spam)
- (spam-stat-buffer-is-spam))))))
+ (let ((article-string (spam-get-article-as-string article)))
+ (with-temp-buffer
+ (insert article-string)
+ (if unregister
+ (spam-stat-buffer-change-to-non-spam)
+ (spam-stat-buffer-is-spam))))))
(defun spam-stat-unregister-spam-routine (articles)
(spam-stat-register-spam-routine articles t))
(defun spam-stat-register-ham-routine (articles &optional unregister)
(dolist (article articles)
- (let ((article-string (spam-get-article-as-string article)))
- (with-temp-buffer
- (insert article-string)
- (if unregister
- (spam-stat-buffer-change-to-spam)
- (spam-stat-buffer-is-non-spam))))))
+ (let ((article-string (spam-get-article-as-string article)))
+ (with-temp-buffer
+ (insert article-string)
+ (if unregister
+ (spam-stat-buffer-change-to-spam)
+ (spam-stat-buffer-is-non-spam))))))
(defun spam-stat-unregister-ham-routine (articles)
(spam-stat-register-ham-routine articles t))
@@ -2318,38 +2345,37 @@ 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))
- (if (re-search-forward (regexp-quote a) nil t)
- ;; found the address
- (when remove
- (spam-kill-whole-line))
- ;; else, the address was not found
- (unless remove
- (goto-char (point-max))
- (unless (bobp)
- (insert "\n"))
- (insert a "\n")))))
+ (when (stringp a)
+ (goto-char (point-min))
+ (if (re-search-forward (regexp-quote a) nil t)
+ ;; found the address
+ (when remove
+ (spam-kill-whole-line))
+ ;; else, the address was not found
+ (unless remove
+ (goto-char (point-max))
+ (unless (bobp)
+ (insert "\n"))
+ (insert a "\n")))))
(save-buffer))))
(defun spam-filelist-build-cache (type)
(let ((cache (if (eq type 'spam-use-blacklist)
- spam-blacklist-cache
- spam-whitelist-cache))
- parsed-cache)
+ spam-blacklist-cache
+ spam-whitelist-cache))
+ parsed-cache)
(unless (gethash type spam-caches)
(while cache
- (let ((address (pop cache)))
- (unless (zerop (length address)) ; 0 for a nil address too
- (setq address (regexp-quote address))
- ;; fix regexp-quote's treatment of user-intended regexes
- (while (string-match "\\\\\\*" address)
- (setq address (replace-match ".*" t t address))))
- (push address parsed-cache)))
+ (let ((address (pop cache)))
+ (unless (zerop (length address)) ; 0 for a nil address too
+ (setq address (regexp-quote address))
+ ;; fix regexp-quote's treatment of user-intended regexes
+ (while (string-match "\\\\\\*" address)
+ (setq address (replace-match ".*" t t address))))
+ (push address parsed-cache)))
(puthash type parsed-cache spam-caches))))
(defun spam-filelist-check-cache (type from)
@@ -2357,9 +2383,9 @@ With a non-nil REMOVE, remove the ADDRESSES."
(spam-filelist-build-cache type)
(let (found)
(dolist (address (gethash type spam-caches))
- (when (and address (string-match address from))
- (setq found t)
- (return)))
+ (when (and address (string-match address from))
+ (setq found t)
+ (return)))
found)))
;;; returns t if the sender is in the whitelist, nil or
@@ -2371,7 +2397,7 @@ With a non-nil REMOVE, remove the ADDRESSES."
(if (spam-from-listed-p 'spam-use-whitelist)
t
(if spam-use-whitelist-exclusive
- spam-split-group
+ spam-split-group
nil)))
(defun spam-check-blacklist ()
@@ -2385,59 +2411,60 @@ With a non-nil REMOVE, remove the ADDRESSES."
(when (file-readable-p file)
(let (contents address)
(with-temp-buffer
- (insert-file-contents file)
- (while (not (eobp))
- (setq address (buffer-substring (point) (point-at-eol)))
- (forward-line 1)
- ;; insert the e-mail address if detected, otherwise the raw data
- (unless (zerop (length address))
- (let ((pure-address (nth 1 (gnus-extract-address-components address))))
- (push (or pure-address address) contents)))))
+ (insert-file-contents file)
+ (while (not (eobp))
+ (setq address (buffer-substring (point) (point-at-eol)))
+ (forward-line 1)
+ ;; insert the e-mail address if detected, otherwise the raw data
+ (unless (zerop (length address))
+ (let ((pure-address
+ (nth 1 (gnus-extract-address-components address))))
+ (push (or pure-address address) contents)))))
(nreverse contents))))
(defun spam-from-listed-p (type)
(let ((from (message-fetch-field "from"))
- found)
+ found)
(spam-filelist-check-cache type from)))
(defun spam-filelist-register-routine (articles blacklist &optional unregister)
(let ((de-symbol (if blacklist 'spam-use-whitelist 'spam-use-blacklist))
- (declassification (if blacklist 'ham 'spam))
- (enter-function
- (if blacklist 'spam-enter-blacklist 'spam-enter-whitelist))
- (remove-function
- (if blacklist 'spam-enter-whitelist 'spam-enter-blacklist))
- from addresses unregister-list article-unregister-list)
+ (declassification (if blacklist 'ham 'spam))
+ (enter-function
+ (if blacklist 'spam-enter-blacklist 'spam-enter-whitelist))
+ (remove-function
+ (if blacklist 'spam-enter-whitelist 'spam-enter-blacklist))
+ from addresses unregister-list article-unregister-list)
(dolist (article articles)
(let ((from (spam-fetch-field-from-fast article))
- (id (spam-fetch-field-message-id-fast article))
- sender-ignored)
- (when (stringp from)
- (dolist (ignore-regex spam-blacklist-ignored-regexes)
- (when (and (not sender-ignored)
- (stringp ignore-regex)
- (string-match ignore-regex from))
- (setq sender-ignored t)))
- ;; remember the messages we need to unregister, unless remove is set
- (when (and
- (null unregister)
- (spam-log-unregistration-needed-p
- id 'process declassification de-symbol))
- (push article article-unregister-list)
- (push from unregister-list))
- (unless sender-ignored
- (push from addresses)))))
+ (id (spam-fetch-field-message-id-fast article))
+ sender-ignored)
+ (when (stringp from)
+ (dolist (ignore-regex spam-blacklist-ignored-regexes)
+ (when (and (not sender-ignored)
+ (stringp ignore-regex)
+ (string-match ignore-regex from))
+ (setq sender-ignored t)))
+ ;; remember the messages we need to unregister, unless remove is set
+ (when (and
+ (null unregister)
+ (spam-log-unregistration-needed-p
+ id 'process declassification de-symbol))
+ (push article article-unregister-list)
+ (push from unregister-list))
+ (unless sender-ignored
+ (push from addresses)))))
(if unregister
- (funcall enter-function addresses t) ; unregister all these addresses
+ (funcall enter-function addresses t) ; unregister all these addresses
;; else, register normally and unregister what we need to
(funcall remove-function unregister-list t)
(dolist (article article-unregister-list)
- (spam-log-undo-registration
- (spam-fetch-field-message-id-fast article)
- 'process
- declassification
- de-symbol))
+ (spam-log-undo-registration
+ (spam-fetch-field-message-id-fast article)
+ 'process
+ declassification
+ de-symbol))
(funcall enter-function addresses nil))))
(defun spam-blacklist-unregister-routine (articles)
@@ -2468,9 +2495,9 @@ With a non-nil REMOVE, remove the ADDRESSES."
(defun spam-report-resend-register-routine (articles &optional ham)
(let* ((resend-to-gp
- (if ham
- (gnus-parameter-ham-resend-to gnus-newsgroup-name)
- (gnus-parameter-spam-resend-to gnus-newsgroup-name)))
+ (if ham
+ (gnus-parameter-ham-resend-to gnus-newsgroup-name)
+ (gnus-parameter-spam-resend-to gnus-newsgroup-name)))
(spam-report-resend-to (or (car-safe resend-to-gp)
spam-report-resend-to)))
(spam-report-resend articles ham)))
@@ -2480,15 +2507,15 @@ With a non-nil REMOVE, remove the ADDRESSES."
;;{{{ Bogofilter
(defun spam-check-bogofilter-headers (&optional score)
(let ((header (message-fetch-field spam-bogofilter-header)))
- (when header ; return nil when no header
- (if score ; scoring mode
- (if (string-match "spamicity=\\([0-9.]+\\)" header)
- (match-string 1 header)
- "0")
- ;; spam detection mode
- (when (string-match spam-bogofilter-bogosity-positive-spam-header
- header)
- spam-split-group)))))
+ (when header ; return nil when no header
+ (if score ; scoring mode
+ (if (string-match "spamicity=\\([0-9.]+\\)" header)
+ (match-string 1 header)
+ "0")
+ ;; spam detection mode
+ (when (string-match spam-bogofilter-bogosity-positive-spam-header
+ header)
+ spam-split-group)))))
;; return something sensible if the score can't be determined
(defun spam-bogofilter-score (&optional recheck)
@@ -2498,8 +2525,8 @@ With a non-nil REMOVE, remove the ADDRESSES."
(gnus-summary-show-article t)
(set-buffer gnus-article-buffer)
(let ((score (or (unless recheck
- (spam-check-bogofilter-headers t))
- (spam-check-bogofilter t))))
+ (spam-check-bogofilter-headers t))
+ (spam-check-bogofilter t))))
(gnus-summary-show-article)
(message "Spamicity score %s" score)
(or score "0"))))
@@ -2508,54 +2535,53 @@ With a non-nil REMOVE, remove the ADDRESSES."
"Verify the Bogofilter version is sufficient."
(when (eq spam-bogofilter-valid 'unknown)
(setq spam-bogofilter-valid
- (not (string-match "^bogofilter version 0\\.\\([0-9]\\|1[01]\\)\\."
- (shell-command-to-string
- (format "%s -V" spam-bogofilter-program))))))
+ (not (string-match "^bogofilter version 0\\.\\([0-9]\\|1[01]\\)\\."
+ (shell-command-to-string
+ (format "%s -V" spam-bogofilter-program))))))
spam-bogofilter-valid)
(defun spam-check-bogofilter (&optional score)
"Check the Bogofilter backend for the classification of this message."
(if (spam-verify-bogofilter)
(let ((article-buffer-name (buffer-name))
- (db spam-bogofilter-database-directory)
- return)
- (with-temp-buffer
- (let ((temp-buffer-name (buffer-name)))
- (save-excursion
- (set-buffer article-buffer-name)
- (apply 'call-process-region
- (point-min) (point-max)
- spam-bogofilter-program
- nil temp-buffer-name nil
- (if db `("-d" ,db "-v") `("-v"))))
- (setq return (spam-check-bogofilter-headers score))))
- return)
+ (db spam-bogofilter-database-directory)
+ return)
+ (with-temp-buffer
+ (let ((temp-buffer-name (buffer-name)))
+ (with-current-buffer article-buffer-name
+ (apply 'call-process-region
+ (point-min) (point-max)
+ spam-bogofilter-program
+ nil temp-buffer-name nil
+ (if db `("-d" ,db "-v") `("-v"))))
+ (setq return (spam-check-bogofilter-headers score))))
+ return)
(gnus-error 5 "`spam.el' doesn't support obsolete bogofilter versions")))
(defun spam-bogofilter-register-with-bogofilter (articles
- spam
- &optional unregister)
+ spam
+ &optional unregister)
"Register an article, given as a string, as spam or non-spam."
(if (spam-verify-bogofilter)
(dolist (article articles)
- (let ((article-string (spam-get-article-as-string article))
- (db spam-bogofilter-database-directory)
- (switch (if unregister
- (if spam
- spam-bogofilter-spam-strong-switch
- spam-bogofilter-ham-strong-switch)
- (if spam
- spam-bogofilter-spam-switch
- spam-bogofilter-ham-switch))))
- (when (stringp article-string)
- (with-temp-buffer
- (insert article-string)
-
- (apply 'call-process-region
- (point-min) (point-max)
- spam-bogofilter-program
- nil nil nil switch
- (if db `("-d" ,db "-v") `("-v")))))))
+ (let ((article-string (spam-get-article-as-string article))
+ (db spam-bogofilter-database-directory)
+ (switch (if unregister
+ (if spam
+ spam-bogofilter-spam-strong-switch
+ spam-bogofilter-ham-strong-switch)
+ (if spam
+ spam-bogofilter-spam-switch
+ spam-bogofilter-ham-switch))))
+ (when (stringp article-string)
+ (with-temp-buffer
+ (insert article-string)
+
+ (apply 'call-process-region
+ (point-min) (point-max)
+ spam-bogofilter-program
+ nil nil nil switch
+ (if db `("-d" ,db "-v") `("-v")))))))
(gnus-error 5 "`spam.el' doesn't support obsolete bogofilter versions")))
(defun spam-bogofilter-register-spam-routine (articles &optional unregister)
@@ -2579,46 +2605,45 @@ 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)
- (let ((status
- (apply 'call-process-region
- (point-min) (point-max)
- spam-spamoracle-binary
- nil temp-buffer-name nil
- (if spam-spamoracle-database
- `("-f" ,spam-spamoracle-database "mark")
- '("mark")))))
- (if (eq 0 status)
- (progn
- (set-buffer temp-buffer-name)
- (goto-char (point-min))
- (when (re-search-forward "^X-Spam: yes;" nil t)
- spam-split-group))
- (error "Error running spamoracle: %s" status))))))))
+ (with-current-buffer article-buffer-name
+ (let ((status
+ (apply 'call-process-region
+ (point-min) (point-max)
+ spam-spamoracle-binary
+ nil temp-buffer-name nil
+ (if spam-spamoracle-database
+ `("-f" ,spam-spamoracle-database "mark")
+ '("mark")))))
+ (if (eq 0 status)
+ (progn
+ (set-buffer temp-buffer-name)
+ (goto-char (point-min))
+ (when (re-search-forward "^X-Spam: yes;" nil t)
+ spam-split-group))
+ (error "Error running spamoracle: %s" status))))))))
(defun spam-spamoracle-learn (articles article-is-spam-p &optional unregister)
"Run spamoracle in training mode."
(with-temp-buffer
(let ((temp-buffer-name (buffer-name)))
(save-excursion
- (goto-char (point-min))
- (dolist (article articles)
- (insert (spam-get-article-as-string article)))
- (let* ((arg (if (spam-xor unregister article-is-spam-p)
- "-spam"
- "-good"))
- (status
- (apply 'call-process-region
- (point-min) (point-max)
- spam-spamoracle-binary
- nil temp-buffer-name nil
- (if spam-spamoracle-database
- `("-f" ,spam-spamoracle-database
- "add" ,arg)
- `("add" ,arg)))))
- (unless (eq 0 status)
- (error "Error running spamoracle: %s" status)))))))
+ (goto-char (point-min))
+ (dolist (article articles)
+ (insert (spam-get-article-as-string article)))
+ (let* ((arg (if (spam-xor unregister article-is-spam-p)
+ "-spam"
+ "-good"))
+ (status
+ (apply 'call-process-region
+ (point-min) (point-max)
+ spam-spamoracle-binary
+ nil temp-buffer-name nil
+ (if spam-spamoracle-database
+ `("-f" ,spam-spamoracle-database
+ "add" ,arg)
+ `("add" ,arg)))))
+ (unless (eq 0 status)
+ (error "Error running spamoracle: %s" status)))))))
(defun spam-spamoracle-learn-ham (articles &optional unregister)
(spam-spamoracle-learn articles nil unregister))
@@ -2638,32 +2663,31 @@ With a non-nil REMOVE, remove the ADDRESSES."
;;; based mostly on the bogofilter code
(defun spam-check-spamassassin-headers (&optional score)
"Check the SpamAssassin headers for the classification of this message."
- (if score ; scoring mode
+ (if score ; scoring mode
(let ((header (message-fetch-field spam-spamassassin-spam-status-header)))
- (when header
- (if (string-match spam-spamassassin-score-regexp header)
- (match-string 1 header)
- "0")))
+ (when header
+ (if (string-match spam-spamassassin-score-regexp header)
+ (match-string 1 header)
+ "0")))
;; spam detection mode
(let ((header (message-fetch-field spam-spamassassin-spam-flag-header)))
- (when header ; return nil when no header
- (when (string-match spam-spamassassin-positive-spam-flag-header
- header)
- spam-split-group)))))
+ (when header ; return nil when no header
+ (when (string-match spam-spamassassin-positive-spam-flag-header
+ header)
+ spam-split-group)))))
(defun spam-check-spamassassin (&optional score)
"Check the SpamAssassin backend for the classification of this message."
(let ((article-buffer-name (buffer-name)))
(with-temp-buffer
(let ((temp-buffer-name (buffer-name)))
- (save-excursion
- (set-buffer article-buffer-name)
- (apply 'call-process-region
- (point-min) (point-max) spam-assassin-program
- nil temp-buffer-name nil spam-spamassassin-arguments))
- ;; check the return now (we're back in the temp buffer)
- (goto-char (point-min))
- (spam-check-spamassassin-headers score)))))
+ (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))
+ ;; check the return now (we're back in the temp buffer)
+ (goto-char (point-min))
+ (spam-check-spamassassin-headers score)))))
;; return something sensible if the score can't be determined
(defun spam-spamassassin-score (&optional recheck)
@@ -2673,41 +2697,39 @@ With a non-nil REMOVE, remove the ADDRESSES."
(gnus-summary-show-article t)
(set-buffer gnus-article-buffer)
(let ((score (or (unless recheck
- (spam-check-spamassassin-headers t))
- (spam-check-spamassassin t))))
+ (spam-check-spamassassin-headers t))
+ (spam-check-spamassassin t))))
(gnus-summary-show-article)
(message "SpamAssassin score %s" score)
(or score "0"))))
(defun spam-spamassassin-register-with-sa-learn (articles spam
- &optional unregister)
+ &optional unregister)
"Register articles with spamassassin's sa-learn as spam or non-spam."
(if articles
(let ((action (if unregister spam-sa-learn-unregister-switch
- (if spam spam-sa-learn-spam-switch
- spam-sa-learn-ham-switch)))
- (summary-buffer-name (buffer-name)))
- (with-temp-buffer
- ;; group the articles into mbox format
- (dolist (article articles)
- (let (article-string)
- (save-excursion
- (set-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
- ; first five chars, so we can get away with
- ; a bogus line))
- (insert article-string)
- (insert "\n"))))
- ;; call sa-learn on all messages at the same time
- (apply 'call-process-region
- (point-min) (point-max)
- spam-sa-learn-program
- nil nil nil "--mbox"
- (if spam-sa-learn-rebuild
- (list action)
- `("--no-rebuild" ,action)))))))
+ (if spam spam-sa-learn-spam-switch
+ spam-sa-learn-ham-switch)))
+ (summary-buffer-name (buffer-name)))
+ (with-temp-buffer
+ ;; group the articles into mbox format
+ (dolist (article articles)
+ (let (article-string)
+ (with-current-buffer summary-buffer-name
+ (setq article-string (spam-get-article-as-string article)))
+ (when (stringp article-string)
+ ;; mbox separator
+ (insert (concat "From nobody " (current-time-string) "\n"))
+ (insert article-string)
+ (insert "\n"))))
+ ;; call sa-learn on all messages at the same time
+ (apply 'call-process-region
+ (point-min) (point-max)
+ spam-sa-learn-program
+ nil nil nil "--mbox"
+ (if spam-sa-learn-rebuild
+ (list action)
+ `("--no-rebuild" ,action)))))))
(defun spam-spamassassin-register-spam-routine (articles &optional unregister)
(spam-spamassassin-register-with-sa-learn articles t unregister))
@@ -2728,11 +2750,11 @@ With a non-nil REMOVE, remove the ADDRESSES."
(defun spam-check-bsfilter-headers (&optional score)
(if score
(or (nnmail-fetch-field spam-bsfilter-probability-header)
- "0")
+ "0")
(let ((header (nnmail-fetch-field spam-bsfilter-header)))
(when header ; return nil when no header
- (when (string-match "YES" header)
- spam-split-group)))))
+ (when (string-match "YES" header)
+ spam-split-group)))))
;; return something sensible if the score can't be determined
(defun spam-bsfilter-score (&optional recheck)
@@ -2742,8 +2764,8 @@ With a non-nil REMOVE, remove the ADDRESSES."
(gnus-summary-show-article t)
(set-buffer gnus-article-buffer)
(let ((score (or (unless recheck
- (spam-check-bsfilter-headers t))
- (spam-check-bsfilter t))))
+ (spam-check-bsfilter-headers t))
+ (spam-check-bsfilter t))))
(gnus-summary-show-article)
(message "Spamicity score %s" score)
(or score "0"))))
@@ -2751,48 +2773,47 @@ With a non-nil REMOVE, remove the ADDRESSES."
(defun spam-check-bsfilter (&optional score)
"Check the Bsfilter backend for the classification of this message."
(let ((article-buffer-name (buffer-name))
- (dir spam-bsfilter-database-directory)
- return)
+ (dir spam-bsfilter-database-directory)
+ return)
(with-temp-buffer
(let ((temp-buffer-name (buffer-name)))
- (save-excursion
- (set-buffer article-buffer-name)
- (apply 'call-process-region
- (point-min) (point-max)
- spam-bsfilter-program
- nil temp-buffer-name nil
- "--pipe"
- "--insert-flag"
- "--insert-probability"
- (when dir
- (list "--homedir" dir))))
- (setq return (spam-check-bsfilter-headers score))))
+ (with-current-buffer article-buffer-name
+ (apply 'call-process-region
+ (point-min) (point-max)
+ spam-bsfilter-program
+ nil temp-buffer-name nil
+ "--pipe"
+ "--insert-flag"
+ "--insert-probability"
+ (when dir
+ (list "--homedir" dir))))
+ (setq return (spam-check-bsfilter-headers score))))
return))
(defun spam-bsfilter-register-with-bsfilter (articles
- spam
- &optional unregister)
+ spam
+ &optional unregister)
"Register an article, given as a string, as spam or non-spam."
(dolist (article articles)
(let ((article-string (spam-get-article-as-string article))
- (switch (if unregister
- (if spam
- spam-bsfilter-spam-strong-switch
- spam-bsfilter-ham-strong-switch)
- (if spam
- spam-bsfilter-spam-switch
- spam-bsfilter-ham-switch))))
+ (switch (if unregister
+ (if spam
+ spam-bsfilter-spam-strong-switch
+ spam-bsfilter-ham-strong-switch)
+ (if spam
+ spam-bsfilter-spam-switch
+ spam-bsfilter-ham-switch))))
(when (stringp article-string)
- (with-temp-buffer
- (insert article-string)
- (apply 'call-process-region
- (point-min) (point-max)
- spam-bsfilter-program
- nil nil nil switch
- "--update"
- (when spam-bsfilter-database-directory
- (list "--homedir"
- spam-bsfilter-database-directory))))))))
+ (with-temp-buffer
+ (insert article-string)
+ (apply 'call-process-region
+ (point-min) (point-max)
+ spam-bsfilter-program
+ nil nil nil switch
+ "--update"
+ (when spam-bsfilter-database-directory
+ (list "--homedir"
+ spam-bsfilter-database-directory))))))))
(defun spam-bsfilter-register-spam-routine (articles &optional unregister)
(spam-bsfilter-register-with-bsfilter articles t unregister))
@@ -2811,15 +2832,15 @@ With a non-nil REMOVE, remove the ADDRESSES."
;;{{{ CRM114 Mailfilter
(defun spam-check-crm114-headers (&optional score)
(let ((header (message-fetch-field spam-crm114-header)))
- (when header ; return nil when no header
- (if score ; scoring mode
- (if (string-match "( pR: \\([0-9.-]+\\)" header)
- (match-string 1 header)
- "0")
- ;; spam detection mode
- (when (string-match spam-crm114-positive-spam-header
- header)
- spam-split-group)))))
+ (when header ; return nil when no header
+ (if score ; scoring mode
+ (if (string-match "( pR: \\([0-9.-]+\\)" header)
+ (match-string 1 header)
+ "0")
+ ;; spam detection mode
+ (when (string-match spam-crm114-positive-spam-header
+ header)
+ spam-split-group)))))
;; return something sensible if the score can't be determined
(defun spam-crm114-score ()
@@ -2829,7 +2850,7 @@ With a non-nil REMOVE, remove the ADDRESSES."
(gnus-summary-show-article t)
(set-buffer gnus-article-buffer)
(let ((score (or (spam-check-crm114-headers t)
- (spam-check-crm114 t))))
+ (spam-check-crm114 t))))
(gnus-summary-show-article)
(message "pR: %s" score)
(or score "0"))))
@@ -2837,42 +2858,41 @@ With a non-nil REMOVE, remove the ADDRESSES."
(defun spam-check-crm114 (&optional score)
"Check the CRM114 Mailfilter backend for the classification of this message."
(let ((article-buffer-name (buffer-name))
- (db spam-crm114-database-directory)
- return)
+ (db spam-crm114-database-directory)
+ return)
(with-temp-buffer
(let ((temp-buffer-name (buffer-name)))
- (save-excursion
- (set-buffer article-buffer-name)
- (apply 'call-process-region
- (point-min) (point-max)
- spam-crm114-program
- nil temp-buffer-name nil
+ (with-current-buffer article-buffer-name
+ (apply 'call-process-region
+ (point-min) (point-max)
+ spam-crm114-program
+ nil temp-buffer-name nil
(when db (list (concat "--fileprefix=" db)))))
- (setq return (spam-check-crm114-headers score))))
+ (setq return (spam-check-crm114-headers score))))
return))
(defun spam-crm114-register-with-crm114 (articles
- spam
- &optional unregister)
+ spam
+ &optional unregister)
"Register an article, given as a string, as spam or non-spam."
(dolist (article articles)
(let ((article-string (spam-get-article-as-string article))
- (db spam-crm114-database-directory)
- (switch (if unregister
- (if spam
- spam-crm114-spam-strong-switch
- spam-crm114-ham-strong-switch)
- (if spam
- spam-crm114-spam-switch
- spam-crm114-ham-switch))))
+ (db spam-crm114-database-directory)
+ (switch (if unregister
+ (if spam
+ spam-crm114-spam-strong-switch
+ spam-crm114-ham-strong-switch)
+ (if spam
+ spam-crm114-spam-switch
+ spam-crm114-ham-switch))))
(when (stringp article-string)
- (with-temp-buffer
- (insert article-string)
+ (with-temp-buffer
+ (insert article-string)
- (apply 'call-process-region
- (point-min) (point-max)
- spam-crm114-program
- nil nil nil
+ (apply 'call-process-region
+ (point-min) (point-max)
+ spam-crm114-program
+ nil nil nil
(when db (list switch (concat "--fileprefix=" db)))))))))
(defun spam-crm114-register-spam-routine (articles &optional unregister)
@@ -2912,7 +2932,7 @@ installed through `spam-necessary-extra-headers'."
(setq spam-install-hooks t)
;; TODO: How do we redo this every time the `spam' face is customized?
(push '((eq mark gnus-spam-mark) . spam)
- gnus-summary-highlight)
+ gnus-summary-highlight)
;; Add hooks for loading and saving the spam stats
(add-hook 'gnus-save-newsrc-hook 'spam-maybe-spam-stat-save)
(add-hook 'gnus-get-top-new-news-hook 'spam-maybe-spam-stat-load)
@@ -2941,5 +2961,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 5355119f406..4b4839a4df2 100644
--- a/lisp/gnus/starttls.el
+++ b/lisp/gnus/starttls.el
@@ -1,7 +1,6 @@
;;; starttls.el --- STARTTLS functions
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Daiki Ueno <ueno@unixuser.org>
;; Author: Simon Josefsson <simon@josefsson.org>
@@ -254,8 +253,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 +268,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 +310,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 9d2a475008c..f362931dcd0 100644
--- a/lisp/gnus/utf7.el
+++ b/lisp/gnus/utf7.el
@@ -1,7 +1,6 @@
;;; utf7.el --- UTF-7 encoding/decoding for Emacs -*-coding: iso-8859-1;-*-
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Jon K Hellan <hellan@acm.org>
;; Maintainer: bugs@gnus.org
@@ -78,7 +77,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 +111,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 +152,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 +204,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 +228,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 66a17fa7fd3..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, 2011 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 c31f59c64e4..c21dfbdb438 100644
--- a/lisp/gnus/yenc.el
+++ b/lisp/gnus/yenc.el
@@ -1,6 +1,6 @@
;;; yenc.el --- elisp native yenc decoder
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Jesper Harder <harder@ifa.au.dk>
;; Keywords: yenc news
@@ -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/gs.el b/lisp/gs.el
index a890a33db36..2eba7af71ae 100644
--- a/lisp/gs.el
+++ b/lisp/gs.el
@@ -1,7 +1,6 @@
;;; gs.el --- interface to Ghostscript
-;; Copyright (C) 1998, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
@@ -221,5 +220,4 @@ the form \"WINDOW-ID PIXMAP-ID\". Value is non-nil if successful."
(provide 'gs)
-;; arch-tag: 06ab51b8-4932-4cfe-9f60-b924a8edb3f0
;;; gs.el ends here
diff --git a/lisp/help-at-pt.el b/lisp/help-at-pt.el
index c4d11111173..d9012bdcad3 100644
--- a/lisp/help-at-pt.el
+++ b/lisp/help-at-pt.el
@@ -1,6 +1,6 @@
;;; help-at-pt.el --- local help through the keyboard
-;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003-2011 Free Software Foundation, Inc.
;; Author: Luc Teirlinck <teirllm@auburn.edu>
;; Keywords: help
@@ -350,5 +350,4 @@ different regions. With numeric argument ARG, behaves like
(provide 'help-at-pt)
-;; arch-tag: d0b8b86d-d23f-45d0-a82d-208d6205a583
;;; help-at-pt.el ends here
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index fbe87d99208..97ce7ca44ef 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -1,11 +1,11 @@
-;;; help-fns.el --- Complex help functions
+;;; help-fns.el --- Complex help functions -*- lexical-binding: t -*-
-;; Copyright (C) 1985, 1986, 1993, 1994, 1998, 1999, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+;; Copyright (C) 1985-1986, 1993-1994, 1998-2011
;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: help, internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -76,15 +76,18 @@ DEF is the function whose usage we're looking for in DOCSTRING."
;; Replace `fn' with the actual function name.
(if (consp def) "anonymous" def)
(match-string 1 docstring))
- (substring docstring 0 (match-beginning 0)))))
+ (unless (zerop (match-beginning 0))
+ (substring docstring 0 (match-beginning 0))))))
+;; FIXME: Move to subr.el?
(defun help-add-fundoc-usage (docstring arglist)
"Add the usage info to DOCSTRING.
If DOCSTRING already has a usage info, then just return it unchanged.
The usage info is built from ARGLIST. DOCSTRING can be nil.
ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"."
- (unless (stringp docstring) (setq docstring "Not documented"))
- (if (or (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" docstring) (eq arglist t))
+ (unless (stringp docstring) (setq docstring ""))
+ (if (or (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" docstring)
+ (eq arglist t))
docstring
(concat docstring
(if (string-match "\n?\n\\'" docstring)
@@ -95,18 +98,61 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"."
(concat "(fn" (match-string 1 arglist) ")")
(format "%S" (help-make-usage 'fn arglist))))))
-(defun help-function-arglist (def)
+;; FIXME: Move to subr.el?
+(defun help-function-arglist (def &optional preserve-names)
+ "Return a formal argument list for the function DEF.
+IF PRESERVE-NAMES is non-nil, return a formal arglist that uses
+the same names as used in the original source code, when possible."
;; Handle symbols aliased to other symbols.
(if (and (symbolp def) (fboundp def)) (setq def (indirect-function def)))
;; If definition is a macro, find the function inside it.
(if (eq (car-safe def) 'macro) (setq def (cdr def)))
(cond
- ((byte-code-function-p def) (aref def 0))
+ ((and (byte-code-function-p def) (listp (aref def 0))) (aref def 0))
((eq (car-safe def) 'lambda) (nth 1 def))
+ ((eq (car-safe def) 'closure) (nth 2 def))
+ ((or (and (byte-code-function-p def) (integerp (aref def 0)))
+ (subrp def))
+ (or (when preserve-names
+ (let* ((doc (condition-case nil (documentation def) (error nil)))
+ (docargs (if doc (car (help-split-fundoc doc nil))))
+ (arglist (if docargs
+ (cdar (read-from-string (downcase docargs)))))
+ (valid t))
+ ;; Check validity.
+ (dolist (arg arglist)
+ (unless (and (symbolp arg)
+ (let ((name (symbol-name arg)))
+ (if (eq (aref name 0) ?&)
+ (memq arg '(&rest &optional))
+ (not (string-match "\\." name)))))
+ (setq valid nil)))
+ (when valid arglist)))
+ (let* ((args-desc (if (not (subrp def))
+ (aref def 0)
+ (let ((a (subr-arity def)))
+ (logior (car a)
+ (if (numberp (cdr a))
+ (lsh (cdr a) 8)
+ (lsh 1 7))))))
+ (max (lsh args-desc -8))
+ (min (logand args-desc 127))
+ (rest (logand args-desc 128))
+ (arglist ()))
+ (dotimes (i min)
+ (push (intern (concat "arg" (number-to-string (1+ i)))) arglist))
+ (when (> max min)
+ (push '&optional arglist)
+ (dotimes (i (- max min))
+ (push (intern (concat "arg" (number-to-string (+ 1 i min))))
+ arglist)))
+ (unless (zerop rest) (push '&rest arglist) (push 'rest arglist))
+ (nreverse arglist))))
((and (eq (car-safe def) 'autoload) (not (eq (nth 4 def) 'keymap)))
"[Arg list not available until function definition is loaded.]")
(t t)))
+;; FIXME: Move to subr.el?
(defun help-make-usage (function arglist)
(cons (if (symbolp function) function 'anonymous)
(mapcar (lambda (arg)
@@ -117,8 +163,11 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"."
(cdr arg))
arg)
(let ((name (symbol-name arg)))
- (if (string-match "\\`&" name) arg
- (intern (upcase name))))))
+ (cond
+ ((string-match "\\`&" name) arg)
+ ((string-match "\\`_" name)
+ (intern (upcase (substring name 1))))
+ (t (intern (upcase name)))))))
arglist)))
;; Could be this, if we make symbol-file do the work below.
@@ -190,7 +239,7 @@ if the variable `help-downcase-arguments' is non-nil."
doc t t 1)))))
(defun help-highlight-arguments (usage doc &rest args)
- (when usage
+ (when (and usage (string-match "^(" usage))
(with-temp-buffer
(insert usage)
(goto-char (point-min))
@@ -288,13 +337,19 @@ suitable file is found, return nil."
((not (stringp file-name))
;; If we don't have a file-name string by now, we lost.
nil)
+ ;; Now, `file-name' should have become an absolute file name.
+ ;; For files loaded from ~/.emacs.elc, try ~/.emacs.
+ ((let (fn)
+ (and (string-equal file-name
+ (expand-file-name ".emacs.elc" "~"))
+ (file-readable-p (setq fn (expand-file-name ".emacs" "~")))
+ fn)))
+ ;; When the Elisp source file can be found in the install
+ ;; directory, return the name of that file.
((let ((lib-name
(if (string-match "[.]elc\\'" file-name)
(substring-no-properties file-name 0 -1)
file-name)))
- ;; When the Elisp source file can be found in the install
- ;; directory return the name of that file - `file-name' should
- ;; have become an absolute file name ny now.
(or (and (file-readable-p lib-name) lib-name)
;; The library might be compressed.
(and (file-readable-p (concat lib-name ".gz")) lib-name))))
@@ -347,8 +402,7 @@ suitable file is found, return nil."
(pt1 (with-current-buffer (help-buffer) (point)))
errtype)
(setq string
- (cond ((or (stringp def)
- (vectorp def))
+ (cond ((or (stringp def) (vectorp def))
"a keyboard macro")
((subrp def)
(if (eq 'unevalled (cdr (subr-arity def)))
@@ -367,6 +421,8 @@ suitable file is found, return nil."
(concat beg "Lisp function"))
((eq (car-safe def) 'macro)
"a Lisp macro")
+ ((eq (car-safe def) 'closure)
+ (concat beg "Lisp closure"))
((eq (car-safe def) 'autoload)
(format "%s autoloaded %s"
(if (commandp def) "an interactive" "an")
@@ -470,7 +526,8 @@ suitable file is found, return nil."
(let* ((advertised (gethash def advertised-signature-table t))
(arglist (if (listp advertised)
advertised (help-function-arglist def)))
- (doc (documentation function))
+ (doc (condition-case err (documentation function)
+ (error (format "No Doc! %S" err))))
(usage (help-split-fundoc doc function)))
(with-current-buffer standard-output
;; If definition is a keymap, skip arglist note.
@@ -527,6 +584,7 @@ If ANY-SYMBOL is non-nil, don't insist the symbol be bound."
(with-syntax-table emacs-lisp-mode-syntax-table
(or (condition-case ()
(save-excursion
+ (skip-chars-forward "'")
(or (not (zerop (skip-syntax-backward "_w")))
(eq (char-syntax (following-char)) ?w)
(eq (char-syntax (following-char)) ?_)
@@ -585,7 +643,7 @@ it is displayed along with the global value."
"Describe variable (default %s): " v)
"Describe variable: ")
obarray
- (lambda (vv)
+ (lambda (vv)
(or (get vv 'variable-documentation)
(and (boundp vv) (not (keywordp vv)))))
t nil nil
@@ -641,7 +699,20 @@ it is displayed along with the global value."
(pp val)
(if (< (point) (+ 68 (line-beginning-position 0)))
(delete-region from (1+ from))
- (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
(if (bufferp locus)
@@ -728,15 +799,21 @@ it is displayed along with the global value."
(setq extra-line t)
(if (member (cons variable val) dir-local-variables-alist)
(let ((file (and (buffer-file-name)
- (not (file-remote-p (buffer-file-name)))
- (dir-locals-find-file (buffer-file-name)))))
+ (not (file-remote-p (buffer-file-name)))
+ (dir-locals-find-file
+ (buffer-file-name))))
+ (type "file"))
(princ " This variable is a directory local variable")
(when file
- (princ (concat "\n from the file \""
- (if (consp file)
- (car file)
- file)
- "\"")))
+ (if (consp file) ; result from cache
+ ;; If the cache element has an mtime, we
+ ;; assume it came from a file.
+ (if (nth 2 file)
+ (setq file (expand-file-name
+ dir-locals-file (car file)))
+ ;; Otherwise, assume it was set directly.
+ (setq type "directory")))
+ (princ (format "\n from the %s \"%s\"" type file)))
(princ ".\n"))
(princ " This variable is a file local variable.\n")))
@@ -811,7 +888,7 @@ BUFFER defaults to the current buffer."
(insert (cond
((null value) "default")
((char-table-p value) "deeper char-table ...")
- (t (condition-case err
+ (t (condition-case nil
(category-set-mnemonics value)
(error "invalid"))))))
@@ -869,7 +946,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 acad46df0d6..8efb99d42d8 100644
--- a/lisp/help-macro.el
+++ b/lisp/help-macro.el
@@ -1,12 +1,12 @@
;;; help-macro.el --- makes command line help such as help-for-help
-;; Copyright (C) 1993, 1994, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1994, 2001-2011 Free Software Foundation, Inc.
;; Author: Lynn Slater <lrs@indetech.com>
;; Maintainer: FSF
;; Created: Mon Oct 1 11:42:39 1990
;; Adapted-By: ESR
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -201,5 +201,4 @@ and then returns."
(provide 'help-macro)
-;; arch-tag: 59fee949-1686-485a-8a05-83418073e257
;;; help-macro.el ends here
diff --git a/lisp/help-mode.el b/lisp/help-mode.el
index 573554aa448..642dac71ba6 100644
--- a/lisp/help-mode.el
+++ b/lisp/help-mode.el
@@ -1,10 +1,11 @@
;;; help-mode.el --- `help-mode' used by *Help* buffers
-;; Copyright (C) 1985, 1986, 1993, 1994, 1998, 1999, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1986, 1993-1994, 1998-2011
+;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: help, internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -32,18 +33,19 @@
(require 'view)
(eval-when-compile (require 'easymenu))
-(defvar help-mode-map (make-sparse-keymap)
+(defvar help-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map button-buffer-map)
+
+ (define-key map [mouse-2] 'help-follow-mouse)
+ (define-key map "\C-c\C-b" 'help-go-back)
+ (define-key map "\C-c\C-f" 'help-go-forward)
+ (define-key map "\C-c\C-c" 'help-follow-symbol)
+ ;; Documentation only, since we use minor-mode-overriding-map-alist.
+ (define-key map "\r" 'help-follow)
+ map)
"Keymap for help mode.")
-(set-keymap-parent help-mode-map button-buffer-map)
-
-(define-key help-mode-map [mouse-2] 'help-follow-mouse)
-(define-key help-mode-map "\C-c\C-b" 'help-go-back)
-(define-key help-mode-map "\C-c\C-f" 'help-go-forward)
-(define-key help-mode-map "\C-c\C-c" 'help-follow-symbol)
-;; Documentation only, since we use minor-mode-overriding-map-alist.
-(define-key help-mode-map "\r" 'help-follow)
-
(easy-menu-define help-mode-menu help-mode-map
"Menu for Help Mode."
'("Help-Mode"
@@ -160,7 +162,7 @@ The format is (FUNCTION ARGS...).")
(define-button-type 'help-info-variable
:supertype 'help-xref
;; the name of the variable is put before the argument to Info
- 'help-function (lambda (a v) (info v))
+ 'help-function (lambda (_a v) (info v))
'help-echo (purecopy "mouse-2, RET: read this Info node"))
(define-button-type 'help-info
@@ -244,6 +246,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 +293,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
@@ -302,6 +326,15 @@ Commands:
;; View mode's read-only status of existing *Help* buffer is lost
;; by with-output-to-temp-buffer.
(toggle-read-only 1)
+
+ (save-excursion
+ (goto-char (point-min))
+ (let ((inhibit-read-only t))
+ (when (re-search-forward "^This [^[:space:]]+ is advised.$" nil t)
+ (put-text-property (match-beginning 0)
+ (match-end 0)
+ 'face 'font-lock-warning-face))))
+
(help-make-xrefs (current-buffer))))
;; Grokking cross-reference information in doc strings and
@@ -376,13 +409,16 @@ restore it properly when going back."
(defun help-buffer ()
"Return the name of a buffer for inserting help.
If `help-xref-following' is non-nil, this is the name of the
-current buffer.
-Otherwise, it is *Help*; if no buffer with that name currently
-exists, it is created."
+current buffer. Signal an error if this buffer is not derived
+from `help-mode'.
+Otherwise, return \"*Help*\", creating a buffer with that name if
+it does not already exist."
(buffer-name ;for with-output-to-temp-buffer
- (if help-xref-following
- (current-buffer)
- (get-buffer-create "*Help*"))))
+ (if (not help-xref-following)
+ (get-buffer-create "*Help*")
+ (unless (derived-mode-p 'help-mode)
+ (error "Current buffer is not in Help mode"))
+ (current-buffer))))
(defvar help-xref-override-view-map
(let ((map (make-sparse-keymap)))
@@ -433,7 +469,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
@@ -740,7 +778,7 @@ help buffer."
(help-xref-go-forward (current-buffer))
(error "No next help buffer")))
-(defun help-do-xref (pos function args)
+(defun help-do-xref (_pos function args)
"Call the help cross-reference function FUNCTION with args ARGS.
Things are set up properly so that the resulting help-buffer has
a proper [back] button."
@@ -781,6 +819,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
@@ -793,5 +842,4 @@ help buffer by other means."
(provide 'help-mode)
-;; arch-tag: 850954ae-3725-4cb4-8e91-0bf6d52d6b0b
;;; help-mode.el ends here
diff --git a/lisp/help.el b/lisp/help.el
index 97690ea6b85..3a943274a14 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -1,10 +1,11 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1986, 1993-1994, 1998-2011
+;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: help, internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -103,6 +104,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 +119,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)
@@ -416,7 +415,7 @@ With argument, display info only for the selected version."
(beginning-of-line)
(point)))))))
-(defun view-emacs-todo (&optional arg)
+(defun view-emacs-todo (&optional _arg)
"Display the Emacs TODO list."
(interactive "P")
(view-help-file "TODO"))
@@ -872,8 +871,20 @@ whose documentation describes the minor mode."
(let ((start (point)))
(insert (format-mode-line mode nil nil buffer))
(add-text-properties start (point) '(face bold)))))
- (princ " mode:\n")
- (princ (documentation major-mode))))))
+ (princ " mode")
+ (let* ((mode major-mode)
+ (file-name (find-lisp-object-file-name mode nil)))
+ (when file-name
+ (princ (concat " defined in `" (file-name-nondirectory file-name) "'"))
+ ;; Make a hyperlink to the library.
+ (with-current-buffer standard-output
+ (save-excursion
+ (re-search-backward "`\\([^`']+\\)'" nil t)
+ (help-xref-button 1 'help-function-def mode file-name)))))
+ (princ ":\n")
+ (princ (documentation major-mode)))))
+ ;; For the sake of IELM and maybe others
+ nil)
(defun describe-minor-mode (minor-mode)
@@ -1245,8 +1256,16 @@ Select help window if the actual value of the user option
;; Reset `help-window' to nil to avoid confusing future calls of
;; `help-mode-finish' with plain `with-output-to-temp-buffer'.
(setq help-window nil))))
+
+;; Called from C, on encountering `help-char' when reading a char.
+;; Don't print to *Help*; that would clobber Help history.
+(defun help-form-show ()
+ "Display the output of a non-nil `help-form'."
+ (let ((msg (eval help-form)))
+ (if (stringp msg)
+ (with-output-to-temp-buffer " *Char Help*"
+ (princ msg)))))
(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 0139a672744..c5ef6ac906a 100644
--- a/lisp/hex-util.el
+++ b/lisp/hex-util.el
@@ -1,7 +1,6 @@
;;; hex-util.el --- Functions to encode/decode hexadecimal string.
-;; Copyright (C) 1999, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2001-2011 Free Software Foundation, Inc.
;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
;; Keywords: data
@@ -69,5 +68,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 6d04093b8a4..fdafd97cdab 100644
--- a/lisp/hexl.el
+++ b/lisp/hexl.el
@@ -1,7 +1,6 @@
-;;; hexl.el --- edit a file in a hex dump format using the hexl filter
+;;; hexl.el --- edit a file in a hex dump format using the hexl filter -*- lexical-binding: t -*-
-;; Copyright (C) 1989, 1994, 1998, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1989, 1994, 1998, 2001-2011 Free Software Foundation, Inc.
;; Author: Keith Gabryelski <ag@wheaties.ai.mit.edu>
;; Maintainer: FSF
@@ -97,7 +96,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)
@@ -107,19 +198,8 @@ Quoting cannot be used, so the arguments cannot themselves contain spaces."
(defvar hl-line-face)
;; Variables where the original values are stored to.
-(defvar hexl-mode-old-hl-line-mode)
-(defvar hexl-mode-old-hl-line-range-function)
-(defvar hexl-mode-old-hl-line-face)
-(defvar hexl-mode-old-local-map)
-(defvar hexl-mode-old-mode-name)
-(defvar hexl-mode-old-major-mode)
-(defvar hexl-mode-old-ruler-mode)
-(defvar hexl-mode-old-ruler-function)
-(defvar hexl-mode-old-isearch-search-fun-function)
-(defvar hexl-mode-old-require-final-newline)
-(defvar hexl-mode-old-syntax-table)
-(defvar hexl-mode-old-font-lock-keywords)
-(defvar hexl-mode-old-eldoc-documentation-function)
+(defvar hexl-mode--old-var-vals ())
+(make-variable-buffer-local 'hexl-mode--old-var-vals)
(defvar hexl-ascii-overlay nil
"Overlay used to highlight ASCII element corresponding to current point.")
@@ -136,6 +216,25 @@ Quoting cannot be used, so the arguments cannot themselves contain spaces."
(put 'hexl-mode 'mode-class 'special)
+
+(defun hexl-mode--minor-mode-p (var)
+ (memq var '(ruler-mode hl-line-mode)))
+
+(defun hexl-mode--setq-local (var val)
+ ;; `var' can be either a symbol or a pair, in which case the `car'
+ ;; is the getter function and the `cdr' is the corresponding setter.
+ (unless (or (member var hexl-mode--old-var-vals)
+ (assoc var hexl-mode--old-var-vals))
+ (push (if (or (consp var) (boundp var))
+ (cons var
+ (if (consp var) (funcall (car var)) (symbol-value var)))
+ var)
+ hexl-mode--old-var-vals))
+ (cond
+ ((consp var) (funcall (cdr var) val))
+ ((hexl-mode--minor-mode-p var) (funcall var (if val 1 -1)))
+ (t (set (make-local-variable var) val))))
+
;;;###autoload
(defun hexl-mode (&optional arg)
"\\<hexl-mode-map>A mode for editing binary files in hex dump format.
@@ -241,59 +340,31 @@ You can use \\[hexl-find-file] to visit a file in Hexl mode.
;; We do not turn off the old major mode; instead we just
;; override most of it. That way, we can restore it perfectly.
- (make-local-variable 'hexl-mode-old-local-map)
- (setq hexl-mode-old-local-map (current-local-map))
- (use-local-map hexl-mode-map)
-
- (make-local-variable 'hexl-mode-old-mode-name)
- (setq hexl-mode-old-mode-name mode-name)
- (setq mode-name "Hexl")
-
- (set (make-local-variable 'hexl-mode-old-isearch-search-fun-function)
- isearch-search-fun-function)
- (set (make-local-variable 'isearch-search-fun-function)
- 'hexl-isearch-search-function)
-
- (make-local-variable 'hexl-mode-old-major-mode)
- (setq hexl-mode-old-major-mode major-mode)
- (setq major-mode 'hexl-mode)
- (make-local-variable 'hexl-mode-old-ruler-mode)
- (setq hexl-mode-old-ruler-mode
- (and (boundp 'ruler-mode) ruler-mode))
+ (hexl-mode--setq-local '(current-local-map . use-local-map) hexl-mode-map)
- (make-local-variable 'hexl-mode-old-hl-line-mode)
- (setq hexl-mode-old-hl-line-mode
- (and (boundp 'hl-line-mode) hl-line-mode))
+ (hexl-mode--setq-local 'mode-name "Hexl")
+ (hexl-mode--setq-local 'isearch-search-fun-function
+ 'hexl-isearch-search-function)
+ (hexl-mode--setq-local 'major-mode 'hexl-mode)
- (make-local-variable 'hexl-mode-old-syntax-table)
- (setq hexl-mode-old-syntax-table (syntax-table))
- (set-syntax-table (standard-syntax-table))
+ (hexl-mode--setq-local '(syntax-table . set-syntax-table)
+ (standard-syntax-table))
(add-hook 'write-contents-functions 'hexl-save-buffer nil t)
- (make-local-variable 'hexl-mode-old-require-final-newline)
- (setq hexl-mode-old-require-final-newline require-final-newline)
- (make-local-variable 'require-final-newline)
- (setq require-final-newline nil)
+ (hexl-mode--setq-local 'require-final-newline nil)
- (make-local-variable 'hexl-mode-old-font-lock-keywords)
- (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)
+ (hexl-mode--setq-local 'font-lock-defaults '(hexl-font-lock-keywords t))
+ (hexl-mode--setq-local '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.
- (make-local-variable 'hexl-mode-old-eldoc-documentation-function)
- (setq hexl-mode-old-eldoc-documentation-function
- (bound-and-true-p eldoc-documentation-function))
-
- (set (make-local-variable 'eldoc-documentation-function)
- 'hexl-print-current-point-info)
+ (hexl-mode--setq-local 'eldoc-documentation-function
+ #'hexl-print-current-point-info)
(eldoc-add-command-completions "hexl-")
(eldoc-remove-command "hexl-save-buffer"
"hexl-current-address")
@@ -321,12 +392,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 +437,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,35 +473,26 @@ 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)
- (if (and (boundp 'ruler-mode) ruler-mode (not hexl-mode-old-ruler-mode))
- (ruler-mode 0))
- (when (boundp 'hexl-mode-old-ruler-function)
- (setq ruler-mode-ruler-function hexl-mode-old-ruler-function))
-
- (if (and (boundp 'hl-line-mode) hl-line-mode (not hexl-mode-old-hl-line-mode))
- (hl-line-mode 0))
- (when (boundp 'hexl-mode-old-hl-line-range-function)
- (setq hl-line-range-function hexl-mode-old-hl-line-range-function))
- (when (boundp 'hexl-mode-old-hl-line-face)
- (setq hl-line-face hexl-mode-old-hl-line-face))
-
- (when (boundp 'hexl-mode-old-eldoc-documentation-function)
- (setq eldoc-documentation-function
- hexl-mode-old-eldoc-documentation-function))
-
- (setq require-final-newline hexl-mode-old-require-final-newline)
- (setq mode-name hexl-mode-old-mode-name)
- (setq isearch-search-fun-function hexl-mode-old-isearch-search-fun-function)
- (use-local-map hexl-mode-old-local-map)
- (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)
+ (let ((mms ()))
+ (dolist (varval hexl-mode--old-var-vals)
+ (let* ((bound (consp varval))
+ (var (if bound (car varval) varval))
+ (val (cdr-safe varval)))
+ (cond
+ ((consp var) (funcall (cdr var) val))
+ ((hexl-mode--minor-mode-p var) (push (cons var val) mms))
+ (bound (set (make-local-variable var) val))
+ (t (kill-local-variable var)))))
+ (kill-local-variable 'hexl-mode--old-var-vals)
+ ;; Enable/disable minor modes. Do it after having reset the other vars,
+ ;; since some of them may affect the minor modes.
+ (dolist (mm mms)
+ (funcall (car mm) (if (cdr mm) 1 -1))))
+
(force-mode-line-update))
(defun hexl-maybe-dehexlify-buffer ()
@@ -518,23 +591,21 @@ Signal error if HEX-ADDRESS is out of range."
(progn
(setq arg (- arg))
(while (> arg 0)
- (if (not (equal address (logior address 3)))
- (if (> address hexl-max-address)
- (progn
- (message "End of buffer.")
- (setq address hexl-max-address))
- (setq address (logior address 3)))
- (if (> address hexl-max-address)
- (progn
- (message "End of buffer.")
- (setq address hexl-max-address))
- (setq address (+ address 4))))
+ (setq address
+ (if (> address hexl-max-address)
+ (progn
+ (message "End of buffer.")
+ hexl-max-address)
+ (if (equal address (logior address 3))
+ (+ address 4)
+ (logior address 3))))
(setq arg (1- arg)))
- (if (> address hexl-max-address)
- (progn
- (message "End of buffer.")
- (setq address hexl-max-address))
- (setq address (logior address 3))))
+ (setq address
+ (if (> address hexl-max-address)
+ (progn
+ (message "End of buffer.")
+ hexl-max-address)
+ (logior address 3))))
(while (> arg 0)
(if (not (equal address (logand address -4)))
(setq address (logand address -4))
@@ -557,23 +628,21 @@ Signal error if HEX-ADDRESS is out of range."
(progn
(setq arg (- arg))
(while (> arg 0)
- (if (not (equal address (logior address 7)))
- (if (> address hexl-max-address)
- (progn
- (message "End of buffer.")
- (setq address hexl-max-address))
- (setq address (logior address 7)))
- (if (> address hexl-max-address)
- (progn
- (message "End of buffer.")
- (setq address hexl-max-address))
- (setq address (+ address 8))))
+ (setq address
+ (if (> address hexl-max-address)
+ (progn
+ (message "End of buffer.")
+ hexl-max-address)
+ (if (equal address (logior address 7))
+ (+ address 8)
+ (logior address 7))))
(setq arg (1- arg)))
- (if (> address hexl-max-address)
- (progn
- (message "End of buffer.")
- (setq address hexl-max-address))
- (setq address (logior address 7))))
+ (setq address
+ (if (> address hexl-max-address)
+ (progn
+ (message "End of buffer.")
+ hexl-max-address)
+ (logior address 7))))
(while (> arg 0)
(if (not (equal address (logand address -8)))
(setq address (logand address -8))
@@ -644,18 +713,18 @@ With prefix arg N, puts point N bytes of the way from the true beginning."
(defun hexl-scroll-down (arg)
"Scroll hexl buffer window upward ARG lines; or near full window if no ARG."
(interactive "P")
- (if (null arg)
- (setq arg (1- (window-height)))
- (setq arg (prefix-numeric-value arg)))
+ (setq arg (if (null arg)
+ (1- (window-height))
+ (prefix-numeric-value arg)))
(hexl-scroll-up (- arg)))
(defun hexl-scroll-up (arg)
"Scroll hexl buffer window upward ARG lines; or near full window if no ARG.
If there's no byte at the target address, move to the first or last line."
(interactive "P")
- (if (null arg)
- (setq arg (1- (window-height)))
- (setq arg (prefix-numeric-value arg)))
+ (setq arg (if (null arg)
+ (1- (window-height))
+ (prefix-numeric-value arg)))
(let* ((movement (* arg 16))
(address (hexl-current-address))
(dest (+ address movement)))
@@ -683,10 +752,8 @@ If there's no byte at the target address, move to the first or last line."
(defun hexl-end-of-1k-page ()
"Go to end of 1KB boundary."
(interactive)
- (hexl-goto-address (let ((address (logior (hexl-current-address) 1023)))
- (if (> address hexl-max-address)
- (setq address hexl-max-address))
- address)))
+ (hexl-goto-address
+ (max hexl-max-address (logior (hexl-current-address) 1023))))
(defun hexl-beginning-of-512b-page ()
"Go to beginning of 512 byte boundary."
@@ -696,10 +763,8 @@ If there's no byte at the target address, move to the first or last line."
(defun hexl-end-of-512b-page ()
"Go to end of 512 byte boundary."
(interactive)
- (hexl-goto-address (let ((address (logior (hexl-current-address) 511)))
- (if (> address hexl-max-address)
- (setq address hexl-max-address))
- address)))
+ (hexl-goto-address
+ (max hexl-max-address (logior (hexl-current-address) 511))))
(defun hexl-quoted-insert (arg)
"Read next input character and insert it.
@@ -954,27 +1019,17 @@ Customize the variable `hexl-follow-ascii' to disable this feature."
(defun hexl-activate-ruler ()
"Activate `ruler-mode'."
(require 'ruler-mode)
- (unless (boundp 'hexl-mode-old-ruler-function)
- (set (make-local-variable 'hexl-mode-old-ruler-function)
- ruler-mode-ruler-function))
- (set (make-local-variable 'ruler-mode-ruler-function)
- 'hexl-mode-ruler)
- (ruler-mode 1))
+ (hexl-mode--setq-local 'ruler-mode-ruler-function
+ #'hexl-mode-ruler)
+ (hexl-mode--setq-local 'ruler-mode t))
(defun hexl-follow-line ()
"Activate `hl-line-mode'."
(require 'hl-line)
- (unless (boundp 'hexl-mode-old-hl-line-range-function)
- (set (make-local-variable 'hexl-mode-old-hl-line-range-function)
- hl-line-range-function))
- (unless (boundp 'hexl-mode-old-hl-line-face)
- (set (make-local-variable 'hexl-mode-old-hl-line-face)
- hl-line-face))
- (set (make-local-variable 'hl-line-range-function)
- 'hexl-highlight-line-range)
- (set (make-local-variable 'hl-line-face)
- 'highlight)
- (hl-line-mode 1))
+ (hexl-mode--setq-local 'hl-line-range-function
+ #'hexl-highlight-line-range)
+ (hexl-mode--setq-local 'hl-line-face 'highlight)
+ (hexl-mode--setq-local 'hl-line-mode t))
(defun hexl-highlight-line-range ()
"Return the range of address region for the point.
@@ -1017,100 +1072,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"
@@ -1150,5 +1111,4 @@ This function is assumed to be used as callback function for `hl-line-mode'."
(provide 'hexl)
-;; arch-tag: d5a7aa8a-9bce-480b-bcff-6c4c7ca5ea4a
;;; hexl.el ends here
diff --git a/lisp/hfy-cmap.el b/lisp/hfy-cmap.el
index 228de361fb7..7bf1da2bdd9 100644
--- a/lisp/hfy-cmap.el
+++ b/lisp/hfy-cmap.el
@@ -1,6 +1,6 @@
;;; hfy-cmap.el --- Fallback colour name -> rgb mapping for `htmlfontify'
-;; Copyright (C) 2002, 2003, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2003, 2009-2011 Free Software Foundation, Inc.
;; Emacs Lisp Archive Entry
;; Package: htmlfontify
@@ -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,20 @@ 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
-;; arch-tag: dff7feea-add4-48ba-937c-e79ac40cec9b
+;; Local Variables:
+;; generated-autoload-file: "htmlfontify.el"
+;; End:
+
+;;; hfy-cmap.el ends here
diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el
index 31d62723281..a0b5844582b 100644
--- a/lisp/hi-lock.el
+++ b/lisp/hi-lock.el
@@ -1,7 +1,6 @@
;;; hi-lock.el --- minor mode for interactive automatic highlighting
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Author: David M. Koppelman <koppel@ece.lsu.edu>
;; Keywords: faces, minor-mode, matching, display
@@ -88,8 +87,7 @@
;;; Code:
-(eval-and-compile
- (require 'font-lock))
+(require 'font-lock)
(defgroup hi-lock nil
"Interactively add and remove font-lock patterns for highlighting text."
@@ -240,45 +238,47 @@ a library is being loaded.")
(make-variable-buffer-local 'hi-lock-file-patterns)
(put 'hi-lock-file-patterns 'permanent-local t)
-(defvar hi-lock-menu (make-sparse-keymap "Hi Lock")
+(defvar hi-lock-menu
+ (let ((map (make-sparse-keymap "Hi Lock")))
+ (define-key-after map [highlight-regexp]
+ '(menu-item "Highlight Regexp..." highlight-regexp
+ :help "Highlight text matching PATTERN (a regexp)."))
+
+ (define-key-after map [highlight-phrase]
+ '(menu-item "Highlight Phrase..." highlight-phrase
+ :help "Highlight text matching PATTERN (a regexp processed to match phrases)."))
+
+ (define-key-after map [highlight-lines-matching-regexp]
+ '(menu-item "Highlight Lines..." highlight-lines-matching-regexp
+ :help "Highlight lines containing match of PATTERN (a regexp)."))
+
+ (define-key-after map [unhighlight-regexp]
+ '(menu-item "Remove Highlighting..." unhighlight-regexp
+ :help "Remove previously entered highlighting pattern."
+ :enable hi-lock-interactive-patterns))
+
+ (define-key-after map [hi-lock-write-interactive-patterns]
+ '(menu-item "Patterns to Buffer" hi-lock-write-interactive-patterns
+ :help "Insert interactively added REGEXPs into buffer at point."
+ :enable hi-lock-interactive-patterns))
+
+ (define-key-after map [hi-lock-find-patterns]
+ '(menu-item "Patterns from Buffer" hi-lock-find-patterns
+ :help "Use patterns (if any) near top of buffer."))
+ map)
"Menu for hi-lock mode.")
-(define-key-after hi-lock-menu [highlight-regexp]
- '(menu-item "Highlight Regexp..." highlight-regexp
- :help "Highlight text matching PATTERN (a regexp)."))
-
-(define-key-after hi-lock-menu [highlight-phrase]
- '(menu-item "Highlight Phrase..." highlight-phrase
- :help "Highlight text matching PATTERN (a regexp processed to match phrases)."))
-
-(define-key-after hi-lock-menu [highlight-lines-matching-regexp]
- '(menu-item "Highlight Lines..." highlight-lines-matching-regexp
- :help "Highlight lines containing match of PATTERN (a regexp)."))
-
-(define-key-after hi-lock-menu [unhighlight-regexp]
- '(menu-item "Remove Highlighting..." unhighlight-regexp
- :help "Remove previously entered highlighting pattern."
- :enable hi-lock-interactive-patterns))
-
-(define-key-after hi-lock-menu [hi-lock-write-interactive-patterns]
- '(menu-item "Patterns to Buffer" hi-lock-write-interactive-patterns
- :help "Insert interactively added REGEXPs into buffer at point."
- :enable hi-lock-interactive-patterns))
-
-(define-key-after hi-lock-menu [hi-lock-find-patterns]
- '(menu-item "Patterns from Buffer" hi-lock-find-patterns
- :help "Use patterns (if any) near top of buffer."))
-
-(defvar hi-lock-map (make-sparse-keymap "Hi Lock")
+(defvar hi-lock-map
+ (let ((map (make-sparse-keymap "Hi Lock")))
+ (define-key map "\C-xwi" 'hi-lock-find-patterns)
+ (define-key map "\C-xwl" 'highlight-lines-matching-regexp)
+ (define-key map "\C-xwp" 'highlight-phrase)
+ (define-key map "\C-xwh" 'highlight-regexp)
+ (define-key map "\C-xwr" 'unhighlight-regexp)
+ (define-key map "\C-xwb" 'hi-lock-write-interactive-patterns)
+ map)
"Key map for hi-lock.")
-(define-key hi-lock-map "\C-xwi" 'hi-lock-find-patterns)
-(define-key hi-lock-map "\C-xwl" 'highlight-lines-matching-regexp)
-(define-key hi-lock-map "\C-xwp" 'highlight-phrase)
-(define-key hi-lock-map "\C-xwh" 'highlight-regexp)
-(define-key hi-lock-map "\C-xwr" 'unhighlight-regexp)
-(define-key hi-lock-map "\C-xwb" 'hi-lock-write-interactive-patterns)
-
;; Visible Functions
;;;###autoload
@@ -665,5 +665,4 @@ A string is considered new if it had not previously been used in a call to
(provide 'hi-lock)
-;; arch-tag: d2e8fd07-4cc9-4c6f-a200-1e729bc54066
;;; hi-lock.el ends here
diff --git a/lisp/hilit-chg.el b/lisp/hilit-chg.el
index 0a18d89db41..6591ef44ff0 100644
--- a/lisp/hilit-chg.el
+++ b/lisp/hilit-chg.el
@@ -1,7 +1,6 @@
;;; hilit-chg.el --- minor mode displaying buffer changes with special face
-;; Copyright (C) 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 2000-2011 Free Software Foundation, Inc.
;; Author: Richard Sharman <rsharman@pobox.com>
;; Keywords: faces
@@ -386,7 +385,7 @@ This command does not itself set highlight-changes mode."
)
-(defun hilit-chg-cust-fix-changes-face-list (w wc &optional event)
+(defun hilit-chg-cust-fix-changes-face-list (w _wc &optional event)
;; When customization function `highlight-changes-face-list' inserts a new
;; face it uses the default face. We don't want the user to modify this
;; face, so we rename the faces in the list on an insert. The rename is
@@ -558,9 +557,9 @@ This allows you to manually remove highlighting from uninteresting changes."
;; otherwise an undone change shows up as changed. While the properties
;; are automatically restored by undo, we must fix up the overlay.
(save-match-data
- (let ((beg-decr 1) (end-incr 1)
- (type 'hilit-chg)
- old)
+ (let (;;(beg-decr 1)
+ (end-incr 1)
+ (type 'hilit-chg))
(if undo-in-progress
(if (and highlight-changes-mode
highlight-changes-visible-mode)
@@ -633,7 +632,7 @@ This removes all saved change information."
(highlight-save-buffer-state
(hilit-chg-hide-changes)
(hilit-chg-map-changes
- (lambda (prop start stop)
+ (lambda (_prop start stop)
(remove-text-properties start stop '(hilit-chg nil)))))
(setq highlight-changes-mode nil)
(force-mode-line-update)))
@@ -912,8 +911,7 @@ changes are made, so \\[highlight-changes-next-change] and
(file-a (buffer-file-name))
(existing-buf (get-file-buffer file-b))
(buf-b (or existing-buf
- (find-file-noselect file-b)))
- (buf-b-read-only (with-current-buffer buf-b buffer-read-only)))
+ (find-file-noselect file-b))))
(highlight-markup-buffers buf-a file-a buf-b file-b (not existing-buf))
(unless existing-buf
(kill-buffer buf-b))
@@ -921,24 +919,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 +954,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 +969,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 +1035,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 5367a640a23..75bc1f9743c 100644
--- a/lisp/hippie-exp.el
+++ b/lisp/hippie-exp.el
@@ -1,7 +1,6 @@
;;; hippie-exp.el --- expand text trying various ways to find its expansion
-;; Copyright (C) 1992, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 2001-2011 Free Software Foundation, Inc.
;; Author: Anders Holst <aho@sans.kth.se>
;; Last change: 3 March 1998
@@ -716,8 +715,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 +1182,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 2720574f37e..55704dccb33 100644
--- a/lisp/hl-line.el
+++ b/lisp/hl-line.el
@@ -1,7 +1,6 @@
;;; hl-line.el --- highlight the current line
-;; Copyright (C) 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 2000-2011 Free Software Foundation, Inc.
;; Author: Dave Love <fx@gnu.org>
;; Maintainer: FSF
@@ -72,7 +71,7 @@
(defgroup hl-line nil
"Highlight the current line."
:version "21.1"
- :group 'editing)
+ :group 'convenience)
(defface hl-line
'((t :inherit highlight))
@@ -219,5 +218,4 @@ the line including the point by OVERLAY."
(provide 'hl-line)
-;; arch-tag: ac806940-0876-4959-8c89-947563ee2833
;;; hl-line.el ends here
diff --git a/lisp/htmlfontify.el b/lisp/htmlfontify.el
index 535f9d15a03..c8e95581510 100644
--- a/lisp/htmlfontify.el
+++ b/lisp/htmlfontify.el
@@ -1,6 +1,6 @@
;;; htmlfontify.el --- htmlise a buffer/source tree with optional hyperlinks
-;; Copyright (C) 2002, 2003, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2003, 2009-2011 Free Software Foundation, Inc.
;; Emacs Lisp Archive Entry
;; Package: htmlfontify
@@ -15,6 +15,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 +91,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
@@ -140,13 +108,13 @@
`htmlfontify-load-rgb-file'
`htmlfontify-unload-rgb-file'\n
In order to:\n
-fontify a file you have open: M-x htmlfontify-buffer
-prepare the etags map for a directory: M-x htmlfontify-run-etags
-copy a directory, fontifying as you go: M-x htmlfontify-copy-and-link-dir\n
+fontify a file you have open: \\[htmlfontify-buffer]
+prepare the etags map for a directory: \\[htmlfontify-run-etags]
+copy a directory, fontifying as you go: \\[htmlfontify-copy-and-link-dir]\n
The following might be useful when running non-windowed or in batch mode:
\(note that they shouldn't be necessary - we have a built in map)\n
-load an X11 style rgb.txt file: M-x htmlfontify-load-rgb-file
-unload the current rgb.txt file: M-x htmlfontify-unload-rgb-file\n
+load an X11 style rgb.txt file: \\[htmlfontify-load-rgb-file]
+unload the current rgb.txt file: \\[htmlfontify-unload-rgb-file]\n
And here's a programmatic example:\n
\(defun rtfm-build-page-header (file style)
(format \"#define TEMPLATE red+black.html
@@ -182,10 +150,12 @@ main-content <=MAIN_CONTENT;\\n\" rtfm-section file style rtfm-section file))
:prefix "hfy-")
(defcustom hfy-page-header 'hfy-default-header
- "Function called with two arguments (the filename relative to the top
+ "Function called to build the header of the html source.
+This is called with two arguments (the filename relative to the top
level source directory being etag'd and fontified), and a string containing
-the <style>...</style> text to embed in the document- the string returned will
-be used as the header for the htmlfontified version of the source file.\n
+the <style>...</style> text to embed in the document.
+It should return the string returned will be used as the header for the
+htmlfontified version of the source file.\n
See also `hfy-page-footer'."
:group 'htmlfontify
;; FIXME: Why place such a :tag everywhere? Isn't it imposing your
@@ -194,16 +164,17 @@ See also `hfy-page-footer'."
:type '(function))
(defcustom hfy-split-index nil
- "Whether or not to split the index `hfy-index-file' alphabetically
-on the first letter of each tag. Useful when the index would otherwise
+ "Whether or not to split the index `hfy-index-file' alphabetically.
+If non-nil, the index is split on the first letter of each tag.
+Useful when the index would otherwise
be large and take a long time to render or be difficult to navigate."
:group 'htmlfontify
:tag "split-index"
:type '(boolean))
(defcustom hfy-page-footer 'hfy-default-footer
- "As `hfy-page-header', but generates the output footer
-\(and takes only one argument, the filename)."
+ "As `hfy-page-header', but generates the output footer.
+It takes only one argument, the filename."
:group 'htmlfontify
:tag "page-footer"
:type '(function))
@@ -236,7 +207,8 @@ code using this should fall back to `hfy-extn'."
:type '(choice string (const nil)))
(defcustom hfy-link-style-fun 'hfy-link-style-string
- "Set this to a function, which will be called with one argument
+ "Function to customize the appearance of hyperlinks.
+Set this to a function, which will be called with one argument
\(a \"{ foo: bar; ...}\" CSS style-string) - it should return a copy of
its argument, altered so as to make any changes you want made for text which
is a hyperlink, in addition to being in the class to which that style would
@@ -259,7 +231,7 @@ fontification-and-hyperlinking."
:tag "instance-file"
:type '(string))
-(defcustom hfy-html-quote-regex "\\(<\\|\"\\|&\\|>\\)"
+(defcustom hfy-html-quote-regex "\\([<\"&>]\\)"
"Regex to match (with a single back-reference per match) strings in HTML
which should be quoted with `hfy-html-quote' (and `hfy-html-quote-map')
to make them safe."
@@ -318,8 +290,7 @@ in order, to:\n
:group 'htmlfontify
:tag "html-quote-map"
:type '(alist :key-type (string)))
-(eval-and-compile
- (defconst hfy-e2x-etags-cmd "for src in `find . -type f`;
+(defconst hfy-e2x-etags-cmd "for src in `find . -type f`;
do
ETAGS=%s;
case ${src} in
@@ -350,17 +321,17 @@ do
esac;
done;")
- (defconst hfy-etags-cmd-alist-default
- `(("emacs etags" . ,hfy-e2x-etags-cmd)
- ("exuberant ctags" . "%s -R -f -" )))
+(defconst hfy-etags-cmd-alist-default
+ `(("emacs etags" . ,hfy-e2x-etags-cmd)
+ ("exuberant ctags" . "%s -R -f -" )))
- (defcustom hfy-etags-cmd-alist
- hfy-etags-cmd-alist-default
- "Alist of possible shell commands that will generate etags output that
+(defcustom hfy-etags-cmd-alist
+ hfy-etags-cmd-alist-default
+ "Alist of possible shell commands that will generate etags output that
`htmlfontify' can use. '%s' will be replaced by `hfy-etags-bin'."
- :group 'htmlfontify
- :tag "etags-cmd-alist"
- :type '(alist :key-type (string) :value-type (string)) ))
+ :group 'htmlfontify
+ :tag "etags-cmd-alist"
+ :type '(alist :key-type (string) :value-type (string)))
(defcustom hfy-etags-bin "etags"
"Location of etags binary (we begin by assuming it's in your path).\n
@@ -395,7 +366,13 @@ commands in `hfy-etags-cmd-alist'."
((string-match "GNU E" v) "emacs etags" )) ))
(defcustom hfy-etags-cmd
- (eval-and-compile (cdr (assoc (hfy-which-etags) hfy-etags-cmd-alist)))
+ ;; We used to wrap this in a `eval-and-compile', but:
+ ;; - it had no effect because this expression was not seen by the
+ ;; byte-compiler (defcustom used to quote this argument).
+ ;; - it signals an error (`hfy-which-etags' is not defined at compile-time).
+ ;; - we want this auto-detection to reflect the system on which Emacs is run
+ ;; rather than the one on which it's compiled.
+ (cdr (assoc (hfy-which-etags) hfy-etags-cmd-alist))
"The etags equivalent command to run in a source directory to generate a tags
file for the whole source tree from there on down. The command should emit
the etags output on stdout.\n
@@ -403,11 +380,10 @@ Two canned commands are provided - they drive Emacs' etags and
exuberant-ctags' etags respectively."
:group 'htmlfontify
:tag "etags-command"
- :type (eval-and-compile
- (let ((clist (list '(string))))
- (dolist (C hfy-etags-cmd-alist)
- (push (list 'const :tag (car C) (cdr C)) clist))
- (cons 'choice clist)) ))
+ :type (let ((clist (list '(string))))
+ (dolist (C hfy-etags-cmd-alist)
+ (push (list 'const :tag (car C) (cdr C)) clist))
+ (cons 'choice clist)))
(defcustom hfy-istext-command "file %s | sed -e 's@^[^:]*:[ \t]*@@'"
"Command to run with the name of a file, to see whether it is a text file
@@ -587,7 +563,8 @@ therefore no longer care about) will be invalid at any time.\n
(while sa
(setq elt (car sa)
sa (cdr sa))
- (if (memq elt set-b) (setq interq (cons elt interq)))) interq))
+ (if (memq elt set-b) (setq interq (cons elt interq))))
+ interq))
(defun hfy-colour-vals (colour)
"Where COLOUR is a color name or #XXXXXX style triplet, return a
@@ -618,7 +595,8 @@ in a windowing system - try to trick it..."
(setq cperl-syntaxify-by-font-lock t)))
(setq hfy-cperl-mode-kludged-p t))) )
-(defun hfy-opt (symbol) "Is option SYMBOL set." (memq symbol hfy-optimisations))
+(defun hfy-opt (symbol) "Is option SYMBOL set."
+ (memq symbol hfy-optimisations))
(defun hfy-default-header (file style)
"Default value for `hfy-page-header'.
@@ -732,7 +710,7 @@ STYLE is the inline CSS stylesheet (or tag referring to an external sheet)."
<body onload=\"stripe('index'); return true;\">\n"
file style))
-(defun hfy-default-footer (file)
+(defun hfy-default-footer (_file)
"Default value for `hfy-page-footer'.
FILE is the name of the file being rendered, in case it is needed."
"\n </body>\n</html>\n")
@@ -749,7 +727,8 @@ of the variable `hfy-src-doc-link-style', removing text matching the regex
(concat (replace-match hfy-src-doc-link-style
'fixed-case
'literal
- style-string) " }") style-string))
+ style-string) " }")
+ style-string))
;; utility functions - cast emacs style specification values into their
;; css2 equivalents:
@@ -846,7 +825,7 @@ regular specifiers."
((stringp box) (list (cons "border" (format "solid %s 1px" box))))
((listp box) (hfy-box-to-style box) ))) )
-(defun hfy-decor (tag val)
+(defun hfy-decor (tag _val)
"Derive CSS text-decoration specifiers from various Emacs font attributes.
TAG is an Emacs font attribute key (eg :underline).
VAL is ignored."
@@ -857,7 +836,7 @@ VAL is ignored."
(:overline (cons "text-decoration" "overline" ))
(:strike-through (cons "text-decoration" "line-through")))))
-(defun hfy-invisible (&optional val)
+(defun hfy-invisible (&optional _val)
"This text should be invisible.
Do something in CSS to make that happen.
VAL is ignored here."
@@ -867,11 +846,11 @@ VAL is ignored here."
"Return a `defface' style alist of possible specifications for FACE.
Entries resulting from customization (`custom-set-faces') will take
precedence."
- (let ((spec nil))
- (setq spec (append (or (get face 'saved-face) (list))
- (or (get face 'face-defface-spec) (list))))
- (if (and hfy-display-class hfy-default-face-def (eq face 'default))
- (setq spec (append hfy-default-face-def spec))) spec))
+ (append
+ (if (and hfy-display-class hfy-default-face-def (eq face 'default))
+ hfy-default-face-def)
+ (get face 'saved-face)
+ (get face 'face-defface-spec)))
(defun hfy-face-attr-for-class (face &optional class)
"Return the face attributes for FACE.
@@ -1077,10 +1056,9 @@ haven't encountered them yet. Returns a `hfy-style-assoc'."
and return a `hfy-style-assoc'.\n
See also `hfy-face-to-style-i', `hfy-flatten-style'."
;;(message "hfy-face-to-style");;DBUG
- (let ((face-def (hfy-face-resolve-face fn))
- (final-style nil))
-
- (setq final-style (hfy-flatten-style (hfy-face-to-style-i face-def)))
+ (let* ((face-def (hfy-face-resolve-face fn))
+ (final-style
+ (hfy-flatten-style (hfy-face-to-style-i face-def))))
;;(message "%S" final-style)
(if (not (assoc "text-decoration" final-style))
(progn (setq final-style
@@ -1122,8 +1100,9 @@ See also `hfy-face-to-style-i', `hfy-flatten-style'."
(string-match "^[Ii]nfo-\\(.*\\)" face-name))
(progn
(setq face-name (match-string 1 face-name))
- (if (string-match "\\(.*\\)-face$" face-name)
- (setq face-name (match-string 1 face-name))) face-name)
+ (if (string-match "\\(.*\\)-face\\'" face-name)
+ (setq face-name (match-string 1 face-name)))
+ face-name)
face-name)) )
;; construct an assoc of (stripped-name . "{ css-stuff-here }") pairs
@@ -1133,91 +1112,45 @@ See also `hfy-face-to-style-i', `hfy-flatten-style'."
and return a CSS style specification.\n
See also `hfy-face-to-style'."
;;(message "hfy-face-to-css");;DBUG
- (let ((css-list nil)
- (css-text nil)
- (seen nil))
- ;;(message "(hfy-face-to-style %S)" fn)
- (setq css-list (hfy-face-to-style fn))
- (setq css-text
+ (let* ((css-list (hfy-face-to-style fn))
+ (seen nil)
+ (css-text
(mapcar
(lambda (E)
(if (car E)
(unless (member (car E) seen)
(push (car E) seen)
(format " %s: %s; " (car E) (cdr E)))))
- css-list))
+ css-list)))
(cons (hfy-css-name fn) (format "{%s}" (apply 'concat css-text)))) )
-;; extract a face from a list of char properties, if there is one:
-(defun hfy-p-to-face (props)
- "Given PROPS, a list of text properties, return the value of the face
-property, or nil."
- (if props
- (if (string= (car props) "face")
- (let ((propval (cadr props)))
- (if (and (listp propval) (not (cdr propval)))
- (car propval)
- propval))
- (hfy-p-to-face (cddr props)))
- nil))
-
-(defun hfy-p-to-face-lennart (props)
- "Given PROPS, a list of text properties, return the value of the face
-property, or nil."
- (when props
- (let ((face (plist-get props 'face))
- (font-lock-face (plist-get props 'font-lock-face))
- (button (plist-get props 'button))
- ;;(face-rec (memq 'face props))
- ;;(button-rec (memq 'button props)))
- )
- (if button
- (let* ((category (plist-get props 'category))
- (face (when category (plist-get (symbol-plist category) 'face))))
- face)
- (or font-lock-face
- face)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; (defun hfy-get-face-at (pos)
-;; ;; (let ((face (get-char-property-and-overlay pos 'face)))
-;; ;; (when (and face (listp face)) (setq face (car face)))
-;; ;; (unless (listp face)
-;; ;; face)))
-;; ;;(get-char-property pos 'face)
-;; ;; Overlays are handled later
-;; (if (or (not show-trailing-whitespace)
-;; (not (get-text-property pos 'hfy-show-trailing-whitespace)))
-;; (get-text-property pos 'face)
-;; (list 'trailing-whitespace (get-text-property pos 'face)))
-;; )
-
-(defun hfy-prop-invisible-p (prop)
- "Is text property PROP an active invisibility property?"
- (or (and (eq buffer-invisibility-spec t) prop)
- (or (memq prop buffer-invisibility-spec)
- (assq prop buffer-invisibility-spec))))
+(defalias 'hfy-prop-invisible-p
+ (if (fboundp 'invisible-p) #'invisible-p
+ (lambda (prop)
+ "Is text property PROP an active invisibility property?"
+ (or (and (eq buffer-invisibility-spec t) prop)
+ (or (memq prop buffer-invisibility-spec)
+ (assq prop buffer-invisibility-spec))))))
(defun hfy-find-invisible-ranges ()
"Return a list of (start-point . end-point) cons cells of invisible regions."
- (let (invisible p i e s) ;; return-value pos invisible end start
- (save-excursion
+ (save-excursion
+ (let (invisible p i s) ;; return-value pos invisible end start
(setq p (goto-char (point-min)))
(when (invisible-p p) (setq s p i t))
(while (< p (point-max))
(if i ;; currently invisible
(when (not (invisible-p p)) ;; but became visible
- (setq e p
- i nil
- invisible (cons (cons s e) invisible)))
+ (setq i nil
+ invisible (cons (cons s p) invisible)))
;; currently visible:
(when (invisible-p p) ;; but have become invisible
(setq s p i t)))
(setq p (next-char-property-change p)))
;; still invisible at buffer end?
(when i
- (setq e (point-max)
- invisible (cons (cons s e) invisible))) ) invisible))
+ (setq invisible (cons (cons s (point-max)) invisible)))
+ invisible)))
(defun hfy-invisible-name (point map)
"Generate a CSS style name for an invisible section of the buffer.
@@ -1247,9 +1180,7 @@ return a `defface' style list of face properties instead of a face symbol."
;; not sure why we'd want to remove face-name? -- v
(let ((overlay-data nil)
(base-face nil)
- ;; restored hfy-p-to-face as it handles faces like (bold) as
- ;; well as face like 'bold - hfy-get-face-at doesn't dtrt -- v
- (face-name (hfy-p-to-face (text-properties-at p)))
+ (face-name (get-text-property p 'face))
;; (face-name (hfy-get-face-at p))
(prop-seen nil)
(extra-props nil)
@@ -1365,9 +1296,9 @@ return a `defface' style list of face properties instead of a face symbol."
extra-props (cons p (cons v extra-props))))))))))
;;(message "+ %d: %s; %S" p face-name extra-props)
(if extra-props
- (if (listp face-name)
- (nconc extra-props face-name)
- (nconc extra-props (face-attr-construct face-name)))
+ (nconc extra-props (if (listp face-name)
+ face-name
+ (face-attr-construct face-name)))
face-name)) ))
(defun hfy-overlay-props-at (p)
@@ -1410,7 +1341,8 @@ variable `font-lock-mode' and variable `font-lock-fontified' for truth."
(goto-char pt)
(while (and (< pt (point-max)) (not face-name))
(setq face-name (hfy-face-at pt))
- (setq pt (next-char-property-change pt)))) face-name)
+ (setq pt (next-char-property-change pt))))
+ face-name)
font-lock-mode)))
;; remember, the map is in reverse point order:
@@ -1473,12 +1405,13 @@ Returns a modified copy of FACE-MAP."
;; Fix-me: save table for multi-buffer
"Compile and return a `hfy-facemap-assoc' for the current buffer."
;;(message "hfy-compile-face-map");;DBUG
- (let ((pt (point-min))
- (pt-narrow 1)
- (fn nil)
- (map nil)
- (prev-tag nil)) ;; t if the last tag-point was a span-start
- ;; nil if it was a span-stop
+ (let* ((pt (point-min))
+ (pt-narrow (save-restriction (widen) (point-min)))
+ (offset (- pt pt-narrow))
+ (fn nil)
+ (map nil)
+ (prev-tag nil)) ;; t if the last tag-point was a span-start
+ ;; nil if it was a span-stop
(save-excursion
(goto-char pt)
(while (< pt (point-max))
@@ -1489,7 +1422,7 @@ Returns a modified copy of FACE-MAP."
(if prev-tag (push (cons pt-narrow 'end) map))
(setq prev-tag nil))
(setq pt (next-char-property-change pt))
- (setq pt-narrow (1+ (- pt (point-min)))))
+ (setq pt-narrow (+ offset pt)))
(if (and map (not (eq 'end (cdar map))))
(push (cons (- (point-max) (point-min)) 'end) map)))
(if (hfy-opt 'merge-adjacent-tags) (hfy-merge-adjacent-spans map) map)))
@@ -1506,7 +1439,7 @@ Otherwise a plausible filename is constructed from `default-directory',
(with-current-buffer buf
(setq buffer-file-name
(if src (concat src hfy-extn)
- (expand-file-name (if (string-match "^.*/\\([^/]*\\)$" name)
+ (expand-file-name (if (string-match "^.*/\\([^/]*\\)\\'" name)
(match-string 1 name)
name))))
buf)))
@@ -1524,23 +1457,22 @@ Uses `hfy-link-style-fun' to do this."
(defun hfy-sprintf-stylesheet (css file)
"Return the inline CSS style sheet for FILE as a string."
- (let ((stylesheet nil))
- (setq stylesheet
- (concat
- hfy-meta-tags
- "\n<style type=\"text/css\"><!-- \n"
- ;; Fix-me: Add handling of page breaks here + scan for ^L
- ;; where appropriate.
- (format "body %s\n" (cddr (assq 'default css)))
- (apply 'concat
- (mapcar
- (lambda (style)
- (format
- "span.%s %s\nspan.%s a %s\n"
- (cadr style) (cddr style)
- (cadr style) (hfy-link-style (cddr style))))
- css))
- " --></style>\n"))
+ (let ((stylesheet
+ (concat
+ hfy-meta-tags
+ "\n<style type=\"text/css\"><!-- \n"
+ ;; Fix-me: Add handling of page breaks here + scan for ^L
+ ;; where appropriate.
+ (format "body %s\n" (cddr (assq 'default css)))
+ (apply 'concat
+ (mapcar
+ (lambda (style)
+ (format
+ "span.%s %s\nspan.%s a %s\n"
+ (cadr style) (cddr style)
+ (cadr style) (hfy-link-style (cddr style))))
+ css))
+ " --></style>\n")))
(funcall hfy-page-header file stylesheet)))
;; tag all the dangerous characters we want to escape
@@ -1730,33 +1662,32 @@ FILE, if set, is the file name."
;; (message "checking to see whether we should link...")
(if (and srcdir file)
(let ((lp 'hfy-link)
- (pt nil)
+ (pt (point-min))
(pr nil)
(rr nil))
;; (message " yes we should.")
- ;; translate 'hfy-anchor properties to anchors
- (setq pt (point-min))
- (while (setq pt (next-single-property-change pt 'hfy-anchor))
- (if (setq pr (get-text-property pt 'hfy-anchor))
- (progn (goto-char pt)
- (remove-text-properties pt (1+ pt) '(hfy-anchor nil))
- (insert (concat "<a name=\"" pr "\"></a>")))))
- ;; translate alternate 'hfy-link and 'hfy-endl props to opening
- ;; and closing links. (this should avoid those spurious closes
- ;; we sometimes get by generating only paired tags)
- (setq pt (point-min))
- (while (setq pt (next-single-property-change pt lp))
- (if (not (setq pr (get-text-property pt lp))) nil
- (goto-char pt)
- (remove-text-properties pt (1+ pt) (list lp nil))
- (case lp
- (hfy-link
- (if (setq rr (get-text-property pt 'hfy-inst))
- (insert (format "<a name=\"%s\"></a>" rr)))
- (insert (format "<a href=\"%s\">" pr))
- (setq lp 'hfy-endl))
- (hfy-endl
- (insert "</a>") (setq lp 'hfy-link)) ))) ))
+ ;; translate 'hfy-anchor properties to anchors
+ (while (setq pt (next-single-property-change pt 'hfy-anchor))
+ (if (setq pr (get-text-property pt 'hfy-anchor))
+ (progn (goto-char pt)
+ (remove-text-properties pt (1+ pt) '(hfy-anchor nil))
+ (insert (concat "<a name=\"" pr "\"></a>")))))
+ ;; translate alternate 'hfy-link and 'hfy-endl props to opening
+ ;; and closing links. (this should avoid those spurious closes
+ ;; we sometimes get by generating only paired tags)
+ (setq pt (point-min))
+ (while (setq pt (next-single-property-change pt lp))
+ (if (not (setq pr (get-text-property pt lp))) nil
+ (goto-char pt)
+ (remove-text-properties pt (1+ pt) (list lp nil))
+ (case lp
+ (hfy-link
+ (if (setq rr (get-text-property pt 'hfy-inst))
+ (insert (format "<a name=\"%s\"></a>" rr)))
+ (insert (format "<a href=\"%s\">" pr))
+ (setq lp 'hfy-endl))
+ (hfy-endl
+ (insert "</a>") (setq lp 'hfy-link)) ))) ))
;; #####################################################################
;; transform the dangerous chars. This changes character positions
@@ -1822,13 +1753,13 @@ hyperlinks as appropriate."
;; pick up the file name in case we didn't receive it
(if (not file)
(progn (setq file (or (buffer-file-name) (buffer-name)))
- (if (string-match "/\\([^/]*\\)$" file)
+ (if (string-match "/\\([^/]*\\)\\'" file)
(setq file (match-string 1 file)))) )
(if (not (hfy-opt 'skip-refontification))
(save-excursion ;; Keep region
(hfy-force-fontification)))
- (if (interactive-p) ;; display the buffer in interactive mode:
+ (if (called-interactively-p 'any) ;; display the buffer in interactive mode:
(switch-to-buffer (hfy-fontify-buffer srcdir file))
(hfy-fontify-buffer srcdir file)))
@@ -1865,7 +1796,7 @@ Hardly bombproof, but good enough in the context in which it is being used."
"Is SRCDIR/FILE text? Uses `hfy-istext-command' to determine this."
(let* ((cmd (format hfy-istext-command (expand-file-name file srcdir)))
(rsp (shell-command-to-string cmd)))
- (if (string-match "text" rsp) t nil)))
+ (string-match "text" rsp)))
;; open a file, check fontification, if fontified, write a fontified copy
;; to the destination directory, otherwise just copy the file:
@@ -1898,18 +1829,17 @@ adding an extension of `hfy-extn'. Fontification is actually done by
(kill-buffer source)) ))
;; list of tags in file in srcdir
-(defun hfy-tags-for-file (srcdir file)
+(defun hfy-tags-for-file (cache-hash file)
"List of etags tags that have definitions in this FILE.
-Looks up the tags cache in `hfy-tags-cache' using SRCDIR as the key."
+CACHE-HASH is the tags cache."
;;(message "hfy-tags-for-file");;DBUG
- (let ((cache-entry (assoc srcdir hfy-tags-cache))
- (cache-hash nil)
- (tag-list nil))
- (if (setq cache-hash (cadr cache-entry))
+ (let* ((tag-list nil))
+ (if cache-hash
(maphash
(lambda (K V)
(if (assoc file V)
- (setq tag-list (cons K tag-list)))) cache-hash))
+ (setq tag-list (cons K tag-list))))
+ cache-hash))
tag-list))
;; mark the tags native to this file for anchors
@@ -1917,9 +1847,9 @@ Looks up the tags cache in `hfy-tags-cache' using SRCDIR as the key."
"Mark tags in FILE (lookup SRCDIR in `hfy-tags-cache') with the `hfy-anchor'
property, with a value of \"tag.line-number\"."
;;(message "(hfy-mark-tag-names %s %s)" srcdir file);;DBUG
- (let ((cache-entry (assoc srcdir hfy-tags-cache))
- (cache-hash nil))
- (if (setq cache-hash (cadr cache-entry))
+ (let* ((cache-entry (assoc srcdir hfy-tags-cache))
+ (cache-hash (cadr cache-entry)))
+ (if cache-hash
(mapcar
(lambda (TAG)
(mapcar
@@ -1932,7 +1862,7 @@ property, with a value of \"tag.line-number\"."
(+ 2 chr)
'hfy-anchor link))))
(gethash TAG cache-hash)))
- (hfy-tags-for-file srcdir file)))))
+ (hfy-tags-for-file cache-hash file)))))
(defun hfy-relstub (file &optional start)
"Return a \"../\" stub of the appropriate length for the current source
@@ -1941,7 +1871,8 @@ START is the offset at which to start looking for the / character in FILE."
;;(message "hfy-relstub");;DBUG
(let ((c ""))
(while (setq start (string-match "/" file start))
- (setq start (1+ start)) (setq c (concat c "../"))) c))
+ (setq start (1+ start)) (setq c (concat c "../")))
+ c))
(defun hfy-href-stub (this-file def-files tag)
"Return an href stub for a tag href in THIS-FILE.
@@ -2130,7 +2061,7 @@ FILE is the specific file we are rendering."
(puthash tag-string hash-entry cache-hash)))) )))
;; cache a list of tags in descending length order:
- (maphash (lambda (K V) (push K tags-list)) cache-hash)
+ (maphash (lambda (K _V) (push K tags-list)) cache-hash)
(setq tags-list (sort tags-list (lambda (A B) (< (length B) (length A)))))
;; put the tag list into the cache:
@@ -2161,7 +2092,7 @@ DSTDIR is the output directory, where files will be written."
(setq cache-hash (cadr cache-entry))
(setq index-buf (get-buffer-create index-file))))
nil ;; noop
- (maphash (lambda (K V) (push K tag-list)) cache-hash)
+ (maphash (lambda (K _V) (push K tag-list)) cache-hash)
(setq tag-list (sort tag-list 'string<))
(set-buffer index-buf)
(erase-buffer)
@@ -2205,7 +2136,7 @@ SRCDIR and DSTDIR are the source and output directories respectively."
(cache-entry (assoc srcdir hfy-tags-cache)))
(if (and cache-entry (setq cache-hash (cadr cache-entry)))
(maphash
- (lambda (K V)
+ (lambda (K _V)
(let ((stub (upcase (substring K 0 1))))
(if (member stub stub-list)
nil ;; seen this already: NOOP
@@ -2215,7 +2146,9 @@ SRCDIR and DSTDIR are the source and output directories respectively."
dstdir
hfy-index-file
stub)
- index-list)) ))) cache-hash) ) index-list)))
+ index-list)) )))
+ cache-hash) )
+ index-list)))
(defun hfy-prepare-tag-map (srcdir dstdir)
"Prepare the counterpart(s) to the index buffer(s) - a list of buffers
@@ -2236,7 +2169,7 @@ See also `hfy-prepare-index', `hfy-split-index'."
(if (and cache-entry (setq cache-hash (cadr cache-entry)))
(maphash
- (lambda (K V)
+ (lambda (K _V)
(let ((stub (upcase (substring K 0 1))))
(if (member stub stub-list)
nil ;; seen this already: NOOP
@@ -2247,7 +2180,9 @@ See also `hfy-prepare-index', `hfy-split-index'."
hfy-instance-file
stub
hfy-tags-rmap)
- index-list)) ))) cache-hash) ) index-list)))
+ index-list)) )))
+ cache-hash) )
+ index-list)))
(defun hfy-subtract-maps (srcdir)
"Internal function - strips definitions of tags from the instance map.
@@ -2274,8 +2209,7 @@ See also `hfy-tags-cache', `hfy-tags-rmap'."
"Load the etags cache for SRCDIR.
See also `hfy-load-tags-cache'."
(interactive "D source directory: ")
- (setq srcdir (directory-file-name srcdir))
- (hfy-load-tags-cache srcdir))
+ (hfy-load-tags-cache (directory-file-name srcdir)))
;;(defun hfy-test-read-args (foo bar)
;; (interactive "D source directory: \nD target directory: ")
@@ -2328,7 +2262,7 @@ You may also want to set `hfy-page-header' and `hfy-page-footer'."
;; (defalias 'hfy-set-hooks 'custom-set-variables)
;; (defun hfy-pp-hook (H)
-;; (and (string-match "-hook$" (symbol-name H))
+;; (and (string-match "-hook\\'" (symbol-name H))
;; (boundp H)
;; (symbol-value H)
;; (insert (format "\n '(%S %S)" H (symbol-value H)))
@@ -2379,7 +2313,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" "8dce008297f15826cc6ab82203c46fa6")
+;;; 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 95a753c6add..f4b729458e6 100644
--- a/lisp/ibuf-ext.el
+++ b/lisp/ibuf-ext.el
@@ -1,12 +1,12 @@
;;; ibuf-ext.el --- extensions for ibuffer
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Author: Colin Walters <walters@verbum.org>
;; 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 +91,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 +215,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 +235,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")
@@ -1228,12 +1219,10 @@ mean move backwards, non-negative integers mean move forwards."
(setq direction 1))
;; Skip the title
(ibuffer-forward-line 0)
- (let ((opos (point))
- curmark)
+ (let ((opos (point)))
(ibuffer-forward-line direction)
(while (not (or (= (point) opos)
- (eq (setq curmark (ibuffer-current-mark))
- mark)))
+ (eq (ibuffer-current-mark) mark)))
(ibuffer-forward-line direction))
(when (and (= (point) opos)
(not (eq (ibuffer-current-mark) mark)))
@@ -1256,7 +1245,7 @@ to move by. The default is `ibuffer-marked-char'."
(message "No buffers marked; use 'm' to mark a buffer")
(let ((count
(ibuffer-map-marked-lines
- #'(lambda (buf mark)
+ #'(lambda (_buf _mark)
'kill))))
(message "Killed %s lines" count))))
@@ -1288,7 +1277,7 @@ a prefix argument reverses the meaning of that variable."
(let (buf-point)
;; Blindly search for our buffer: it is very likely that it is
;; not in a hidden filter group.
- (ibuffer-map-lines #'(lambda (buf marks)
+ (ibuffer-map-lines #'(lambda (buf _marks)
(when (string= (buffer-name buf) name)
(setq buf-point (point))
nil))
@@ -1302,7 +1291,7 @@ a prefix argument reverses the meaning of that variable."
(dolist (group ibuffer-hidden-filter-groups)
(ibuffer-jump-to-filter-group group)
(ibuffer-toggle-filter-group)
- (ibuffer-map-lines #'(lambda (buf marks)
+ (ibuffer-map-lines #'(lambda (buf _marks)
(when (string= (buffer-name buf) name)
(setq buf-point (point))
nil))
@@ -1317,7 +1306,8 @@ a prefix argument reverses the meaning of that variable."
(error "No buffer with name %s" name)
(goto-char buf-point)))))
-(declare-function diff-sentinel "diff" (code))
+(declare-function diff-sentinel "diff"
+ (code &optional old-temp-file new-temp-file))
(defun ibuffer-diff-buffer-with-file-1 (buffer)
(let ((bufferfile (buffer-local-value 'buffer-file-name buffer))
@@ -1344,8 +1334,7 @@ a prefix argument reverses the meaning of that variable."
(format "Buffer %s" (buffer-name buffer)))))
,(shell-quote-argument (or oldtmp old))
,(shell-quote-argument (or newtmp new)))
- " "))
- proc)
+ " ")))
(let ((inhibit-read-only t))
(insert command "\n")
(diff-sentinel
@@ -1404,7 +1393,7 @@ You can then feed the file name(s) to other commands with \\[yank]."
(t
'name))))
(ibuffer-map-marked-lines
- #'(lambda (buf mark)
+ #'(lambda (buf _mark)
(setq ibuffer-copy-filename-as-kill-result
(concat ibuffer-copy-filename-as-kill-result
(let ((name (buffer-file-name buf)))
@@ -1425,7 +1414,7 @@ You can then feed the file name(s) to other commands with \\[yank]."
(defun ibuffer-mark-on-buffer (func &optional ibuffer-mark-on-buffer-mark group)
(let ((count
(ibuffer-map-lines
- #'(lambda (buf mark)
+ #'(lambda (buf _mark)
(when (funcall func buf)
(ibuffer-set-mark-1 (or ibuffer-mark-on-buffer-mark
ibuffer-marked-char))
@@ -1593,7 +1582,7 @@ defaults to one."
(let ((ibuffer-do-occur-bufs nil))
;; Accumulate a list of marked buffers
(ibuffer-map-marked-lines
- #'(lambda (buf mark)
+ #'(lambda (buf _mark)
(push buf ibuffer-do-occur-bufs)))
(occur-1 regexp nlines ibuffer-do-occur-bufs)))
@@ -1603,5 +1592,4 @@ defaults to one."
;; generated-autoload-file: "ibuffer.el"
;; End:
-;; arch-tag: 9af21953-deda-4c30-b76d-f81d9128e76d
;;; ibuf-ext.el ends here
diff --git a/lisp/ibuf-macs.el b/lisp/ibuf-macs.el
index 6fc6533b8dd..9965e0ccfb2 100644
--- a/lisp/ibuf-macs.el
+++ b/lisp/ibuf-macs.el
@@ -1,12 +1,12 @@
;;; ibuf-macs.el --- macros for ibuffer
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Author: Colin Walters <walters@verbum.org>
;; Maintainer: John Paul Wallington <jpw@gnu.org>
;; Created: 6 Dec 2001
;; Keywords: buffer, convenience
+;; Package: ibuffer
;; This file is part of GNU Emacs.
@@ -300,5 +300,4 @@ bound to the current value of the filter.
(provide 'ibuf-macs)
-;; arch-tag: 2748edce-82c9-4cd9-9d9d-bd73e43c20c5
;;; ibuf-macs.el ends here
diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el
index d6b4feb1613..5fda52f3d12 100644
--- a/lisp/ibuffer.el
+++ b/lisp/ibuffer.el
@@ -1,7 +1,6 @@
;;; ibuffer.el --- operate on buffers like dired
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Author: Colin Walters <walters@verbum.org>
;; Maintainer: John Paul Wallington <jpw@gnu.org>
@@ -332,8 +331,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)
@@ -384,14 +384,66 @@ directory, like `default-directory'."
(regexp :tag "To")))
:group 'ibuffer)
+(defvar ibuffer-mode-groups-popup
+ (let ((groups-map (make-sparse-keymap "Filter Groups")))
+ ;; Filter groups
+
+ (define-key-after groups-map [filters-to-filter-group]
+ '(menu-item "Create filter group from current filters..."
+ ibuffer-filters-to-filter-group
+ :enable (and (featurep 'ibuf-ext) ibuffer-filtering-qualifiers)))
+ (define-key-after groups-map [forward-filter-group]
+ '(menu-item "Move point to the next filter group"
+ ibuffer-forward-filter-group))
+ (define-key-after groups-map [backward-filter-group]
+ '(menu-item "Move point to the previous filter group"
+ ibuffer-backward-filter-group))
+ (define-key-after groups-map [jump-to-filter-group]
+ '(menu-item "Move point to a specific filter group..."
+ ibuffer-jump-to-filter-group))
+ (define-key-after groups-map [kill-filter-group]
+ '(menu-item "Kill filter group named..."
+ ibuffer-kill-filter-group
+ :enable (and (featurep 'ibuf-ext) ibuffer-filter-groups)))
+ (define-key-after groups-map [yank-filter-group]
+ '(menu-item "Yank last killed filter group before..."
+ ibuffer-yank-filter-group
+ :enable (and (featurep 'ibuf-ext) ibuffer-filter-group-kill-ring)))
+ (define-key-after groups-map [pop-filter-group]
+ '(menu-item "Remove top filter group"
+ ibuffer-pop-filter-group
+ :enable (and (featurep 'ibuf-ext) ibuffer-filter-groups)))
+ (define-key-after groups-map [clear-filter-groups]
+ '(menu-item "Remove all filter groups"
+ ibuffer-clear-filter-groups
+ :enable (and (featurep 'ibuf-ext) ibuffer-filter-groups)))
+ (define-key-after groups-map [pop-filter-group]
+ '(menu-item "Decompose filter group..."
+ ibuffer-pop-filter-group
+ :help "\"Unmake\" a filter group"
+ :enable (and (featurep 'ibuf-ext) ibuffer-filter-groups)))
+ (define-key-after groups-map [save-filter-groups]
+ '(menu-item "Save current filter groups permanently..."
+ ibuffer-save-filter-groups
+ :enable (and (featurep 'ibuf-ext) ibuffer-filter-groups)
+ :help "Use a mnemnonic name to store current filter groups"))
+ (define-key-after groups-map [switch-to-saved-filter-groups]
+ '(menu-item "Restore permanently saved filters..."
+ ibuffer-switch-to-saved-filter-groups
+ :enable (and (featurep 'ibuf-ext) ibuffer-saved-filter-groups)
+ :help "Replace current filters with a saved stack"))
+ (define-key-after groups-map [delete-saved-filter-groups]
+ '(menu-item "Delete permanently saved filter groups..."
+ ibuffer-delete-saved-filter-groups
+ :enable (and (featurep 'ibuf-ext) ibuffer-saved-filter-groups)))
+ (define-key-after groups-map [set-filter-groups-by-mode]
+ '(menu-item "Set current filter groups to filter by mode"
+ ibuffer-set-filter-groups-by-mode))
-(defvar ibuffer-mode-map nil)
-(defvar ibuffer-mode-operate-map nil)
-(defvar ibuffer-mode-groups-popup nil)
-(unless ibuffer-mode-map
- (let ((map (make-sparse-keymap))
- (operate-map (make-sparse-keymap "Operate"))
- (groups-map (make-sparse-keymap "Filter Groups")))
+ groups-map))
+
+(defvar ibuffer-mode-map
+ (let ((map (make-keymap)))
(define-key map (kbd "0") 'digit-argument)
(define-key map (kbd "1") 'digit-argument)
(define-key map (kbd "2") 'digit-argument)
@@ -432,10 +484,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 +526,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)
@@ -547,10 +597,10 @@ directory, like `default-directory'."
'(menu-item "View (other frame)" ibuffer-visit-buffer-other-frame))
(define-key-after map [menu-bar view ibuffer-update]
'(menu-item "Update" ibuffer-update
- :help "Regenerate the list of buffers"))
+ :help "Regenerate the list of buffers"))
(define-key-after map [menu-bar view switch-format]
'(menu-item "Switch display format" ibuffer-switch-format
- :help "Toggle between available values of `ibuffer-formats'"))
+ :help "Toggle between available values of `ibuffer-formats'"))
(define-key-after map [menu-bar view dashes]
'("--"))
@@ -564,28 +614,29 @@ directory, like `default-directory'."
'(menu-item "Sort by buffer size" ibuffer-do-sort-by-size))
(define-key-after map [menu-bar view sort do-sort-by-alphabetic]
'(menu-item "Sort lexicographically" ibuffer-do-sort-by-alphabetic
- :help "Sort by the alphabetic order of buffer name"))
+ :help "Sort by the alphabetic order of buffer name"))
(define-key-after map [menu-bar view sort do-sort-by-recency]
'(menu-item "Sort by view time" ibuffer-do-sort-by-recency
- :help "Sort by the last time the buffer was displayed"))
+ :help "Sort by the last time the buffer was displayed"))
(define-key-after map [menu-bar view sort dashes]
'("--"))
(define-key-after map [menu-bar view sort invert-sorting]
'(menu-item "Reverse sorting order" ibuffer-invert-sorting))
(define-key-after map [menu-bar view sort toggle-sorting-mode]
'(menu-item "Switch sorting mode" ibuffer-toggle-sorting-mode
- :help "Switch between the various sorting criteria"))
+ :help "Switch between the various sorting criteria"))
(define-key-after map [menu-bar view filter]
(cons "Filter" (make-sparse-keymap "Filter")))
(define-key-after map [menu-bar view filter filter-disable]
'(menu-item "Disable all filtering" ibuffer-filter-disable
- :enable (and (featurep 'ibuf-ext) ibuffer-filtering-qualifiers)))
+ :enable (and (featurep 'ibuf-ext) ibuffer-filtering-qualifiers)))
(define-key-after map [menu-bar view filter filter-by-mode]
'(menu-item "Add filter by major mode..." ibuffer-filter-by-mode))
(define-key-after map [menu-bar view filter filter-by-mode]
- '(menu-item "Add filter by major mode in use..." ibuffer-filter-by-used-mode))
+ '(menu-item "Add filter by major mode in use..."
+ ibuffer-filter-by-used-mode))
(define-key-after map [menu-bar view filter filter-by-name]
'(menu-item "Add filter by buffer name..." ibuffer-filter-by-name))
(define-key-after map [menu-bar view filter filter-by-filename]
@@ -593,158 +644,112 @@ directory, like `default-directory'."
(define-key-after map [menu-bar view filter filter-by-size-lt]
'(menu-item "Add filter by size less than..." ibuffer-filter-by-size-lt))
(define-key-after map [menu-bar view filter filter-by-size-gt]
- '(menu-item "Add filter by size greater than..." ibuffer-filter-by-size-gt))
+ '(menu-item "Add filter by size greater than..."
+ ibuffer-filter-by-size-gt))
(define-key-after map [menu-bar view filter filter-by-content]
- '(menu-item "Add filter by content (regexp)..." ibuffer-filter-by-content))
+ '(menu-item "Add filter by content (regexp)..."
+ ibuffer-filter-by-content))
(define-key-after map [menu-bar view filter filter-by-predicate]
- '(menu-item "Add filter by Lisp predicate..." ibuffer-filter-by-predicate))
+ '(menu-item "Add filter by Lisp predicate..."
+ ibuffer-filter-by-predicate))
(define-key-after map [menu-bar view filter pop-filter]
'(menu-item "Remove top filter" ibuffer-pop-filter
- :enable (and (featurep 'ibuf-ext) ibuffer-filtering-qualifiers)))
+ :enable (and (featurep 'ibuf-ext) ibuffer-filtering-qualifiers)))
(define-key-after map [menu-bar view filter or-filter]
'(menu-item "OR top two filters" ibuffer-or-filter
- :enable (and (featurep 'ibuf-ext) ibuffer-filtering-qualifiers
- (cdr ibuffer-filtering-qualifiers))
- :help "Create a new filter which is the logical OR of the top two filters"))
+ :enable (and (featurep 'ibuf-ext) ibuffer-filtering-qualifiers
+ (cdr ibuffer-filtering-qualifiers))
+ :help
+ "Create a new filter which is the logical OR of the top two filters"))
(define-key-after map [menu-bar view filter negate-filter]
'(menu-item "Negate top filter" ibuffer-negate-filter
- :enable (and (featurep 'ibuf-ext) ibuffer-filtering-qualifiers)))
+ :enable (and (featurep 'ibuf-ext) ibuffer-filtering-qualifiers)))
(define-key-after map [menu-bar view filter decompose-filter]
'(menu-item "Decompose top filter" ibuffer-decompose-filter
- :enable (and (featurep 'ibuf-ext) (memq (car ibuffer-filtering-qualifiers) '(or saved not)))
- :help "Break down a complex filter like OR or NOT"))
+ :enable (and (featurep 'ibuf-ext)
+ (memq (car ibuffer-filtering-qualifiers) '(or saved not)))
+ :help "Break down a complex filter like OR or NOT"))
(define-key-after map [menu-bar view filter exchange-filters]
'(menu-item "Swap top two filters" ibuffer-exchange-filters
- :enable (and (featurep 'ibuf-ext) ibuffer-filtering-qualifiers
- (cdr ibuffer-filtering-qualifiers))))
+ :enable (and (featurep 'ibuf-ext) ibuffer-filtering-qualifiers
+ (cdr ibuffer-filtering-qualifiers))))
(define-key-after map [menu-bar view filter save-filters]
'(menu-item "Save current filters permanently..." ibuffer-save-filters
- :enable (and (featurep 'ibuf-ext) ibuffer-filtering-qualifiers)
- :help "Use a mnemnonic name to store current filter stack"))
+ :enable (and (featurep 'ibuf-ext) ibuffer-filtering-qualifiers)
+ :help "Use a mnemnonic name to store current filter stack"))
(define-key-after map [menu-bar view filter switch-to-saved-filters]
- '(menu-item "Restore permanently saved filters..." ibuffer-switch-to-saved-filters
- :enable (and (featurep 'ibuf-ext) ibuffer-saved-filters)
- :help "Replace current filters with a saved stack"))
+ '(menu-item "Restore permanently saved filters..."
+ ibuffer-switch-to-saved-filters
+ :enable (and (featurep 'ibuf-ext) ibuffer-saved-filters)
+ :help "Replace current filters with a saved stack"))
(define-key-after map [menu-bar view filter add-saved-filters]
- '(menu-item "Add to permanently saved filters..." ibuffer-add-saved-filters
- :enable (and (featurep 'ibuf-ext) ibuffer-filtering-qualifiers)
- :help "Include already saved stack with current filters"))
+ '(menu-item "Add to permanently saved filters..."
+ ibuffer-add-saved-filters
+ :enable (and (featurep 'ibuf-ext) ibuffer-filtering-qualifiers)
+ :help "Include already saved stack with current filters"))
(define-key-after map [menu-bar view filter delete-saved-filters]
'(menu-item "Delete permanently saved filters..."
- ibuffer-delete-saved-filters
- :enable (and (featurep 'ibuf-ext) ibuffer-saved-filters)))
-
- ;; Filter groups
-
- (define-key-after groups-map [filters-to-filter-group]
- '(menu-item "Create filter group from current filters..."
- ibuffer-filters-to-filter-group
- :enable (and (featurep 'ibuf-ext) ibuffer-filtering-qualifiers)))
- (define-key-after groups-map [forward-filter-group]
- '(menu-item "Move point to the next filter group"
- ibuffer-forward-filter-group))
- (define-key-after groups-map [backward-filter-group]
- '(menu-item "Move point to the previous filter group"
- ibuffer-backward-filter-group))
- (define-key-after groups-map [jump-to-filter-group]
- '(menu-item "Move point to a specific filter group..."
- ibuffer-jump-to-filter-group))
- (define-key-after groups-map [kill-filter-group]
- '(menu-item "Kill filter group named..."
- ibuffer-kill-filter-group
- :enable (and (featurep 'ibuf-ext) ibuffer-filter-groups)))
- (define-key-after groups-map [yank-filter-group]
- '(menu-item "Yank last killed filter group before..."
- ibuffer-yank-filter-group
- :enable (and (featurep 'ibuf-ext) ibuffer-filter-group-kill-ring)))
- (define-key-after groups-map [pop-filter-group]
- '(menu-item "Remove top filter group"
- ibuffer-pop-filter-group
- :enable (and (featurep 'ibuf-ext) ibuffer-filter-groups)))
- (define-key-after groups-map [clear-filter-groups]
- '(menu-item "Remove all filter groups"
- ibuffer-clear-filter-groups
- :enable (and (featurep 'ibuf-ext) ibuffer-filter-groups)))
- (define-key-after groups-map [pop-filter-group]
- '(menu-item "Decompose filter group..."
- ibuffer-pop-filter-group
- :help "\"Unmake\" a filter group"
- :enable (and (featurep 'ibuf-ext) ibuffer-filter-groups)))
- (define-key-after groups-map [save-filter-groups]
- '(menu-item "Save current filter groups permanently..."
- ibuffer-save-filter-groups
- :enable (and (featurep 'ibuf-ext) ibuffer-filter-groups)
- :help "Use a mnemnonic name to store current filter groups"))
- (define-key-after groups-map [switch-to-saved-filter-groups]
- '(menu-item "Restore permanently saved filters..."
- ibuffer-switch-to-saved-filter-groups
- :enable (and (featurep 'ibuf-ext) ibuffer-saved-filter-groups)
- :help "Replace current filters with a saved stack"))
- (define-key-after groups-map [delete-saved-filter-groups]
- '(menu-item "Delete permanently saved filter groups..."
- ibuffer-delete-saved-filter-groups
- :enable (and (featurep 'ibuf-ext) ibuffer-saved-filter-groups)))
- (define-key-after groups-map [set-filter-groups-by-mode]
- '(menu-item "Set current filter groups to filter by mode"
- ibuffer-set-filter-groups-by-mode))
+ ibuffer-delete-saved-filters
+ :enable (and (featurep 'ibuf-ext) ibuffer-saved-filters)))
(define-key-after map [menu-bar view filter-groups]
- (cons "Filter Groups" groups-map))
+ (cons "Filter Groups" ibuffer-mode-groups-popup))
(define-key-after map [menu-bar view dashes2]
'("--"))
(define-key-after map [menu-bar view diff-with-file]
'(menu-item "Diff with file" ibuffer-diff-with-file
- :help "View the differences between this buffer and its file"))
+ :help "View the differences between this buffer and its file"))
(define-key-after map [menu-bar view auto-mode]
'(menu-item "Toggle Auto Mode" ibuffer-auto-mode
- :help "Attempt to automatically update the Ibuffer buffer"))
+ :help "Attempt to automatically update the Ibuffer buffer"))
(define-key-after map [menu-bar view customize]
'(menu-item "Customize Ibuffer" ibuffer-customize
- :help "Use Custom to customize Ibuffer"))
+ :help "Use Custom to customize Ibuffer"))
(define-key-after map [menu-bar mark]
(cons "Mark" (make-sparse-keymap "Mark")))
(define-key-after map [menu-bar mark toggle-marks]
'(menu-item "Toggle marks" ibuffer-toggle-marks
- :help "Unmark marked buffers, and mark unmarked buffers"))
+ :help "Unmark marked buffers, and mark unmarked buffers"))
(define-key-after map [menu-bar mark mark-forward]
'(menu-item "Mark" ibuffer-mark-forward
- :help "Mark the buffer at point"))
+ :help "Mark the buffer at point"))
(define-key-after map [menu-bar mark unmark-forward]
'(menu-item "Unmark" ibuffer-unmark-forward
- :help "Unmark the buffer at point"))
+ :help "Unmark the buffer at point"))
(define-key-after map [menu-bar mark mark-by-mode]
'(menu-item "Mark by mode..." ibuffer-mark-by-mode
- :help "Mark all buffers in a particular major mode"))
+ :help "Mark all buffers in a particular major mode"))
(define-key-after map [menu-bar mark mark-modified-buffers]
'(menu-item "Mark modified buffers" ibuffer-mark-modified-buffers
- :help "Mark all buffers which have been modified"))
+ :help "Mark all buffers which have been modified"))
(define-key-after map [menu-bar mark mark-unsaved-buffers]
'(menu-item "Mark unsaved buffers" ibuffer-mark-unsaved-buffers
- :help "Mark all buffers which have a file and are modified"))
+ :help "Mark all buffers which have a file and are modified"))
(define-key-after map [menu-bar mark mark-read-only-buffers]
'(menu-item "Mark read-only buffers" ibuffer-mark-read-only-buffers
- :help "Mark all buffers which are read-only"))
+ :help "Mark all buffers which are read-only"))
(define-key-after map [menu-bar mark mark-special-buffers]
'(menu-item "Mark special buffers" ibuffer-mark-special-buffers
- :help "Mark all buffers whose name begins with a *"))
+ :help "Mark all buffers whose name begins with a *"))
(define-key-after map [menu-bar mark mark-dired-buffers]
'(menu-item "Mark dired buffers" ibuffer-mark-dired-buffers
- :help "Mark buffers in dired-mode"))
+ :help "Mark buffers in dired-mode"))
(define-key-after map [menu-bar mark mark-dissociated-buffers]
'(menu-item "Mark dissociated buffers" ibuffer-mark-dissociated-buffers
- :help "Mark buffers with a non-existent associated file"))
+ :help "Mark buffers with a non-existent associated file"))
(define-key-after map [menu-bar mark mark-help-buffers]
'(menu-item "Mark help buffers" ibuffer-mark-help-buffers
- :help "Mark buffers in help-mode"))
+ :help "Mark buffers in help-mode"))
(define-key-after map [menu-bar mark mark-compressed-file-buffers]
- '(menu-item "Mark compressed file buffers" ibuffer-mark-compressed-file-buffers
- :help "Mark buffers which have a file that is compressed"))
+ '(menu-item "Mark compressed file buffers"
+ ibuffer-mark-compressed-file-buffers
+ :help "Mark buffers which have a file that is compressed"))
(define-key-after map [menu-bar mark mark-old-buffers]
'(menu-item "Mark old buffers" ibuffer-mark-old-buffers
- :help "Mark buffers which have not been viewed recently"))
+ :help "Mark buffers which have not been viewed recently"))
(define-key-after map [menu-bar mark unmark-all]
'(menu-item "Unmark All" ibuffer-unmark-all))
@@ -753,16 +758,19 @@ directory, like `default-directory'."
(define-key-after map [menu-bar mark mark-by-name-regexp]
'(menu-item "Mark by buffer name (regexp)..." ibuffer-mark-by-name-regexp
- :help "Mark buffers whose name matches a regexp"))
+ :help "Mark buffers whose name matches a regexp"))
(define-key-after map [menu-bar mark mark-by-mode-regexp]
'(menu-item "Mark by major mode (regexp)..." ibuffer-mark-by-mode-regexp
- :help "Mark buffers whose major mode name matches a regexp"))
+ :help "Mark buffers whose major mode name matches a regexp"))
(define-key-after map [menu-bar mark mark-by-file-name-regexp]
- '(menu-item "Mark by file name (regexp)..." ibuffer-mark-by-file-name-regexp
- :help "Mark buffers whose file name matches a regexp"))
+ '(menu-item "Mark by file name (regexp)..."
+ ibuffer-mark-by-file-name-regexp
+ :help "Mark buffers whose file name matches a regexp"))
- ;; Operate map is added later
+ map))
+(defvar ibuffer-mode-operate-map
+ (let ((operate-map (make-sparse-keymap "Operate")))
(define-key-after operate-map [do-view]
'(menu-item "View" ibuffer-do-view))
(define-key-after operate-map [do-view-other-frame]
@@ -771,47 +779,45 @@ directory, like `default-directory'."
'(menu-item "Save" ibuffer-do-save))
(define-key-after operate-map [do-replace-regexp]
'(menu-item "Replace (regexp)..." ibuffer-do-replace-regexp
- :help "Replace text inside marked buffers"))
+ :help "Replace text inside marked buffers"))
(define-key-after operate-map [do-query-replace]
'(menu-item "Query Replace..." ibuffer-do-query-replace
- :help "Replace text in marked buffers, asking each time"))
+ :help "Replace text in marked buffers, asking each time"))
(define-key-after operate-map [do-query-replace-regexp]
'(menu-item "Query Replace (regexp)..." ibuffer-do-query-replace-regexp
- :help "Replace text in marked buffers by regexp, asking each time"))
+ :help "Replace text in marked buffers by regexp, asking each time"))
(define-key-after operate-map [do-print]
'(menu-item "Print" ibuffer-do-print))
(define-key-after operate-map [do-toggle-modified]
'(menu-item "Toggle modification flag" ibuffer-do-toggle-modified))
(define-key-after operate-map [do-revert]
'(menu-item "Revert" ibuffer-do-revert
- :help "Revert marked buffers to their associated file"))
+ :help "Revert marked buffers to their associated file"))
(define-key-after operate-map [do-rename-uniquely]
'(menu-item "Rename Uniquely" ibuffer-do-rename-uniquely
- :help "Rename marked buffers to a new, unique name"))
+ :help "Rename marked buffers to a new, unique name"))
(define-key-after operate-map [do-delete]
'(menu-item "Kill" ibuffer-do-delete))
(define-key-after operate-map [do-occur]
'(menu-item "List lines matching..." ibuffer-do-occur
- :help "View all lines in marked buffers matching a regexp"))
+ :help "View all lines in marked buffers matching a regexp"))
(define-key-after operate-map [do-shell-command-pipe]
'(menu-item "Pipe to shell command..." ibuffer-do-shell-command-pipe
- :help "For each marked buffer, send its contents to a shell command"))
+ :help "For each marked buffer, send its contents to a shell command"))
(define-key-after operate-map [do-shell-command-pipe-replace]
'(menu-item "Pipe to shell command (replace)..." ibuffer-do-shell-command-pipe-replace
- :help "For each marked buffer, replace its contents with output of shell command"))
+ :help "For each marked buffer, replace its contents with output of shell command"))
(define-key-after operate-map [do-shell-command-file]
'(menu-item "Shell command on buffer's file..." ibuffer-do-shell-command-file
- :help "For each marked buffer, run a shell command with its file as argument"))
+ :help "For each marked buffer, run a shell command with its file as argument"))
(define-key-after operate-map [do-eval]
'(menu-item "Eval..." ibuffer-do-eval
- :help "Evaluate a Lisp form in each marked buffer"))
+ :help "Evaluate a Lisp form in each marked buffer"))
(define-key-after operate-map [do-view-and-eval]
'(menu-item "Eval (viewing buffer)..." ibuffer-do-view-and-eval
- :help "Evaluate a Lisp form in each marked buffer while viewing it"))
+ :help "Evaluate a Lisp form in each marked buffer while viewing it"))
- (setq ibuffer-mode-map map
- ibuffer-mode-operate-map operate-map
- ibuffer-mode-groups-popup (copy-keymap groups-map))))
+ operate-map))
(define-key ibuffer-mode-groups-popup [kill-filter-group]
'(menu-item "Kill filter group"
@@ -1052,7 +1058,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))))
@@ -1132,15 +1137,15 @@ a new window in the current frame, splitting vertically."
(frame-height)))
(1+ (length marked-bufs)))))
(mapcar (if (eq type 'other-frame)
- #'(lambda (buf)
- (let ((curframe (selected-frame)))
- (select-frame (make-frame))
- (switch-to-buffer buf)
- (select-frame curframe)))
- #'(lambda (buf)
- (split-window nil height (eq type 'horizontally))
- (other-window 1)
- (switch-to-buffer buf)))
+ (lambda (buf)
+ (let ((curframe (selected-frame)))
+ (select-frame (make-frame))
+ (switch-to-buffer buf)
+ (select-frame curframe)))
+ (lambda (buf)
+ (split-window nil height (eq type 'horizontally))
+ (other-window 1)
+ (switch-to-buffer buf)))
marked-bufs)))))
(defun ibuffer-do-view-other-frame ()
@@ -1209,10 +1214,10 @@ a new window in the current frame, splitting vertically."
(defun ibuffer-buffer-names-with-mark (mark)
(let ((ibuffer-buffer-names-with-mark-result nil))
(ibuffer-map-lines-nomodify
- #'(lambda (buf mk)
- (when (char-equal mark mk)
- (push (buffer-name buf)
- ibuffer-buffer-names-with-mark-result))))
+ (lambda (buf mk)
+ (when (char-equal mark mk)
+ (push (buffer-name buf)
+ ibuffer-buffer-names-with-mark-result))))
ibuffer-buffer-names-with-mark-result))
(defsubst ibuffer-marked-buffer-names ()
@@ -1224,16 +1229,16 @@ a new window in the current frame, splitting vertically."
(defun ibuffer-count-marked-lines (&optional all)
(if all
(ibuffer-map-lines-nomodify
- #'(lambda (buf mark)
- (not (char-equal mark ?\s))))
+ (lambda (_buf mark)
+ (not (char-equal mark ?\s))))
(ibuffer-map-lines-nomodify
- #'(lambda (buf mark)
- (char-equal mark ibuffer-marked-char)))))
+ (lambda (_buf mark)
+ (char-equal mark ibuffer-marked-char)))))
(defsubst ibuffer-count-deletion-lines ()
(ibuffer-map-lines-nomodify
- #'(lambda (buf mark)
- (char-equal mark ibuffer-deletion-char))))
+ (lambda (_buf mark)
+ (char-equal mark ibuffer-deletion-char))))
(defsubst ibuffer-map-deletion-lines (func)
(ibuffer-map-on-mark ibuffer-deletion-char func))
@@ -1312,20 +1317,20 @@ With optional ARG, make read-only only if ARG is positive."
(cond
((char-equal mark ibuffer-marked-char)
(ibuffer-map-marked-lines
- #'(lambda (buf mark)
- (ibuffer-set-mark-1 ?\s)
- t)))
+ (lambda (_buf _mark)
+ (ibuffer-set-mark-1 ?\s)
+ t)))
((char-equal mark ibuffer-deletion-char)
(ibuffer-map-deletion-lines
- #'(lambda (buf mark)
- (ibuffer-set-mark-1 ?\s)
- t)))
+ (lambda (_buf _mark)
+ (ibuffer-set-mark-1 ?\s)
+ t)))
(t
(ibuffer-map-lines
- #'(lambda (buf mark)
- (when (not (char-equal mark ?\s))
- (ibuffer-set-mark-1 ?\s))
- t)))))
+ (lambda (_buf mark)
+ (when (not (char-equal mark ?\s))
+ (ibuffer-set-mark-1 ?\s))
+ t)))))
(ibuffer-redisplay t))
(defun ibuffer-toggle-marks (&optional group)
@@ -1339,15 +1344,15 @@ group."
(setq group it))
(let ((count
(ibuffer-map-lines
- #'(lambda (buf mark)
- (cond ((eq mark ibuffer-marked-char)
- (ibuffer-set-mark-1 ?\s)
- nil)
- ((eq mark ?\s)
- (ibuffer-set-mark-1 ibuffer-marked-char)
- t)
- (t
- nil)))
+ (lambda (_buf mark)
+ (cond ((eq mark ibuffer-marked-char)
+ (ibuffer-set-mark-1 ?\s)
+ nil)
+ ((eq mark ?\s)
+ (ibuffer-set-mark-1 ibuffer-marked-char)
+ t)
+ (t
+ nil)))
nil group)))
(message "%s buffers marked" count))
(ibuffer-redisplay t))
@@ -1562,9 +1567,8 @@ If point is on a group name, this function operates on that group."
from-end-p))
(setq strlen (length str))
(setq str
- ,(ibuffer-compile-make-eliding-form 'str
- elide
- from-end-p)))))
+ ,(ibuffer-compile-make-eliding-form
+ 'str elide from-end-p)))))
;; Now, put these forms together with the rest of the code.
(let ((callform
;; Is this an "inline" column? This means we have
@@ -1578,16 +1582,18 @@ If point is on a group name, this function operates on that group."
;; You're not expected to understand this. Hell, I
;; don't even understand it, and I wrote it five
;; minutes ago.
- (insertgenfn (ibuffer-aif (get sym 'ibuffer-column-summarizer)
- ;; I really, really wish Emacs Lisp had closures.
- (lambda (arg sym)
- `(insert
- (let ((ret ,arg))
- (put ',sym 'ibuffer-column-summary
- (cons ret (get ',sym 'ibuffer-column-summary)))
- ret)))
- (lambda (arg sym)
- `(insert ,arg))))
+ (insertgenfn
+ (ibuffer-aif (get sym 'ibuffer-column-summarizer)
+ ;; I really, really wish Emacs Lisp had closures.
+ (lambda (arg sym)
+ `(insert
+ (let ((ret ,arg))
+ (put ',sym 'ibuffer-column-summary
+ (cons ret (get ',sym
+ 'ibuffer-column-summary)))
+ ret)))
+ (lambda (arg sym)
+ `(insert ,arg))))
(mincompform `(< strlen ,(if (integerp min)
min
'min)))
@@ -1620,7 +1626,8 @@ If point is on a group name, this function operates on that group."
`(strlen (length str))))
outforms)
(setq outforms
- (append outforms (list (funcall insertgenfn 'str sym)))))
+ (append outforms
+ (list (funcall insertgenfn 'str sym)))))
;; The simple case; just insert the string.
(push (funcall insertgenfn callform sym) outforms))
;; Finally, return a `let' form which binds the
@@ -1656,11 +1663,11 @@ If point is on a group name, this function operates on that group."
(mapcar #'ibuffer-compile-format ibuffer-formats))
(when (boundp 'ibuffer-filter-format-alist)
(setq ibuffer-compiled-filter-formats
- (mapcar #'(lambda (entry)
- (cons (car entry)
- (mapcar #'(lambda (formats)
- (mapcar #'ibuffer-compile-format formats))
- (cdr entry))))
+ (mapcar (lambda (entry)
+ (cons (car entry)
+ (mapcar (lambda (formats)
+ (mapcar #'ibuffer-compile-format formats))
+ (cdr entry))))
ibuffer-filter-format-alist))))
(defun ibuffer-clear-summary-columns (format)
@@ -1857,10 +1864,10 @@ If point is on a group name, this function operates on that group."
(defun ibuffer-map-on-mark (mark func)
(ibuffer-map-lines
- #'(lambda (buf mk)
- (if (char-equal mark mk)
- (funcall func buf mark)
- nil))))
+ (lambda (buf mk)
+ (if (char-equal mark mk)
+ (funcall func buf mark)
+ nil))))
(defun ibuffer-map-lines (function &optional nomodify group)
"Call FUNCTION for each buffer.
@@ -1932,9 +1939,9 @@ the buffer object itself and the current mark symbol."
(defun ibuffer-get-marked-buffers ()
"Return a list of buffer objects currently marked."
(delq nil
- (mapcar #'(lambda (e)
- (when (eq (cdr e) ibuffer-marked-char)
- (car e)))
+ (mapcar (lambda (e)
+ (when (eq (cdr e) ibuffer-marked-char)
+ (car e)))
(ibuffer-current-state-list))))
(defun ibuffer-current-state-list (&optional pos)
@@ -1946,22 +1953,22 @@ the value of point at the beginning of the line for that buffer."
;; break later. Don't blame me.
(if pos
(ibuffer-map-lines-nomodify
- #'(lambda (buf mark)
- (when (buffer-live-p buf)
- (push (list buf mark (point)) ibuffer-current-state-list-tmp))))
- (ibuffer-map-lines-nomodify
- #'(lambda (buf mark)
+ (lambda (buf mark)
(when (buffer-live-p buf)
- (push (cons buf mark) ibuffer-current-state-list-tmp)))))
+ (push (list buf mark (point)) ibuffer-current-state-list-tmp))))
+ (ibuffer-map-lines-nomodify
+ (lambda (buf mark)
+ (when (buffer-live-p buf)
+ (push (cons buf mark) ibuffer-current-state-list-tmp)))))
(nreverse ibuffer-current-state-list-tmp)))
(defun ibuffer-current-buffers-with-marks (curbufs)
"Return a list like (BUF . MARK) of all open buffers."
(let ((bufs (ibuffer-current-state-list)))
- (mapcar #'(lambda (buf) (let ((e (assq buf bufs)))
- (if e
- e
- (cons buf ?\s))))
+ (mapcar (lambda (buf) (let ((e (assq buf bufs)))
+ (if e
+ e
+ (cons buf ?\s))))
curbufs)))
(defun ibuffer-buf-matches-predicates (buf predicates)
@@ -1979,17 +1986,17 @@ the value of point at the beginning of the line for that buffer."
(delq nil
(mapcar
;; element should be like (BUFFER . MARK)
- #'(lambda (e)
- (let* ((buf (car e)))
- (when
- ;; This takes precedence over anything else
- (or (and ibuffer-always-show-last-buffer
- (eq last buf))
- (funcall (if ext-loaded
- #'ibuffer-ext-visible-p
- #'ibuffer-visible-p)
- buf all ibuffer-buf))
- e)))
+ (lambda (e)
+ (let* ((buf (car e)))
+ (when
+ ;; This takes precedence over anything else
+ (or (and ibuffer-always-show-last-buffer
+ (eq last buf))
+ (funcall (if ext-loaded
+ #'ibuffer-ext-visible-p
+ #'ibuffer-visible-p)
+ buf all ibuffer-buf))
+ e)))
bmarklist))))
(defun ibuffer-visible-p (buf all &optional ibuffer-buf)
@@ -2077,11 +2084,11 @@ the value of point at the beginning of the line for that buffer."
(beginning-of-line)
(buffer-substring (point) (line-end-position)))))
(apply #'insert (mapcar
- #'(lambda (c)
- (if (not (or (char-equal c ?\s)
- (char-equal c ?\n)))
- ?-
- ?\s))
+ (lambda (c)
+ (if (not (or (char-equal c ?\s)
+ (char-equal c ?\n)))
+ ?-
+ ?\s))
str)))
(insert "\n"))
(point))
@@ -2237,7 +2244,7 @@ If optional arg SILENT is non-nil, do not display progress messages."
'ibuffer-filter-group
name)))
-(defun ibuffer-redisplay-engine (bmarklist &optional ignore)
+(defun ibuffer-redisplay-engine (bmarklist &optional _ignore)
(ibuffer-assert-ibuffer-mode)
(let* ((--ibuffer-insert-buffers-and-marks-format
(ibuffer-current-format))
@@ -2338,7 +2345,7 @@ FORMATS is the value to use for `ibuffer-formats'.
(setq ibuffer-prev-window-config (current-window-configuration))
(let ((buf (get-buffer-create (or name "*Ibuffer*"))))
(if other-window-p
- (funcall (if noselect #'(lambda (buf) (display-buffer buf t)) #'pop-to-buffer) buf)
+ (funcall (if noselect (lambda (buf) (display-buffer buf t)) #'pop-to-buffer) buf)
(funcall (if noselect #'display-buffer #'switch-to-buffer) buf))
(with-current-buffer buf
(save-selected-window
@@ -2641,7 +2648,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" "f6e06ce5f548106a2ffa2f3029ce5eda")
+;;;;;; ibuffer-auto-mode) "ibuf-ext" "ibuf-ext.el" "001cd83e8e1ff27c9a61097c840a984d")
;;; Generated autoloads from ibuf-ext.el
(autoload 'ibuffer-auto-mode "ibuf-ext" "\
@@ -2694,7 +2701,7 @@ Move point backwards by COUNT filtering groups.
(autoload 'ibuffer-do-print "ibuf-ext")
(autoload 'ibuffer-included-in-filters-p "ibuf-ext" "\
-Not documented
+
\(fn BUF FILTERS)" nil nil)
@@ -3017,5 +3024,4 @@ defaults to one.
;; coding: iso-8859-1
;; End:
-;; arch-tag: 72581688-0603-4954-b8cf-837c700f62e8
;;; ibuffer.el ends here
diff --git a/lisp/icomplete.el b/lisp/icomplete.el
index 361d2902ce3..ab67fcfcdfd 100644
--- a/lisp/icomplete.el
+++ b/lisp/icomplete.el
@@ -1,7 +1,7 @@
;;; icomplete.el --- minibuffer completion incremental feedback
-;; Copyright (C) 1992, 1993, 1994, 1997, 1999, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992-1994, 1997, 1999, 2001-2011
+;; Free Software Foundation, Inc.
;; Author: Ken Manheimer <klm@i.am>
;; Maintainer: Ken Manheimer <klm@i.am>
@@ -179,8 +179,11 @@ otherwise turn it off."
(if icomplete-mode
;; The following is not really necessary after first time -
;; no great loss.
- (add-hook 'minibuffer-setup-hook 'icomplete-minibuffer-setup)
- (remove-hook 'minibuffer-setup-hook 'icomplete-minibuffer-setup)))
+ (progn
+ (setq completion-show-inline-help nil)
+ (add-hook 'minibuffer-setup-hook 'icomplete-minibuffer-setup))
+ (remove-hook 'minibuffer-setup-hook 'icomplete-minibuffer-setup)
+ (setq completion-show-inline-help t)))
;;;_ > icomplete-simple-completing-p ()
(defun icomplete-simple-completing-p ()
@@ -283,7 +286,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 "(" "["))
@@ -375,5 +379,4 @@ are exhibited within the square braces.)"
;;allout-layout: (-2 :)
;;End:
-;; arch-tag: 339ec25a-0741-4eb6-be63-997532e89b0f
;;; icomplete.el ends here
diff --git a/lisp/ido.el b/lisp/ido.el
index 7614ee6c5ba..d1b5fd07938 100644
--- a/lisp/ido.el
+++ b/lisp/ido.el
@@ -1,7 +1,6 @@
-;;; ido.el --- interactively do things with buffers and files.
+;;; ido.el --- interactively do things with buffers and files
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Kim F. Storm <storm@cua.dk>
;; Based on: iswitchb by Stephen Eglen <stephen@cns.ed.ac.uk>
@@ -322,7 +321,7 @@
;;; Code:
-(defvar cua-inhibit-cua-keys)
+(defvar recentf-list)
;;; User Variables
;;
@@ -351,7 +350,7 @@ should be enabled. The following values are possible:
Setting this variable directly does not take effect;
use either \\[customize] or the function `ido-mode'."
- :set #'(lambda (symbol value)
+ :set #'(lambda (_symbol value)
(ido-mode value))
:initialize 'custom-initialize-default
:require 'ido
@@ -774,6 +773,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 +815,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 +1052,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.
@@ -1107,6 +1134,9 @@ Value is an integer which is number of chars to right of prompt.")
;; Set to 'ignore to inhibit switching between find-file/switch-buffer.
(defvar ido-context-switch-command)
+;; Dynamically bound in ido-read-internal.
+(defvar ido-completing-read)
+
;;; FUNCTIONS
(defun ido-active (&optional merge)
@@ -1261,8 +1291,6 @@ Value is an integer which is number of chars to right of prompt.")
(defun ido-may-cache-directory (&optional dir)
(setq dir (or dir ido-current-directory))
(cond
- ((ido-directory-too-big-p dir)
- nil)
((and (ido-is-root-directory dir)
(or ido-enable-tramp-completion
(memq system-type '(windows-nt ms-dos))))
@@ -1271,6 +1299,8 @@ Value is an integer which is number of chars to right of prompt.")
(ido-cache-unc-valid))
((ido-is-ftp-directory dir)
(ido-cache-ftp-valid))
+ ((ido-directory-too-big-p dir)
+ nil)
(t t)))
(defun ido-pp (list &optional sep)
@@ -1445,8 +1475,8 @@ Removes badly formatted data and ignored directories."
(add-hook 'choose-completion-string-functions 'ido-choose-completion-string))
(define-minor-mode ido-everywhere
- "Toggle using ido speed-ups everywhere file and directory names are read.
-With ARG, turn ido speed-up on if arg is positive, off otherwise."
+ "Toggle using ido-mode everywhere file and directory names are read.
+With ARG, turn ido-mode on if arg is positive, off otherwise."
:global t
:group 'ido
(when (get 'ido-everywhere 'file)
@@ -1467,8 +1497,8 @@ With ARG, turn ido speed-up on if arg is positive, off otherwise."
;;;###autoload
(defun ido-mode (&optional arg)
- "Toggle ido speed-ups on or off.
-With ARG, turn ido speed-up on if arg is positive, off otherwise.
+ "Toggle ido mode on or off.
+With ARG, turn ido-mode on if arg is positive, off otherwise.
Turning on ido-mode will remap (via a minor-mode keymap) the default
keybindings for the `find-file' and `switch-to-buffer' families of
commands to the ido versions of these functions.
@@ -1597,7 +1627,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))
@@ -1606,6 +1635,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)))
@@ -1937,31 +1967,24 @@ If INITIAL is non-nil, it specifies the initial input string."
(ido-set-matches)
(if (and ido-matches (eq ido-try-merged-list 'auto))
(setq ido-try-merged-list t))
- (let
- ((minibuffer-local-completion-map
- (if (memq ido-cur-item '(file dir))
- minibuffer-local-completion-map
- ido-completion-map))
- (minibuffer-local-filename-completion-map
- (if (memq ido-cur-item '(file dir))
- ido-completion-map
- minibuffer-local-filename-completion-map))
- (max-mini-window-height (or ido-max-window-height
- (and (boundp 'max-mini-window-height) max-mini-window-height)))
+ (let ((max-mini-window-height (or ido-max-window-height
+ (and (boundp 'max-mini-window-height)
+ max-mini-window-height)))
(ido-completing-read t)
(ido-require-match require-match)
(ido-use-mycompletion-depth (1+ (minibuffer-depth)))
- (show-paren-mode nil))
+ (show-paren-mode nil)
+ ;; Postpone history adding till later
+ (history-add-new-input nil))
;; prompt the user for the file name
(setq ido-exit nil)
(setq ido-final-text
(catch 'ido
- (completing-read
- (ido-make-prompt item prompt)
- '(("dummy" . 1)) nil nil ; table predicate require-match
- (prog1 ido-text-init (setq ido-text-init nil)) ;initial-contents
- history))))
- (ido-trace "completing-read" ido-final-text)
+ (read-from-minibuffer (ido-make-prompt item prompt)
+ (prog1 ido-text-init
+ (setq ido-text-init nil))
+ ido-completion-map nil history))))
+ (ido-trace "read-from-minibuffer" ido-final-text)
(if (get-buffer ido-completion-buffer)
(kill-buffer ido-completion-buffer))
@@ -2131,6 +2154,7 @@ If INITIAL is non-nil, it specifies the initial input string."
(t
(setq done t))))))
+ (add-to-history (or history 'minibuffer-history) ido-selected)
ido-selected))
(defun ido-edit-input ()
@@ -2155,9 +2179,11 @@ 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 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
@@ -2193,6 +2219,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))
@@ -2388,7 +2424,7 @@ If cursor is not at the end of the user input, move to end of input."
(ido-record-command 'write-file filename)
(add-to-history 'file-name-history filename)
(ido-record-work-directory)
- (write-file filename))
+ (write-file filename t))
((eq method 'read-only)
(ido-record-work-file filename)
@@ -2667,6 +2703,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
@@ -2765,7 +2811,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."
@@ -2869,7 +2915,7 @@ If no buffer or file exactly matching the prompt exists, maybe create a new one.
(setq ido-rotate-temp t)
(exit-minibuffer)))
-(defun ido-wide-find-dir-or-delete-dir (&optional dir)
+(defun ido-wide-find-dir-or-delete-dir (&optional _dir)
"Prompt for DIR to search for using find, starting from current directory.
If input stack is non-empty, delete current directory component."
(interactive)
@@ -2978,11 +3024,11 @@ If repeated, insert text from buffer instead."
ido-try-merged-list nil)
(exit-minibuffer))))
-(defun ido-copy-current-word (all)
+(defun ido-copy-current-word (_all)
"Insert current word (file or directory name) from current buffer."
(interactive "P")
(let ((word (with-current-buffer ido-entry-buffer
- (let ((p (point)) start-line end-line start-name name)
+ (let ((p (point)) start-line end-line start-name)
(if (and mark-active (/= p (mark)))
(setq start-name (mark))
(beginning-of-line)
@@ -3020,8 +3066,8 @@ If repeated, insert text from buffer instead."
(if ido-matches
(let ((next (cadr ido-matches)))
(setq ido-cur-list (ido-chop ido-cur-list next))
- (setq ido-rescan t)
- (setq ido-rotate t))))
+ (setq ido-matches (ido-chop ido-matches next))
+ (setq ido-rescan nil))))
(defun ido-prev-match ()
"Put last element of `ido-matches' at the front of the list."
@@ -3029,8 +3075,8 @@ If repeated, insert text from buffer instead."
(if ido-matches
(let ((prev (car (last ido-matches))))
(setq ido-cur-list (ido-chop ido-cur-list prev))
- (setq ido-rescan t)
- (setq ido-rotate t))))
+ (setq ido-matches (ido-chop ido-matches prev))
+ (setq ido-rescan nil))))
(defun ido-next-match-dir ()
"Find next directory in match list.
@@ -3189,7 +3235,7 @@ for first matching file."
;; Input is list of ("file" . "dir") cons cells.
;; Output is sorted list of ("file "dir" ...) lists
(let ((l (sort items (lambda (a b) (string-lessp (car b) (car a)))))
- res a cur dirs)
+ res a cur)
(while l
(setq a (car l)
l (cdr l))
@@ -3353,9 +3399,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,
@@ -3395,7 +3470,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.
@@ -3843,10 +3918,10 @@ If cursor is not at the end of the user input, delete to end of input."
(let ((enable-recursive-minibuffers t)
(buf (ido-name (car ido-matches)))
(nextbuf (cadr ido-matches)))
- (when (get-buffer buf)
+ (cond
+ ((get-buffer buf)
;; If next match names a buffer use the buffer object; buffer
- ;; name may be changed by packages such as uniquify; mindful
- ;; of virtual buffers.
+ ;; name may be changed by packages such as uniquify.
(when (and nextbuf (get-buffer nextbuf))
(setq nextbuf (get-buffer nextbuf)))
(if (null (kill-buffer buf))
@@ -3860,7 +3935,13 @@ If cursor is not at the end of the user input, delete to end of input."
(setq ido-default-item nextbuf
ido-text-init ido-text
ido-exit 'refresh)
- (exit-minibuffer))))))
+ (exit-minibuffer)))
+ ;; Handle virtual buffers
+ ((assoc buf ido-virtual-buffers)
+ (setq recentf-list
+ (delete (cdr (assoc buf ido-virtual-buffers)) recentf-list))
+ (setq ido-cur-list (delete buf ido-cur-list))
+ (setq ido-rescan t))))))
;;; DELETE CURRENT FILE
(defun ido-delete-file-at-head ()
@@ -4411,17 +4492,13 @@ For details of keybindings, see `ido-find-file'."
;; Insert the match-status information:
(ido-set-common-completion)
- (let ((inf (ido-completions
- contents
- minibuffer-completion-table
- minibuffer-completion-predicate
- (not minibuffer-completion-confirm))))
+ (let ((inf (ido-completions contents)))
(setq ido-show-confirm-message nil)
(ido-trace "inf" inf)
(insert inf))
))))
-(defun ido-completions (name candidates predicate require-match)
+(defun ido-completions (name)
;; Return the string that is displayed after the user's text.
;; Modified from `icomplete-completions'.
@@ -4517,7 +4594,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)))
@@ -4661,13 +4737,14 @@ See `read-directory-name' for additional parameters."
(concat ido-current-directory filename)))))
;;;###autoload
-(defun ido-completing-read (prompt choices &optional predicate require-match initial-input hist def)
+(defun ido-completing-read (prompt choices &optional _predicate require-match
+ initial-input hist def _inherit-input-method)
"Ido replacement for the built-in `completing-read'.
Read a string in the minibuffer with ido-style completion.
PROMPT is a string to prompt with; normally it ends in a colon and a space.
CHOICES is a list of strings which are the possible completions.
-PREDICATE is currently ignored; it is included to be compatible
- with `completing-read'.
+PREDICATE and INHERIT-INPUT-METHOD is currently ignored; it is included
+ to be compatible with `completing-read'.
If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless
the input is (or completes to) an element of CHOICES or is null.
If the input is null, `ido-completing-read' returns DEF, or an empty
@@ -4694,5 +4771,4 @@ DEF, if non-nil, is the default value."
(provide 'ido)
-;; arch-tag: b63a3500-1735-41bd-8a01-05373f0864da
;;; ido.el ends here
diff --git a/lisp/ielm.el b/lisp/ielm.el
index 5974a55566f..c445e647878 100644
--- a/lisp/ielm.el
+++ b/lisp/ielm.el
@@ -1,7 +1,6 @@
;;; ielm.el --- interaction mode for Emacs Lisp
-;; Copyright (C) 1994, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 2001-2011 Free Software Foundation, Inc.
;; Author: David Smith <maa036@lancaster.ac.uk>
;; Maintainer: FSF
@@ -283,7 +282,7 @@ simply inserts a newline."
(defvar ielm-input)
-(defun ielm-input-sender (proc input)
+(defun ielm-input-sender (_proc input)
;; Just sets the variable ielm-input, which is in the scope of
;; `ielm-send-input's call.
(setq ielm-input input))
@@ -304,8 +303,17 @@ simply inserts a newline."
;;; Evaluation
-(defun ielm-eval-input (ielm-string)
- "Evaluate the Lisp expression IELM-STRING, and pretty-print the result."
+(defvar ielm-string)
+(defvar ielm-form)
+(defvar ielm-pos)
+(defvar ielm-result)
+(defvar ielm-error-type)
+(defvar ielm-output)
+(defvar ielm-wbuf)
+(defvar ielm-pmark)
+
+(defun ielm-eval-input (input-string)
+ "Evaluate the Lisp expression INPUT-STRING, and pretty-print the result."
;; This is the function that actually `sends' the input to the
;; `inferior Lisp process'. All comint-send-input does is works out
;; what that input is. What this function does is evaluates that
@@ -318,7 +326,8 @@ simply inserts a newline."
;;
;; NOTE: all temporary variables in this function will be in scope
;; during the eval, and so need to have non-clashing names.
- (let (ielm-form ; form to evaluate
+ (let ((ielm-string input-string) ; input expression, as a string
+ ielm-form ; form to evaluate
ielm-pos ; End posn of parse in string
ielm-result ; Result, or error message
ielm-error-type ; string, nil if no error
@@ -372,7 +381,8 @@ simply inserts a newline."
(*** *3))
(kill-buffer (current-buffer))
(set-buffer ielm-wbuf)
- (setq ielm-result (eval ielm-form))
+ (setq ielm-result
+ (eval ielm-form lexical-binding))
(setq ielm-wbuf (current-buffer))
(setq
ielm-temp-buffer
@@ -395,7 +405,7 @@ simply inserts a newline."
(goto-char ielm-pmark)
(unless ielm-error-type
- (condition-case err
+ (condition-case nil
;; Self-referential objects cause loops in the printer, so
;; trap quits here. May as well do errors, too
(setq ielm-output (concat ielm-output (pp-to-string ielm-result)))
@@ -560,5 +570,4 @@ Switches to the buffer `*ielm*', or creates it if it does not exist."
(provide 'ielm)
-;; arch-tag: ef60e4c0-9c4f-4bdb-8402-271313329790
;;; ielm.el ends here
diff --git a/lisp/iimage.el b/lisp/iimage.el
index 1a50779ddc6..61347c5024c 100644
--- a/lisp/iimage.el
+++ b/lisp/iimage.el
@@ -1,6 +1,6 @@
;;; iimage.el --- Inline image minor mode.
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: KOSEKI Yoshinori <kose@meadowy.org>
;; Maintainer: KOSEKI Yoshinori <kose@meadowy.org>
@@ -27,20 +27,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 +50,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 +62,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 489195837fc..31a6aed7206 100644
--- a/lisp/image-dired.el
+++ b/lisp/image-dired.el
@@ -1,6 +1,6 @@
;;; image-dired.el --- use dired to browse and manipulate your images
;;
-;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2005-2011 Free Software Foundation, Inc.
;;
;; Version: 0.4.11
;; Keywords: multimedia
@@ -157,6 +157,7 @@
(require 'widget)
(eval-when-compile
+ (require 'cl)
(require 'wid-edit))
(defgroup image-dired nil
@@ -383,7 +384,7 @@ Used together with `image-dired-cmd-read-exif-data-program-options'."
"%p -s -s -s -%t \"%f\""
"Format of command used to read EXIF data.
Available options are %p which is replaced by
-`image-dired-cmd-write-exif-data-options', %f which is replaced
+`image-dired-cmd-write-exif-data-program', %f which is replaced
by the image file name and %t which is replaced by the tag name."
:type 'string
:group 'image-dired)
@@ -550,7 +551,7 @@ Create the thumbnails directory if it does not exist."
))
(defun image-dired-insert-thumbnail (file original-file-name
- associated-dired-buffer)
+ associated-dired-buffer)
"Insert thumbnail image FILE.
Add text properties ORIGINAL-FILE-NAME and ASSOCIATED-DIRED-BUFFER."
(let (beg end)
@@ -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 ()
@@ -809,7 +816,7 @@ used or not. If non-nil, use `display-buffer' instead of
thumbnail buffer to be selected."
(interactive "P")
(let ((buf (image-dired-create-thumbnail-buffer))
- curr-file thumb-name files count dired-buf beg)
+ thumb-name files dired-buf)
(if arg
(setq files (list (dired-get-filename)))
(setq files (dired-get-marked-files)))
@@ -911,7 +918,7 @@ FILE-TAGS is an alist in the following form:
"For all FILES, remove TAG from the image database."
(image-dired-sane-db-file)
(save-excursion
- (let (end buf start)
+ (let (end buf)
(setq buf (find-file image-dired-db-file))
(if (not (listp files))
(if (stringp files)
@@ -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))))
@@ -967,7 +974,7 @@ FILE-TAGS is an alist in the following form:
"Tag marked file(s) in dired. With prefix ARG, tag file at point."
(interactive "P")
(let ((tag (read-string "Tags to add (separate tags with a semicolon): "))
- curr-file files)
+ files)
(if arg
(setq files (list (dired-get-filename)))
(setq files (dired-get-marked-files)))
@@ -1591,7 +1598,7 @@ Note that n, p and <down> and <up> will be hijacked and bound to
With prefix argument ARG, create thumbnails even if they already exist
\(i.e. use this to refresh your thumbnails)."
(interactive "P")
- (let (curr-file thumb-name files count)
+ (let (thumb-name files)
(setq files (dired-get-marked-files))
(mapcar
(lambda (curr-file)
@@ -1899,7 +1906,7 @@ overwritten. This confirmation can be turned off using
(if (not (image-dired-image-at-point-p))
(message "No image at point")
(let ((file (image-dired-original-file-name))
- command temp-file)
+ command)
(if (not (string-match "\.[jJ][pP[eE]?[gG]$" file))
(error "Only JPEG images can be rotated!"))
(setq command (format-spec
@@ -2202,11 +2209,10 @@ non-nil."
Track this in associated dired buffer if `image-dired-track-movement' is
non-nil."
(interactive "e")
- (let (file)
- (mouse-set-point event)
- (goto-char (posn-point (event-end event)))
- (if image-dired-track-movement
- (image-dired-track-original-file)))
+ (mouse-set-point event)
+ (goto-char (posn-point (event-end event)))
+ (if image-dired-track-movement
+ (image-dired-track-original-file))
(image-dired-display-thumb-properties))
(defun image-dired-mouse-toggle-mark (event)
@@ -2214,11 +2220,10 @@ non-nil."
Track this in associated dired buffer if `image-dired-track-movement' is
non-nil."
(interactive "e")
- (let (file)
- (mouse-set-point event)
- (goto-char (posn-point (event-end event)))
- (if image-dired-track-movement
- (image-dired-track-original-file)))
+ (mouse-set-point event)
+ (goto-char (posn-point (event-end event)))
+ (if image-dired-track-movement
+ (image-dired-track-original-file))
(image-dired-toggle-mark-thumb-original-file))
(defun image-dired-dired-display-properties ()
@@ -2367,7 +2372,7 @@ it easier to generate, then HTML-files are created in
when using per-directory thumbnail file storage"))
(image-dired-create-gallery-lists)
(let ((tags image-dired-tag-file-list)
- count curr tag index-buf tag-buf
+ count tag index-buf tag-buf
comment file-tags tag-link tag-link-list)
;; Make sure gallery root exist
(if (file-exists-p image-dired-gallery-dir)
@@ -2526,7 +2531,7 @@ the operation by activating the Cancel button.\n\n")
(widget-insert "\n")
(widget-create 'push-button
:notify
- (lambda (&rest ignore)
+ (lambda (&rest _ignore)
(image-dired-save-information-from-widgets)
(bury-buffer)
(message "Done."))
@@ -2534,7 +2539,7 @@ the operation by activating the Cancel button.\n\n")
(widget-insert " ")
(widget-create 'push-button
:notify
- (lambda (&rest ignore)
+ (lambda (&rest _ignore)
(bury-buffer)
(message "Operation canceled."))
"Cancel")
@@ -2615,5 +2620,4 @@ tags to their respective image file. Internal function used by
(provide 'image-dired)
-;; arch-tag: 9d11411d-331f-4380-8b44-8adfe3a0343e
;;; image-dired.el ends here
diff --git a/lisp/image-file.el b/lisp/image-file.el
index b93cdef26e8..bd1c101d529 100644
--- a/lisp/image-file.el
+++ b/lisp/image-file.el
@@ -1,7 +1,6 @@
;;; image-file.el --- support for visiting image files
;;
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;;
;; Author: Miles Bader <miles@gnu.org>
;; Keywords: multimedia
@@ -202,5 +201,4 @@ Image files are those whose name has an extension in
(provide 'image-file)
-;; arch-tag: 04cafe36-f7ba-4c80-9f47-4cb656520ce1
;;; image-file.el ends here
diff --git a/lisp/image-mode.el b/lisp/image-mode.el
index 9ef43442980..17f006e81a1 100644
--- a/lisp/image-mode.el
+++ b/lisp/image-mode.el
@@ -1,9 +1,10 @@
;;; image-mode.el --- support for visiting image files
;;
-;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2005-2011 Free Software Foundation, Inc.
;;
;; 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)
@@ -129,13 +118,16 @@ A winprops object has the shape (WINDOW . ALIST)."
(declare-function image-size "image.c" (spec &optional pixels frame))
(defun image-display-size (spec &optional pixels frame)
- "Wrapper around `image-size', to handle slice display properties.
-If SPEC is an image display property, call `image-size' with the
-given arguments.
-If SPEC is a list of properties containing `image' and `slice'
-properties, calculate the display size from the slice property.
-If SPEC contains `image' but not `slice', call `image-size' with
-the specified image."
+ "Wrapper around `image-size', handling slice display properties.
+Like `image-size', the return value is (WIDTH . HEIGHT).
+WIDTH and HEIGHT are in canonical character units if PIXELS is
+nil, and in pixel units if PIXELS is non-nil.
+
+If SPEC is an image display property, this function is equivalent
+to `image-size'. If SPEC is a list of properties containing
+`image' and `slice' properties, return the display size taking
+the slice property into account. If the list contains `image'
+but not `slice', return the `image-size' of the specified image."
(if (eq (car spec) 'image)
(image-size spec pixels frame)
(let ((image (assoc 'image spec))
@@ -312,17 +304,20 @@ This function assumes the current frame has only one window."
(defvar image-mode-map
(let ((map (make-sparse-keymap)))
- (suppress-keymap map)
- (define-key map "q" 'quit-window)
+ (set-keymap-parent map special-mode-map)
(define-key map "\C-c\C-c" 'image-toggle-display)
(define-key map (kbd "SPC") 'image-scroll-up)
(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)
@@ -376,6 +371,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
@@ -387,7 +383,6 @@ to toggle between display as an image and display as text."
(funcall
(if (called-interactively-p 'any) 'error 'message)
"Cannot display image: %s" (cdr err)))))
-
;;;###autoload
(define-minor-mode image-minor-mode
"Toggle Image minor mode.
@@ -467,12 +462,14 @@ 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.
Turn the image data into a real image, but only if the whole file
was inserted."
+ (unless (derived-mode-p 'image-mode major-mode)
+ (error "The buffer is not in Image mode"))
(let* ((filename (buffer-file-name))
(data-p (not (and filename
(file-readable-p filename)
@@ -487,7 +484,9 @@ 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
@@ -496,7 +495,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))
@@ -510,7 +509,7 @@ was inserted."
;; is written with, e.g., C-x C-w.
(if (coding-system-equal (coding-system-base buffer-file-coding-system)
'no-conversion)
- (set (make-local-variable 'require-final-newline) nil))
+ (set (make-local-variable 'find-file-literally) t))
;; Allow navigation of large images
(set (make-local-variable 'auto-hscroll-mode) nil)
(setq image-type type)
@@ -528,17 +527,25 @@ the image by calling `image-mode'."
(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)
@@ -548,7 +555,90 @@ the image by calling `image-mode'."
(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 `image-transform-mode'.")
+
+(define-minor-mode image-transform-mode
+ "Minor mode for scaling and rotating images.
+This minor mode has no effect unless Emacs is compiled with
+ImageMagick support."
+ nil "image-transform" image-transform-minor-mode-map)
+
+(defvar image-transform-resize nil
+ "The image resize operation.
+Its value should be one of the following:
+ - nil, meaning no resizing.
+ - `fit-height', meaning to fit the image to the window height.
+ - `fit-width', meaning to fit the image to the window width.
+ - A number, which is a scale factor (the default size is 100).")
+
+(defvar image-transform-rotation 0.0)
+
+(defun image-transform-properties (display)
+ "Rescale and/or rotate the current image.
+The scale factor and rotation angle are given by the variables
+`image-transform-resize' and `image-transform-rotation'. This
+takes effect only if Emacs is compiled with ImageMagick support."
+ (let* ((size (image-size display t))
+ (height
+ (cond
+ ((numberp image-transform-resize)
+ (unless (= image-transform-resize 100)
+ (* image-transform-resize (cdr size))))
+ ((eq image-transform-resize 'fit-height)
+ (- (nth 3 (window-inside-pixel-edges))
+ (nth 1 (window-inside-pixel-edges))))))
+ (width (if (eq image-transform-resize 'fit-width)
+ (- (nth 2 (window-inside-pixel-edges))
+ (nth 0 (window-inside-pixel-edges))))))
+ ;;TODO fit-to-* should consider the rotation angle
+ `(,@(if height (list :height height))
+ ,@(if width (list :width width))
+ ,@(if (not (equal 0.0 image-transform-rotation))
+ (list :rotation image-transform-rotation)))))
+
+(defun image-transform-set-scale (scale)
+ "Prompt for a number, and resize the current image by that amount.
+This command has no effect unless Emacs is compiled with
+ImageMagick support."
+ (interactive "nScale: ")
+ (setq image-transform-resize scale)
+ (image-toggle-display-image))
+
+(defun image-transform-fit-to-height ()
+ "Fit the current image to the height of the current window.
+This command has no effect unless Emacs is compiled with
+ImageMagick support."
+ (interactive)
+ (setq image-transform-resize 'fit-height)
+ (image-toggle-display-image))
+
+(defun image-transform-fit-to-width ()
+ "Fit the current image to the width of the current window.
+This command has no effect unless Emacs is compiled with
+ImageMagick support."
+ (interactive)
+ (setq image-transform-resize 'fit-width)
+ (image-toggle-display-image))
+
+(defun image-transform-set-rotation (rotation)
+ "Prompt for an angle ROTATION, and rotate the image by that amount.
+ROTATION should be in degrees. This command has no effect unless
+Emacs is compiled with ImageMagick support."
+ (interactive "nRotation angle (in degrees): ")
+ ;;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))
+ (image-toggle-display-image))
+
(provide 'image-mode)
-;; arch-tag: b5b2b7e6-26a7-4b79-96e3-1546b5c4c6cb
;;; image-mode.el ends here
diff --git a/lisp/image.el b/lisp/image.el
index 2aaa2ee379a..3b90ac46bd1 100644
--- a/lisp/image.el
+++ b/lisp/image.el
@@ -1,10 +1,10 @@
;;; image.el --- image API
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: multimedia
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -30,6 +30,7 @@
"Image support."
:group 'multimedia)
+(defalias 'image-refresh 'image-flush)
(defconst image-type-header-regexps
`(("\\`/[\t\n\r ]*\\*.*XPM.\\*/" . xpm)
@@ -59,7 +60,7 @@ IMAGE-TYPE must be a pair (PREDICATE . TYPE). PREDICATE is called
with one argument, a string containing the image data. If PREDICATE returns
a non-nil value, TYPE is the image's type.")
-(defconst image-type-file-name-regexps
+(defvar image-type-file-name-regexps
'(("\\.png\\'" . png)
("\\.gif\\'" . gif)
("\\.jpe?g\\'" . jpeg)
@@ -328,14 +329,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,8 +587,143 @@ 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."
+ (if (fboundp 'imagemagick-types)
+ (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))))
+ (error "Emacs was not built with ImageMagick support")))
(provide 'image)
-;; arch-tag: 8e76a07b-eb48-4f3e-a7a0-1a7ba9f096b3
;;; image.el ends here
diff --git a/lisp/imenu.el b/lisp/imenu.el
index a1ccb1a480f..6be6b85af8a 100644
--- a/lisp/imenu.el
+++ b/lisp/imenu.el
@@ -1,7 +1,6 @@
;;; imenu.el --- framework for mode-specific buffer indexes
-;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1998, 2001-2011 Free Software Foundation, Inc.
;; Author: Ake Stenhoff <etxaksf@aom.ericsson.se>
;; Lars Lindberg <lli@sypro.cap.se>
@@ -162,7 +161,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
@@ -1066,5 +1065,4 @@ for more information."
(provide 'imenu)
-;; arch-tag: 98a2f5f5-4b91-4704-b18c-3aacf77d77a7
;;; imenu.el ends here
diff --git a/lisp/indent.el b/lisp/indent.el
index 8adb5a9bd6a..93218032700 100644
--- a/lisp/indent.el
+++ b/lisp/indent.el
@@ -1,9 +1,9 @@
;;; indent.el --- indentation commands for Emacs
-;; Copyright (C) 1985, 1995, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1995, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -67,6 +67,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 +418,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 +432,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.
@@ -556,8 +561,8 @@ Use \\[edit-tab-stops] to edit them interactively."
(while (and tabs (>= (current-column) (car tabs)))
(setq tabs (cdr tabs)))
(if tabs
- (let ((opoint (point)))
- (delete-horizontal-space t)
+ (progn
+ (delete-horizontal-space t)
(indent-to (car tabs)))
(insert ?\s))))
@@ -589,5 +594,4 @@ Use \\[edit-tab-stops] to edit them interactively."
(define-key ctl-x-map "\t" 'indent-rigidly)
(define-key esc-map "i" 'tab-to-tab-stop)
-;; arch-tag: f402b2a7-e44f-492f-b5b8-38996020b7c3
;;; indent.el ends here
diff --git a/lisp/info-look.el b/lisp/info-look.el
index 065e1beb5f3..6baed1c422d 100644
--- a/lisp/info-look.el
+++ b/lisp/info-look.el
@@ -1,8 +1,7 @@
;;; info-look.el --- major-mode-sensitive Info index lookup facility
;; An older version of this was known as libc.el.
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-1999, 2001-2011 Free Software Foundation, Inc.
;; Author: Ralph Schleicher <rs@nunatak.allgaeu.org>
;; (did not show signs of life (Nov 2001) -stef)
@@ -999,5 +998,4 @@ Return nil if there is nothing appropriate in the buffer near point."
(provide 'info-look)
-;; arch-tag: 0f1e3ea3-32a2-4461-bbab-3cff93539a74
;;; info-look.el ends here
diff --git a/lisp/info-xref.el b/lisp/info-xref.el
index 7ab42910586..41da9d12c99 100644
--- a/lisp/info-xref.el
+++ b/lisp/info-xref.el
@@ -1,10 +1,10 @@
;;; info-xref.el --- check external references in an Info document
-;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2003-2011 Free Software Foundation, Inc.
;; Author: Kevin Ryde <user42@zip.com.au>
;; Keywords: docs
+;; Version: 3
;; This file is part of GNU Emacs.
@@ -23,56 +23,259 @@
;;; Commentary:
-;; This file implements some simple checking of external cross references in
-;; info files, by attempting to visit the nodes specified.
+;; This is some simple checking of external cross references in info files,
+;; docstrings and custom-links by attempting to visit the nodes specified.
;;
-;; "makeinfo" checks references internal to a document, but not external
-;; references, which makes it rather easy for mistakes to creep in or node
-;; name changes to go unnoticed. `Info-validate' doesn't check external
-;; references either.
+;; `M-x info-xref-check' checks a single info file. See the docstring for
+;; details.
;;
-;; `M-x info-xref-check' checks one file. When invoked from an Info-mode or
-;; texinfo-mode buffer, the current info file is the default at the prompt.
+;; `M-x info-xref-check-all' checks all info files in Info-directory-list.
+;; This is a good way to check the consistency of the whole system.
;;
-;; `M-x info-xref-check-all' looks at everything in the normal info path.
-;; This might be a lot of files but it's a good way to check the consistency
-;; of the whole system.
+;; `M-x info-xref-check-all-custom' loads up all defcustom variables and
+;; checks any info references in them.
;;
-;; Results are shown in a buffer. The format is a bit rough, but hopefully
-;; there won't be too many problems normally, and correcting them is a
-;; manual process anyway, a case of finding the right spot in the original
-;; .texi and finding what node it ought to point to.
-;;
-;; When a target info file doesn't exist there's clearly no way to validate
-;; node references within it. A message is given for missing target files
-;; (once per source document), it could be simply that the target hasn't
-;; been installed, or it could be a mistake in the reference.
-;;
-;; Indirect info files are understood, just pass the top-level foo.info to
-;; `info-xref-check' and it traverses all sub-files. Compressed info files
-;; are accepted too, as usual for `Info-mode'.
-;;
-;; `info-xref-check-all' is rather permissive in what it considers an info
-;; file. It has to be since info files don't necessarily have a ".info"
-;; suffix (eg. this is usual for the emacs manuals). One consequence of
-;; this is that if for instance there's a source code directory in
-;; `Info-directory-list' then a lot of extraneous files might be read, which
-;; will be time consuming but should be harmless.
-;;
-;; `M-x info-xref-check-all-custom' is a related command, it goes through
-;; all info document references in customizable variables, checking them
-;; like info file cross references.
+;; `M-x info-xref-docstrings' checks docstring "Info node ..." hyperlinks in
+;; source files (and other files).
+
+;;; History:
+
+;; Version 3 - new M-x info-xref-docstrings, use compilation-mode
;;; Code:
(require 'info)
+(eval-when-compile
+ (require 'cl)) ;; for `incf'
+
+;;-----------------------------------------------------------------------------
+;; vaguely generic
+
+(defun info-xref-lock-file-p (filename)
+ "Return non-nil if FILENAME is an Emacs lock file.
+A lock file is \".#foo.txt\" etc per `lock-buffer'."
+ (string-match "\\(\\`\\|\\/\\)\\.#" filename))
+
+(defun info-xref-subfile-p (filename)
+ "Return t if FILENAME is an info subfile.
+If removing the last \"-<NUM>\" from the filename gives a file
+which exists, then consider FILENAME a subfile. This is an
+imperfect test, probably ought to open up the purported top file
+and see what subfiles it says."
+ (and (string-match "\\`\\(\\([^-]*-\\)*[^-]*\\)-[0-9]+\\(.*\\)\\'" filename)
+ (file-exists-p (concat (match-string 1 filename)
+ (match-string 3 filename)))))
+
+(defmacro info-xref-with-file (filename &rest body)
+ ;; checkdoc-params: (filename body)
+ "Evaluate BODY in a buffer containing the contents of FILENAME.
+If FILENAME is already in a buffer then that's used, otherwise a
+temporary buffer.
+
+The current implementation uses `insert-file-contents' rather
+than `find-file-noselect' so as not to be held up by queries
+about local variables or possible weirdness in a major mode.
+`lm-with-file' does a similar thing, but it sets
+`emacs-lisp-mode' which is not wanted here."
+
+ (declare (debug t) (indent 1))
+ `(let* ((info-xref-with-file--filename ,filename)
+ (info-xref-with-file--body (lambda () ,@body))
+ (info-xref-with-file--existing
+ (find-buffer-visiting info-xref-with-file--filename)))
+ (if info-xref-with-file--existing
+ (with-current-buffer info-xref-with-file--existing
+ (save-excursion
+ (funcall info-xref-with-file--body)))
+ (with-temp-buffer
+ (insert-file-contents ,filename)
+ (funcall info-xref-with-file--body)))))
+
-(defconst info-xref-results-buffer "*info-xref results*"
+;;-----------------------------------------------------------------------------
+;; output buffer
+
+(defconst info-xref-output-buffer "*info-xref results*"
"Name of the buffer for info-xref results.")
+(defvar info-xref-good 0
+ "Count of good cross references, during info-xref processing.")
+(defvar info-xref-bad 0
+ "Count of bad cross references, during info-xref processing.")
+(defvar info-xref-unavail 0
+ "Count of unavailable cross references, during info-xref processing.")
+
+(defvar info-xref-output-heading ""
+ "A heading string, during info-xref processing.
+This is shown if there's an error, but not if successful.")
+
+(defvar info-xref-filename nil
+ "The current buffer's filename, during info-xref processing.
+When looking at file contents in a temp buffer there's no
+`buffer-file-name', hence this variable.")
+
+(defvar info-xref-xfile-alist nil
+ "Info files found or not found, during info-xref processing.
+Key is \"(foo)\" etc and value nil or t according to whether info
+manual \"(foo)\" exists or not. This is used to suppress
+duplicate messages about foo not being available. (Duplicates
+within one top-level file that is.)")
+
+(defvar info-xref-in-progress nil)
+(defmacro info-xref-with-output (&rest body)
+ "Run BODY with an info-xref output buffer.
+This is meant to nest, so you can wrap it around a set of
+different info-xref checks and have them write to the one output
+buffer created by the outermost `info-xref-with-output', with an
+overall good/bad count summary inserted at the very end."
+
+ (declare (debug t))
+ `(save-excursion
+ (unless info-xref-in-progress
+ (display-buffer (get-buffer-create info-xref-output-buffer))
+ (set-buffer info-xref-output-buffer)
+ (setq buffer-read-only nil)
+ (fundamental-mode)
+ (erase-buffer)
+ (insert ";; info-xref output -*- mode: compilation -*-\n\n")
+ (compilation-mode)
+ (setq info-xref-good 0
+ info-xref-bad 0
+ info-xref-unavail 0
+ info-xref-xfile-alist nil))
+
+ (let ((info-xref-in-progress t)
+ (info-xref-output-heading ""))
+ ,@body)
+
+ (unless info-xref-in-progress
+ (info-xref-output "done, %d good, %d bad, %d unavailable"
+ info-xref-good info-xref-bad info-xref-unavail))))
+
+(defun info-xref-output (fmt &rest args)
+ "Emit a `format'-ed message FMT+ARGS to the `info-xref-output-buffer'."
+ (with-current-buffer info-xref-output-buffer
+ (save-excursion
+ (goto-char (point-max))
+ (let ((inhibit-read-only t))
+ (insert info-xref-output-heading
+ (apply 'format fmt args)
+ "\n")))
+ (setq info-xref-output-heading "")
+ ;; all this info-xref can be pretty slow, display now so the user sees
+ ;; some progress
+ (sit-for 0)))
+(put 'info-xref-output 'byte-compile-format-like t)
+
+(defun info-xref-output-error (fmt &rest args)
+ "Emit a `format'-ed error FMT+ARGS to the `info-xref-output-buffer'.
+The error is attributed to `info-xref-filename' and the current
+buffer's line and column of point."
+ (apply 'info-xref-output
+ (concat "%s:%s:%s: " fmt)
+ info-xref-filename
+ (1+ (count-lines (point-min) (line-beginning-position)))
+ (1+ (current-column))
+ args))
+(put 'info-xref-output-error 'byte-compile-format-like t)
+
+
+;;-----------------------------------------------------------------------------
+;; node checking
+
+;; When asking Info-goto-node to fork, *info* needs to be the current
+;; buffer, otherwise it seems to clone the current buffer but then do the
+;; goto-node in plain *info*.
+;;
+;; We only fork if *info* already exists, if it doesn't then can create and
+;; destroy just that instead of a new name.
+;;
+;; If Info-goto-node can't find the file, then no new buffer is created. If
+;; it finds the file but not the node, then a buffer is created. Handle
+;; this difference by checking before killing.
+;;
+(defun info-xref-goto-node-p (node)
+ "Return t if it's possible to go to the given NODE."
+ (let ((oldbuf (current-buffer)))
+ (save-excursion
+ (save-window-excursion
+ (prog1
+ (condition-case nil
+ (progn
+ (Info-goto-node node
+ (when (get-buffer "*info*")
+ (set-buffer "*info*")
+ "xref - temporary"))
+ t)
+ (error nil))
+ (unless (equal (current-buffer) oldbuf)
+ (kill-buffer)))))))
+
+(defun info-xref-check-node (node)
+
+ ;; Collapse spaces as per info.el and `help-make-xrefs'.
+ ;; Note defcustom :info-link nodes don't get this whitespace collapsing,
+ ;; they should be the exact node name ready to visit.
+ ;; `info-xref-check-all-custom' uses `info-xref-goto-node-p' and so
+ ;; doesn't come through here.
+ ;;
+ ;; Could use "[\t\n ]+" but try to avoid uselessly replacing " " with " ".
+ (setq node (replace-regexp-in-string "[\t\n][\t\n ]*\\| [\t\n ]+" " "
+ node t t))
+
+ (if (not (string-match "\\`([^)]*)" node))
+ (info-xref-output-error "no `(file)' part at start of node: %s\n" node)
+ (let ((file (match-string 0 node)))
+
+ (if (string-equal "()" file)
+ (info-xref-output-error "empty filename part: %s" node)
+
+ ;; see if the file exists, if haven't looked before
+ (unless (assoc file info-xref-xfile-alist)
+ (let ((found (info-xref-goto-node-p file)))
+ (push (cons file found) info-xref-xfile-alist)
+ (unless found
+ (info-xref-output-error "not available to check: %s\n (this reported once per file)" file))))
+
+ ;; if the file exists, try the node
+ (cond ((not (cdr (assoc file info-xref-xfile-alist)))
+ (incf info-xref-unavail))
+ ((info-xref-goto-node-p node)
+ (incf info-xref-good))
+ (t
+ (incf info-xref-bad)
+ (info-xref-output-error "no such node: %s" node)))))))
+
+
+;;-----------------------------------------------------------------------------
+
;;;###autoload
(defun info-xref-check (filename)
- "Check external references in FILENAME, an info document."
+ "Check external references in FILENAME, an info document.
+Interactively from an `Info-mode' or `texinfo-mode' buffer the
+current info file is the default.
+
+Results are shown in a `compilation-mode' buffer. The format is
+a bit rough, but there shouldn't be many problems normally. The
+file:line:column: is the info document, but of course normally
+any correction should be made in the original .texi file.
+Finding the right place in the .texi is a manual process.
+
+When a target info file doesn't exist there's obviously no way to
+validate node references within it. A message is given for
+missing target files once per source document. It could be
+simply that you don't have the target installed, or it could be a
+mistake in the reference.
+
+Indirect info files are understood, just pass the top-level
+foo.info to `info-xref-check' and it traverses all sub-files.
+Compressed info files are accepted too as usual for `Info-mode'.
+
+\"makeinfo\" checks references internal to an info document, but
+not external references, which makes it rather easy for mistakes
+to creep in or node name changes to go unnoticed.
+`Info-validate' doesn't check external references either."
+
(interactive
(list
(let* ((default-filename
@@ -90,98 +293,80 @@
(format "Info file (%s): " default-filename)
"Info file: ")))
(read-file-name prompt nil default-filename t))))
+
(info-xref-check-list (list filename)))
;;;###autoload
(defun info-xref-check-all ()
- "Check external references in all info documents in the usual path.
-The usual path is `Info-directory-list' and `Info-additional-directory-list'."
+ "Check external references in all info documents in the info path.
+`Info-directory-list' and `Info-additional-directory-list' are
+the info paths. See `info-xref-check' for how each file is
+checked.
+
+The search for \"all\" info files is rather permissive, since
+info files don't necessarily have a \".info\" extension and in
+particular the Emacs manuals normally don't. If you have a
+source code directory in `Info-directory-list' then a lot of
+extraneous files might be read. This will be time consuming but
+should be harmless."
+
(interactive)
(info-xref-check-list (info-xref-all-info-files)))
-;; An alternative to trying to get only top-level files here would be to
-;; simply return all files, and have info-xref-check-list not follow
-;; Indirect:. The current way seems a bit nicer though, because it gets the
-;; proper top-level filename into the error messages, and suppresses
-;; duplicate "not available" messages for all subfiles of a single document.
+;; An alternative for geting only top-level files here would be to simply
+;; return all files and have info-xref-check-list not follow "Indirect:".
+;; The current way seems better because it (potentially) gets the proper
+;; top-level filename into the error messages, and suppresses duplicate "not
+;; available" messages for all subfiles of a single document.
(defun info-xref-all-info-files ()
"Return a list of all available info files.
-Only top-level files are returned, subfiles are excluded.
+Only top level files are returned, subfiles are excluded.
-Since info files don't have to have a .info suffix, all files in the
-relevant directories are considered, which might mean a lot of extraneous
-things are returned if for instance a source code directory is in the path."
+Since info files don't have to have a .info suffix, all files in
+the relevant directories are considered, which might mean a lot
+of extraneous things if for instance a source code directory is
+in the path."
(info-initialize) ;; establish Info-directory-list
(apply 'nconc
(mapcar
(lambda (dir)
(let ((result nil))
- (dolist (name (directory-files dir t))
- (unless (or (file-directory-p name) (info-xref-subfile-p name))
+ (dolist (name (directory-files
+ dir
+ t ;; absolute filenames
+ "\\`[^.]")) ;; not dotfiles, nor .# lockfiles
+ (when (and (file-exists-p name) ;; ignore broken symlinks
+ (not (string-match "\\.te?xi\\'" name)) ;; not .texi
+ (not (backup-file-name-p name))
+ (not (file-directory-p name))
+ (not (info-xref-subfile-p name)))
(push name result)))
(nreverse result)))
(append Info-directory-list Info-additional-directory-list))))
-(defun info-xref-subfile-p (filename)
- "Return t if FILENAME is an info subfile.
-If removing the last \"-<NUM>\" from the filename gives a file that exists,
-then consider FILENAME a subfile. This is an imperfect test, we probably
-should open up the purported top file and see what subfiles it says."
- (and (string-match "\\`\\(\\([^-]*-\\)*[^-]*\\)-[0-9]+\\(.*\\)\\'" filename)
- (file-exists-p (concat (match-string 1 filename)
- (match-string 3 filename)))))
-
-
-;; Some dynamic variables are used to share information with sub-functions
-;; below.
-;;
-;; info-xref-filename-header - a heading message for the current top-level
-;; filename, or "" when it's been printed.
-;;
-(defvar info-xref-xfile-alist)
-;;
-;; info-xref-good - count of good cross references.
-;;
-(defvar info-xref-good)
-;;
-;; info-xref-bad - count of bad cross references.
-;;
-(defvar info-xref-bad)
-;;
-;; info-xref-xfile-alist - indexed by "(foo)" with value nil or t according
-;; to whether "(foo)" exists or not. This is used to suppress duplicate
-;; messages about foo not being available. (Duplicates within one
-;; top-level file that is.)
-;;
-(defvar info-xref-filename-heading)
-
(defun info-xref-check-list (filename-list)
"Check external references in info documents in FILENAME-LIST."
- (pop-to-buffer info-xref-results-buffer t)
- (erase-buffer)
- (let ((info-xref-good 0)
- (info-xref-bad 0))
+ (info-xref-with-output
(dolist (info-xref-filename filename-list)
- (let ((info-xref-filename-heading
- (format "In file %s:\n" info-xref-filename))
- (info-xref-xfile-alist nil))
+ (setq info-xref-xfile-alist nil)
+ (let ((info-xref-output-heading
+ (format "Info file %s\n" info-xref-filename)))
(with-temp-message (format "Looking at %s" info-xref-filename)
(with-temp-buffer
(info-insert-file-contents info-xref-filename)
(goto-char (point-min))
- (if (re-search-forward "\^_\nIndirect:\n" nil t)
+ (if (search-forward "\^_\nIndirect:\n" nil t)
(let ((dir (file-name-directory info-xref-filename)))
(while (looking-at "\\(.*\\): [0-9]+\n")
- (let ((subfile (match-string 1)))
+ (let ((info-xref-filename
+ (expand-file-name (match-string 1) dir)))
(with-temp-buffer
- (info-insert-file-contents
- (expand-file-name subfile dir))
+ (info-insert-file-contents info-xref-filename)
(info-xref-check-buffer)))
(forward-line)))
- (info-xref-check-buffer))))))
- (insert (format "done, %d good, %d bad\n" info-xref-good info-xref-bad))))
+ (info-xref-check-buffer))))))))
(defun info-xref-check-buffer ()
"Check external references in the info file in the current buffer.
@@ -190,129 +375,155 @@ This should be the raw file contents, not `Info-mode'."
(while (re-search-forward
"\\*[Nn]ote[ \n\t]+[^:]*:[ \n\t]+\\(\\(([^)]*)\\)[^.,]+\\)[.,]"
nil t)
- (let* ((file (match-string 2))
- (node ;; Canonicalize spaces: we could use "[\t\n ]+" but
- ;; we try to avoid uselessly replacing " " with " ".
- (replace-regexp-in-string "[\t\n][\t\n ]*\\| [\t\n ]+" " "
- (match-string 1) t t)))
- (if (string-equal "()" file)
- (info-xref-output "Empty filename part: %s\n" node)
- ;; see if the file exists, if we haven't tried it before
- (unless (assoc file info-xref-xfile-alist)
- (let ((found (info-xref-goto-node-p file)))
- (push (cons file found) info-xref-xfile-alist)
- (unless found
- (info-xref-output "Not available to check: %s\n" file))))
- ;; if the file exists, try the node
- (when (cdr (assoc file info-xref-xfile-alist))
- (if (info-xref-goto-node-p node)
- (setq info-xref-good (1+ info-xref-good))
- (setq info-xref-bad (1+ info-xref-bad))
- (info-xref-output "No such node: %s\n" node)))))))
-
-(defun info-xref-output (str &rest args)
- "Emit a `format'-ed message STR+ARGS to the info-xref output buffer."
- (with-current-buffer info-xref-results-buffer
- (insert info-xref-filename-heading
- (apply 'format str args))
- (setq info-xref-filename-heading "")
- ;; all this info-xref can be pretty slow, display now so the user can
- ;; see some progress
- (sit-for 0)))
-
-;; When asking Info-goto-node to fork, *info* needs to be the current
-;; buffer, otherwise it seems to clone the current buffer but then do the
-;; goto-node in plain *info*.
-;;
-;; We only fork if *info* already exists, if it doesn't then we can create
-;; and destroy just that instead of a new name.
-;;
-;; If Info-goto-node can't find the file, then no new buffer is created. If
-;; it finds the file but not the node, then a buffer is created. Handle
-;; this difference by checking before killing.
-;;
-(defun info-xref-goto-node-p (node)
- "Return t if it's possible to go to the given NODE."
- (let ((oldbuf (current-buffer)))
(save-excursion
- (save-window-excursion
- (prog1
- (condition-case err
- (progn
- (Info-goto-node node
- (when (get-buffer "*info*")
- (set-buffer "*info*")
- "xref - temporary"))
- t)
- (error nil))
- (unless (equal (current-buffer) oldbuf)
- (kill-buffer (current-buffer))))))))
+ (goto-char (match-beginning 1)) ;; start of nodename as error position
+ (info-xref-check-node (match-string 1)))))
+
+(defvar viper-mode) ;; quieten the byte compiler
+(defvar gnus-registry-install)
;;;###autoload
(defun info-xref-check-all-custom ()
"Check info references in all customize groups and variables.
-`custom-manual' and `info-link' entries in the `custom-links' list are checked.
+Info references can be in `custom-manual' or `info-link' entries
+of the `custom-links' for a variable.
-`custom-load' autoloads for all symbols are loaded in order to get all the
-link information. This will be a lot of lisp packages loaded, and can take
-quite a while."
+Any `custom-load' autoloads in variables are loaded in order to
+get full link information. This will be a lot of Lisp packages
+and can take a long time."
(interactive)
- (pop-to-buffer info-xref-results-buffer t)
- (erase-buffer)
- (let ((info-xref-filename-heading ""))
-
- ;; `custom-load-symbol' is not used, since it quietly ignores errors,
- ;; but we want to show them (since they may mean incomplete checking).
- ;;
- ;; Just one pass through mapatoms is made. There shouldn't be any new
- ;; custom-loads setup by packages loaded.
- ;;
- (info-xref-output "Loading custom-load autoloads ...\n")
- (require 'cus-start)
- (require 'cus-load)
- (let ((viper-mode nil)) ;; tell viper.el not to ask about viperizing
- (mapatoms
- (lambda (symbol)
- (dolist (load (get symbol 'custom-loads))
- (cond ((symbolp load)
- (condition-case cause (require load)
- (error
- (info-xref-output "Symbol `%s': cannot require '%s: %s\n"
- symbol load cause))))
- ;; skip if previously loaded
- ((assoc load load-history))
- ((assoc (locate-library load) load-history))
- (t
- (condition-case cause (load load)
- (error
- (info-xref-output "Symbol `%s': cannot load \"%s\": %s\n"
- symbol load cause)))))))))
-
- ;; Don't bother to check whether the info file exists as opposed to just
- ;; a missing node. If you have the lisp then you should have the
- ;; documentation, so missing node name will be the usual fault.
- ;;
- (info-xref-output "\nChecking custom-links references ...\n")
- (let ((good 0)
- (bad 0))
- (mapatoms
- (lambda (symbol)
- (dolist (link (get symbol 'custom-links))
- (when (memq (car link) '(custom-manual info-link))
- ;; skip :tag part of (custom-manual :tag "Foo" "(foo)Node")
- (if (eq :tag (cadr link))
- (setq link (cddr link)))
- (if (info-xref-goto-node-p (cadr link))
- (setq good (1+ good))
- (setq bad (1+ bad))
- ;; symbol-file gives nil for preloaded variables, would need
- ;; to copy what describe-variable does to show the right place
- (info-xref-output "Symbol `%s' (in %s): cannot goto node: %s\n"
- symbol (symbol-file symbol) (cadr link)))))))
- (info-xref-output "%d good, %d bad\n" good bad))))
+ (info-xref-with-output
+
+ ;; `custom-load-symbol' is not used, since it quietly ignores errors, but
+ ;; we want to show them since they mean incomplete checking.
+ ;;
+ ;; Just one pass through mapatoms is made. There shouldn't be any new
+ ;; custom-loads setup by packages loaded.
+ ;;
+ (info-xref-output "Loading custom-load autoloads ...")
+ (require 'cus-start)
+ (require 'cus-load)
+
+ ;; These are `setq' rather than `let' since a let would unbind the
+ ;; variables after viper.el/gnus-registry.el have loaded, defeating the
+ ;; defvars in those files. Of course it'd be better if those files
+ ;; didn't make interactive queries on loading at all, to allow for
+ ;; programmatic loading like here.
+ (unless (boundp 'viper-mode)
+ (setq viper-mode nil)) ;; avoid viper.el ask about viperizing
+ (unless (boundp 'gnus-registry-install)
+ (setq gnus-registry-install nil)) ;; avoid gnus-registery.el querying
+
+ (mapatoms
+ (lambda (symbol)
+ (dolist (load (get symbol 'custom-loads))
+ (cond ((symbolp load)
+ (condition-case cause (require load)
+ (error
+ (info-xref-output "Symbol `%s': cannot require '%s: %s"
+ symbol load cause))))
+ ;; skip if previously loaded
+ ((assoc load load-history))
+ ((assoc (locate-library load) load-history))
+ (t
+ (condition-case err
+ (load load)
+ (error
+ (info-xref-output "Symbol `%s': cannot load \"%s\": %s"
+ symbol load
+ (error-message-string err)))))))))
+
+ ;; Don't bother to check whether the info file exists as opposed to just
+ ;; a missing node. If you have the code then you should have the
+ ;; documentation, so a wrong node name will be the usual fault.
+ ;;
+ (info-xref-output "\nChecking custom-links references ...")
+ (mapatoms
+ (lambda (symbol)
+ (dolist (link (get symbol 'custom-links))
+ (when (memq (car link) '(custom-manual info-link))
+ ;; skip :tag part of (custom-manual :tag "Foo" "(foo)Node")
+ (if (eq :tag (cadr link))
+ (setq link (cddr link)))
+ (if (info-xref-goto-node-p (cadr link))
+ (incf info-xref-good)
+ (incf info-xref-bad)
+ ;; symbol-file gives nil for preloaded variables, would need
+ ;; to copy what describe-variable does to show the right place
+ (info-xref-output "Symbol `%s' (file %s): cannot goto node: %s"
+ symbol
+ (symbol-file symbol 'defvar)
+ (cadr link)))))))))
+
+;;;###autoload
+(defun info-xref-docstrings (filename-list)
+ ;; checkdoc-params: (filename-list)
+ "Check docstring info node references in source files.
+The given files are searched for docstring hyperlinks like
+
+ Info node `(elisp)Documentation Tips'
+
+and those links checked by attempting to visit the target nodes
+as per `info-xref-check' does.
+
+Interactively filenames are read as a wildcard pattern like
+\"foo*.el\", with the current file as a default. Usually this
+will be lisp sources, but anything with such hyperlinks can be
+checked, including the Emacs .c sources (or the etc/DOC file of
+all builtins).
+
+Because info node hyperlinks are found by a simple regexp search
+in the files, the Lisp code checked doesn't have to be loaded,
+and links can be in the file commentary or elsewhere too. Even
+.elc files can usually be checked successfully if you don't have
+the sources handy."
+ (interactive
+ (let* ((default (and buffer-file-name
+ (file-relative-name buffer-file-name)))
+ (prompt (if default
+ (format "Filename with wildcards (%s): "
+ default)
+ "Filename with wildcards: "))
+ (pattern (read-file-name prompt nil default))
+ ;; absolute filenames
+ (filename-list (file-expand-wildcards pattern t))
+ newlist)
+ (setq filename-list
+ (dolist (file filename-list (nreverse newlist))
+ (or (info-xref-lock-file-p file)
+ (file-directory-p file)
+ (push file newlist))))
+ (unless filename-list
+ (error "No files: %S" pattern))
+ (list filename-list)))
+
+ (eval-and-compile
+ (require 'help-mode)) ;; for `help-xref-info-regexp'
+
+ (info-xref-with-output
+ (dolist (info-xref-filename filename-list)
+ (setq info-xref-xfile-alist nil) ;; "not found"s once per file
+
+ (info-xref-with-file info-xref-filename
+ (goto-char (point-min))
+ (while (re-search-forward help-xref-info-regexp nil t)
+ (let ((node (match-string 2)))
+ (save-excursion
+ (goto-char (match-beginning 2)) ;; start of node as error position
+
+ ;; skip nodes with "%" as probably `format' strings such as in
+ ;; info-look.el
+ (unless (string-match "%" node)
+
+ ;; "(emacs)" is the default manual for docstring hyperlinks,
+ ;; per `help-make-xrefs'
+ (unless (string-match "\\`(" node)
+ (setq node (concat "(emacs)" node)))
+
+ (info-xref-check-node node)))))))))
+
(provide 'info-xref)
-;; arch-tag: 69d4d528-69ed-4cc2-8eb4-c666a0c1d5ac
;;; info-xref.el ends here
diff --git a/lisp/info.el b/lisp/info.el
index 8fd0fc70096..796fd7e2256 100644
--- a/lisp/info.el
+++ b/lisp/info.el
@@ -1,8 +1,6 @@
;; 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, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1985-1986, 1992-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: help
@@ -167,7 +165,7 @@ A header-line does not scroll with the rest of the buffer."
If nil, meaning not yet initialized, Info uses the environment
variable INFOPATH to initialize it, or `Info-default-directory-list'
if there is no INFOPATH variable in the environment, or the
-concatenation of the two if INFOPATH ends with a colon.
+concatenation of the two if INFOPATH ends with a `path-separator'.
When `Info-directory-list' is initialized from the value of
`Info-default-directory-list', and Emacs is installed in one of the
@@ -238,7 +236,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 +266,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.
@@ -341,9 +343,8 @@ Each element of the list has the format (NODENAME (OPERATION . HANDLER) ...)
where NODENAME is a regexp that matches a class of virtual Info node names.
It should be carefully chosen to not cause node name clashes with
existing node names. OPERATION is one of the following operation
-symbols `find-node' that define what HANDLER
-function to call instead of calling the default corresponding function
-to override it.")
+symbols `find-node' that define what HANDLER function to call instead
+of calling the default corresponding function to override it.")
(defvar Info-current-node-virtual nil
"Non-nil if the current Info node is virtual.")
@@ -377,46 +378,50 @@ or `Info-virtual-nodes'."
;; The MS-DOS list should work both when long file names are
;; supported (Windows 9X), and when only 8+3 file names are available.
(if (eq system-type 'ms-dos)
- '( (".gz" . "gunzip")
- (".z" . "gunzip")
- (".bz2" . ("bzip2" "-dc"))
- (".inz" . "gunzip")
- (".igz" . "gunzip")
- (".info.Z" . "gunzip")
- (".info.gz" . "gunzip")
- ("-info.Z" . "gunzip")
- ("-info.gz" . "gunzip")
- ("/index.gz". "gunzip")
- ("/index.z" . "gunzip")
- (".inf" . nil)
- (".info" . nil)
- ("-info" . nil)
- ("/index" . nil)
- ("" . nil))
- '( (".info.Z". "uncompress")
- (".info.Y". "unyabba")
- (".info.gz". "gunzip")
- (".info.z". "gunzip")
- (".info.bz2" . ("bzip2" "-dc"))
- (".info". nil)
- ("-info.Z". "uncompress")
- ("-info.Y". "unyabba")
- ("-info.gz". "gunzip")
- ("-info.bz2" . ("bzip2" "-dc"))
- ("-info.z". "gunzip")
- ("-info". nil)
- ("/index.Z". "uncompress")
- ("/index.Y". "unyabba")
- ("/index.gz". "gunzip")
- ("/index.z". "gunzip")
- ("/index.bz2". ("bzip2" "-dc"))
- ("/index". nil)
- (".Z". "uncompress")
- (".Y". "unyabba")
- (".gz". "gunzip")
- (".z". "gunzip")
- (".bz2" . ("bzip2" "-dc"))
- ("". nil)))
+ '( (".gz" . "gunzip")
+ (".z" . "gunzip")
+ (".bz2" . ("bzip2" "-dc"))
+ (".inz" . "gunzip")
+ (".igz" . "gunzip")
+ (".info.Z" . "gunzip")
+ (".info.gz" . "gunzip")
+ ("-info.Z" . "gunzip")
+ ("-info.gz" . "gunzip")
+ ("/index.gz" . "gunzip")
+ ("/index.z" . "gunzip")
+ (".inf" . nil)
+ (".info" . nil)
+ ("-info" . nil)
+ ("/index" . nil)
+ ("" . nil))
+ '( (".info.Z" . "uncompress")
+ (".info.Y" . "unyabba")
+ (".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
the command as standard input.
@@ -699,7 +704,7 @@ In standalone mode, \\<Info-mode-map>\\[Info-exit] exits Emacs itself."
(re-search-backward regexp beg t))))
(defun Info-find-file (filename &optional noerror)
- "Return expanded FILENAME, or t, if FILENAME is \"dir\".
+ "Return expanded FILENAME, or t if FILENAME is \"dir\".
Optional second argument NOERROR, if t, means if file is not found
just return nil (no error)."
;; Convert filename to lower case if not found as specified.
@@ -798,17 +803,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))
@@ -824,7 +834,7 @@ is preserved, if possible."
(if new-history
(setq Info-history (cons new-history Info-history))))))
-(defun Info-revert-buffer-function (ignore-auto noconfirm)
+(defun Info-revert-buffer-function (_ignore-auto noconfirm)
(when (or noconfirm (y-or-n-p "Revert info buffer? "))
(Info-revert-find-node Info-current-file Info-current-node)
(message "Reverted %s" Info-current-file)))
@@ -875,17 +885,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.
@@ -1384,10 +1393,11 @@ a case-insensitive match is tried."
;; \0\h[image param=value ...\h\0]
;; into the Info file for handling images.
(defun Info-split-parameter-string (parameter-string)
- "Return alist of (\"KEY\" . \"VALUE\") from PARAMETER-STRING; a
-whitespace separated list of KEY=VALUE pairs. If VALUE contains
-whitespace or double quotes, it must be quoted in double quotes and
-any double quotes or backslashes must be escaped (\\\",\\\\)."
+ "Return alist of (\"KEY\" . \"VALUE\") from PARAMETER-STRING.
+PARAMETER-STRING is a whitespace separated list of KEY=VALUE pairs.
+If VALUE contains whitespace or double quotes, it must be quoted
+in double quotes and any double quotes or backslashes must be
+escaped (\\\",\\\\)."
(let ((start 0)
(parameter-alist))
(while (string-match
@@ -1562,8 +1572,7 @@ If FORK is a string, it is the name to use for the new buffer."
(defvar Info-read-node-completion-table)
(defun Info-read-node-name-2 (dirs suffixes string pred action)
- "Virtual completion table for file names input in Info node names.
-PATH-AND-SUFFIXES is a pair of lists, (DIRECTORIES . SUFFIXES)."
+ "Virtual completion table for file names input in Info node names."
(setq suffixes (remove "" suffixes))
(when (file-name-absolute-p string)
(setq dirs (list (file-name-directory string))))
@@ -1684,7 +1693,7 @@ PATH-AND-SUFFIXES is a pair of lists, (DIRECTORIES . SUFFIXES)."
(defvar Info-search-case-fold nil
"The value of `case-fold-search' from previous `Info-search' command.")
-(defun Info-search (regexp &optional bound noerror count direction)
+(defun Info-search (regexp &optional bound _noerror _count direction)
"Search for REGEXP, starting from point, and select node it's found in.
If DIRECTION is `backward', search in the reverse direction."
(interactive (list (read-string
@@ -1905,7 +1914,7 @@ If DIRECTION is `backward', search in the reverse direction."
`(lambda (cmd)
(Info-isearch-pop-state cmd ',Info-current-file ',Info-current-node)))
-(defun Info-isearch-pop-state (cmd file node)
+(defun Info-isearch-pop-state (_cmd file node)
(or (and (equal Info-current-file file)
(equal Info-current-node node))
(progn (Info-find-node file node) (sit-for 0))))
@@ -1914,7 +1923,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.
@@ -2063,16 +2092,16 @@ If SAME-FILE is non-nil, do not move to a different Info file."
))
(defun Info-directory-toc-nodes (filename)
- "Directory-specific implementation of Info-directory-toc-nodes."
+ "Directory-specific implementation of `Info-directory-toc-nodes'."
`(,filename
("Top" nil nil nil)))
-(defun Info-directory-find-file (filename &optional noerror)
- "Directory-specific implementation of Info-find-file."
+(defun Info-directory-find-file (filename &optional _noerror)
+ "Directory-specific implementation of `Info-find-file'."
filename)
-(defun Info-directory-find-node (filename nodename &optional no-going-back)
- "Directory-specific implementation of Info-find-node-2."
+(defun Info-directory-find-node (_filename _nodename &optional _no-going-back)
+ "Directory-specific implementation of `Info-find-node-2'."
(Info-insert-dir))
;;;###autoload
@@ -2089,16 +2118,16 @@ If SAME-FILE is non-nil, do not move to a different Info file."
))
(defun Info-history-toc-nodes (filename)
- "History-specific implementation of Info-history-toc-nodes."
+ "History-specific implementation of `Info-history-toc-nodes'."
`(,filename
("Top" nil nil nil)))
-(defun Info-history-find-file (filename &optional noerror)
- "History-specific implementation of Info-find-file."
+(defun Info-history-find-file (filename &optional _noerror)
+ "History-specific implementation of `Info-find-file'."
filename)
-(defun Info-history-find-node (filename nodename &optional no-going-back)
- "History-specific implementation of Info-find-node-2."
+(defun Info-history-find-node (filename nodename &optional _no-going-back)
+ "History-specific implementation of `Info-find-node-2'."
(insert (format "\n\^_\nFile: %s, Node: %s, Up: (dir)\n\n"
(or filename Info-current-file) nodename))
(insert "Recently Visited Nodes\n")
@@ -2127,8 +2156,8 @@ If SAME-FILE is non-nil, do not move to a different Info file."
(find-node . Info-toc-find-node)
))
-(defun Info-toc-find-node (filename nodename &optional no-going-back)
- "Toc-specific implementation of Info-find-node-2."
+(defun Info-toc-find-node (filename nodename &optional _no-going-back)
+ "Toc-specific implementation of `Info-find-node-2'."
(let* ((curr-file (substring-no-properties (or filename Info-current-file)))
(curr-node (substring-no-properties (or nodename Info-current-node)))
(node-list (Info-toc-nodes curr-file)))
@@ -2290,11 +2319,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 +2836,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 +3127,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
@@ -3113,8 +3137,8 @@ FILENAME is the file name of the manual,
TOPIC is the search string given as an argument to `Info-virtual-index',
MATCHES is a list of index matches found by `Info-index'.")
-(defun Info-virtual-index-find-node (filename nodename &optional no-going-back)
- "Index-specific implementation of Info-find-node-2."
+(defun Info-virtual-index-find-node (filename nodename &optional _no-going-back)
+ "Index-specific implementation of `Info-find-node-2'."
;; Generate Index-like menu of matches
(if (string-match "^\\*Index for `\\(.+\\)'\\*$" nodename)
;; Generate Index-like menu of matches
@@ -3176,8 +3200,7 @@ search results."
(Info-find-node Info-current-file "*Index*")
(unless (assoc (cons Info-current-file topic) Info-virtual-index-nodes)
(let ((orignode Info-current-node)
- (ohist-list Info-history-list)
- nodename)
+ (ohist-list Info-history-list))
;; Reuse `Info-index' to set `Info-index-alternatives'.
(Info-index topic)
(push (cons (cons Info-current-file topic) Info-index-alternatives)
@@ -3193,6 +3216,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*"
@@ -3206,18 +3230,18 @@ STRING is the search string given as an argument to `info-apropos',
MATCHES is a list of index matches found by `Info-apropos-matches'.")
(defun Info-apropos-toc-nodes (filename)
- "Apropos-specific implementation of Info-apropos-toc-nodes."
+ "Apropos-specific implementation of `Info-apropos-toc-nodes'."
(let ((nodes (mapcar 'car (reverse Info-apropos-nodes))))
`(,filename
("Top" nil nil ,nodes)
,@(mapcar (lambda (node) `(,node "Top" nil nil)) nodes))))
-(defun Info-apropos-find-file (filename &optional noerror)
- "Apropos-specific implementation of Info-find-file."
+(defun Info-apropos-find-file (filename &optional _noerror)
+ "Apropos-specific implementation of `Info-find-file'."
filename)
-(defun Info-apropos-find-node (filename nodename &optional no-going-back)
- "Apropos-specific implementation of Info-find-node-2."
+(defun Info-apropos-find-node (_filename nodename &optional _no-going-back)
+ "Apropos-specific implementation of `Info-find-node-2'."
(if (equal nodename "Top")
;; Generate Top menu
(let ((nodes (reverse Info-apropos-nodes)))
@@ -3336,17 +3360,20 @@ Build a menu of the possible matches."
(defvar Info-finder-file "*Finder*"
"Info file name of the virtual Info keyword finder manual.")
-(defun Info-finder-find-file (filename &optional noerror)
- "Finder-specific implementation of Info-find-file."
+(defun Info-finder-find-file (filename &optional _noerror)
+ "Finder-specific implementation of `Info-find-file'."
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."
+(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 +3382,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 +3459,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 of 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."
@@ -3445,14 +3518,14 @@ Build a menu of the possible matches."
(defun Info-get-token (pos start all &optional errorstring)
"Return the token around POS.
-POS must be somewhere inside the token
+POS must be somewhere inside the token.
START is a regular expression which will match the
- beginning of the tokens delimited string
+ beginning of the tokens delimited string.
ALL is a regular expression with a single
parenthesized subpattern which is the token to be
returned. E.g. '{\(.*\)}' would return any string
enclosed in braces around POS.
-ERRORSTRING optional fourth argument, controls action on no match
+ERRORSTRING optional fourth argument, controls action on no match:
nil: return nil
t: beep
a string: signal an error, using that string."
@@ -3685,19 +3758,31 @@ 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)
+ (define-key-after map [separator-1] menu-bar-separator)
(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-top-node "home" map Info-mode-map)
+ (tool-bar-local-item-from-menu 'Info-up "up-node" map Info-mode-map
+ :vert-only t)
+ (define-key-after map [separator-2] menu-bar-separator)
+ (tool-bar-local-item-from-menu 'Info-top-node "home" map Info-mode-map
+ :vert-only t)
(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-search "search" map Info-mode-map)
- (tool-bar-local-item-from-menu 'Info-exit "exit" map Info-mode-map)
+ (define-key-after map [separator-3] menu-bar-separator)
+ (tool-bar-local-item-from-menu 'Info-index "index" map Info-mode-map
+ :label "Index")
+ (tool-bar-local-item-from-menu 'Info-search "search" map Info-mode-map
+ :vert-only t)
+ (tool-bar-local-item-from-menu 'Info-exit "exit" map Info-mode-map
+ :vert-only t)
map))
(defvar Info-menu-last-node nil)
@@ -3795,7 +3880,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 +3942,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 +3961,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 +3983,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.
@@ -4011,7 +4087,7 @@ The `info-file' property of COMMAND says which Info manual to search.
If COMMAND has no property, the variable `Info-file-list-for-emacs'
defines heuristics for which Info manual to try.
The locations are of the format used in `Info-history', i.e.
-\(FILENAME NODENAME BUFFERPOS\), where BUFFERPOS is the line number
+\(FILENAME NODENAME BUFFERPOS), where BUFFERPOS is the line number
in the first element of the returned list (which is treated specially in
`Info-goto-emacs-command-node'), and 0 for the rest elements of a list."
(let ((where '()) line-number
@@ -4596,7 +4672,7 @@ the variable `Info-file-list-for-emacs'."
(eval-when-compile (require 'speedbar))
(defvar Info-speedbar-key-map nil
- "Keymap used when in the info display mode.")
+ "Keymap used when in the Info display mode.")
(defun Info-install-speedbar-variables ()
"Install those variables used by speedbar to enhance Info."
@@ -4644,7 +4720,7 @@ This will add a speedbar major display mode."
(speedbar-change-initial-expansion-list "Info")
)
-(defun Info-speedbar-hierarchy-buttons (directory depth &optional node)
+(defun Info-speedbar-hierarchy-buttons (_directory depth &optional node)
"Display an Info directory hierarchy in speedbar.
DIRECTORY is the current directory in the attached frame.
DEPTH is the current indentation depth.
@@ -4678,7 +4754,7 @@ specific node to expand."
t)
nil))))
-(defun Info-speedbar-goto-node (text node indent)
+(defun Info-speedbar-goto-node (_text node _indent)
"When user clicks on TEXT, go to an info NODE.
The INDENT level is ignored."
(speedbar-select-attached-frame)
@@ -4757,7 +4833,7 @@ NODESPEC is a string of the form: (file)node."
;;; Info mode node listing
;; This is called by `speedbar-add-localized-speedbar-support'
-(defun Info-speedbar-buttons (buffer)
+(defun Info-speedbar-buttons (_buffer)
"Create a speedbar display to help navigation in an Info file.
BUFFER is the buffer speedbar is requesting buttons for."
(if (save-excursion (goto-char (point-min))
@@ -4788,29 +4864,44 @@ BUFFER is the buffer speedbar is requesting buttons for."
;;;; Desktop support
-(defun Info-desktop-buffer-misc-data (desktop-dirname)
+(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)))
-
-(defun Info-restore-desktop-buffer (desktop-buffer-file-name
+ (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 +4910,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)))
@@ -4837,7 +4928,27 @@ type returned by `Info-bookmark-make-record', which see."
(bookmark-default-handler
`("" (buffer . ,buf) . ,(bookmark-get-bookmark-record bmk)))))
+
+;;;###autoload
+(defun info-display-manual (manual)
+ "Go to Info buffer that displays MANUAL, creating it if none already exists."
+ (interactive "sManual name: ")
+ (let ((blist (buffer-list))
+ (manual-re (concat "\\(/\\|\\`\\)" manual "\\(\\.\\|\\'\\)"))
+ (case-fold-search t)
+ found)
+ (dolist (buffer blist)
+ (with-current-buffer buffer
+ (when (and (eq major-mode 'Info-mode)
+ (stringp Info-current-file)
+ (string-match manual-re Info-current-file))
+ (setq found buffer
+ blist nil))))
+ (if found
+ (pop-to-buffer found)
+ (info-initialize)
+ (info (Info-find-file manual)))))
+
(provide 'info)
-;; arch-tag: f2480fe2-2139-40c1-a49b-6314991164ac
;;; info.el ends here
diff --git a/lisp/informat.el b/lisp/informat.el
index 1eb2e94b015..be60b12bbac 100644
--- a/lisp/informat.el
+++ b/lisp/informat.el
@@ -1,7 +1,6 @@
;;; informat.el --- info support functions package for Emacs
-;; Copyright (C) 1986, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1986, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: help
@@ -32,6 +31,10 @@
(declare-function texinfo-format-refill "texinfmt" ())
+;; From texinfmt.el
+(defvar texinfo-command-start)
+(defvar texinfo-command-end)
+
;;;###autoload
(defun Info-tagify (&optional input-buffer-name)
"Create or update Info file tag table in current buffer or in a region."
@@ -511,5 +514,4 @@ For example, invoke \"emacs -batch -f batch-info-validate $info/ ~/*.info\""
(provide 'informat)
-;; arch-tag: 581c440e-5be1-4f31-b005-2d5824bbf569
;;; informat.el ends here
diff --git a/lisp/international/ccl.el b/lisp/international/ccl.el
index c13ddfd621f..2cae1262521 100644
--- a/lisp/international/ccl.el
+++ b/lisp/international/ccl.el
@@ -1,7 +1,6 @@
;;; ccl.el --- CCL (Code Conversion Language) compiler
-;; Copyright (C) 1997, 1998, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-1998, 2001-2011 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -1559,5 +1558,4 @@ See the documentation of `define-ccl-program' for the detail of CCL program."
(provide 'ccl)
-;; arch-tag: 836bcd27-63a1-4a56-b232-1145ecf823fb
;;; ccl.el ends here
diff --git a/lisp/international/characters.el b/lisp/international/characters.el
index 01939ad9419..455cbe697d6 100644
--- a/lisp/international/characters.el
+++ b/lisp/international/characters.el
@@ -1,7 +1,6 @@
;;; characters.el --- set syntax and category for multibyte characters
-;; Copyright (C) 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2000-2011 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -1234,6 +1233,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
@@ -1250,5 +1413,4 @@ Setup char-width-table appropriate for non-CJK language environment."
;; coding: utf-8
;; End:
-;; arch-tag: 85889c35-9f4d-4912-9bf5-82de31b0d42d
;;; characters.el ends here
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/cp51932.el b/lisp/international/cp51932.el
index a648bfcefc4..d4a347d43aa 100644
--- a/lisp/international/cp51932.el
+++ b/lisp/international/cp51932.el
@@ -469,4 +469,3 @@
map)
(define-translation-table 'cp51932-encode map))
-;; arch-tag: d21c06e5-a548-4dda-8802-c2922ff19da3
diff --git a/lisp/international/eucjp-ms.el b/lisp/international/eucjp-ms.el
index 060692f31a5..a16848a0c7c 100644
--- a/lisp/international/eucjp-ms.el
+++ b/lisp/international/eucjp-ms.el
@@ -2086,4 +2086,3 @@
map)
(define-translation-table 'eucjp-ms-encode map))
-;; arch-tag: c4191096-288a-4f13-9b2a-ee7a1f11eb4a
diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el
index f9405b486f4..777779e5ec5 100644
--- a/lisp/international/fontset.el
+++ b/lisp/international/fontset.el
@@ -1,7 +1,6 @@
;;; fontset.el --- commands for handling fontset
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2011 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -433,7 +432,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")
@@ -1152,5 +1151,4 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.")
;;
(provide 'fontset)
-;; arch-tag: bb53e629-0234-403c-950e-551e61554849
;;; fontset.el ends here
diff --git a/lisp/international/isearch-x.el b/lisp/international/isearch-x.el
index ab61f26a63f..cb6856964c0 100644
--- a/lisp/international/isearch-x.el
+++ b/lisp/international/isearch-x.el
@@ -1,7 +1,6 @@
;;; isearch-x.el --- extended isearch handling commands
-;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2001-2011 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -141,5 +140,4 @@
(isearch-update)))
(isearch-process-search-char last-char)))
-;; arch-tag: 1a90a6cf-2cb2-477a-814a-9ff895852822
;;; isearch-x.el ends here
diff --git a/lisp/international/iso-ascii.el b/lisp/international/iso-ascii.el
index e2a4ac41f7d..491a7c02ba4 100644
--- a/lisp/international/iso-ascii.el
+++ b/lisp/international/iso-ascii.el
@@ -1,7 +1,6 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1987, 1995, 1998, 2001-2011 Free Software Foundation, Inc.
;; Author: Howard Gayle
;; Maintainer: FSF
@@ -33,6 +32,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 +40,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,17 +162,12 @@
(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)
-;; arch-tag: 687edf0d-f792-471e-b50e-be805938359a
;;; iso-ascii.el ends here
diff --git a/lisp/international/iso-cvt.el b/lisp/international/iso-cvt.el
index f9b312dcd67..6ccd1c21739 100644
--- a/lisp/international/iso-cvt.el
+++ b/lisp/international/iso-cvt.el
@@ -1,8 +1,7 @@
;;; iso-cvt.el --- translate ISO 8859-1 from/to various encodings -*- coding: iso-latin-1 -*-
;; This file was formerly called gm-lingo.el.
-;; Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1998, 2000-2011 Free Software Foundation, Inc.
;; Author: Michael Gschwind <mike@vlsivie.tuwien.ac.at>
;; Keywords: tex, iso, latin, i18n
@@ -904,5 +903,4 @@ Optional arg BUFFER is ignored (for use in `format-alist')."
(provide 'iso-cvt)
-;; arch-tag: 64ae843f-ed0e-43e1-ba50-ffd581b90840
;;; iso-cvt.el ends here
diff --git a/lisp/international/iso-transl.el b/lisp/international/iso-transl.el
index c73dd0fb07b..49b1f6ef231 100644
--- a/lisp/international/iso-transl.el
+++ b/lisp/international/iso-transl.el
@@ -1,7 +1,6 @@
;;; iso-transl.el --- keyboard input definitions for ISO 8859-1 -*- coding: iso-8859-1 -*-
-;; Copyright (C) 1987, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2001
-;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1987, 1993-1999, 2001-2011 Free Software Foundation, Inc.
;; Author: Howard Gayle
;; Maintainer: FSF
@@ -291,5 +290,4 @@ sequence VECTOR. (VECTOR is normally one character long.)")
(provide 'iso-transl)
-;; arch-tag: 034cfedf-7ebd-461d-bcd0-5c79e6dc0b61
;;; iso-transl.el ends here
diff --git a/lisp/international/ja-dic-cnv.el b/lisp/international/ja-dic-cnv.el
index 9e0bffef367..c0fcf19d841 100644
--- a/lisp/international/ja-dic-cnv.el
+++ b/lisp/international/ja-dic-cnv.el
@@ -337,7 +337,7 @@ The name of generated file is specified by the variable `ja-dic-filename'."
(erase-buffer)
(buffer-disable-undo)
(insert ";;; ja-dic.el --- dictionary for Japanese input method"
- " -*-coding: euc-japan; byte-compile-disable-print-circle:t; -*-\n"
+ " -*-coding: euc-japan; -*-\n"
";;\tGenerated by the command `skkdic-convert'\n"
";;\tDate: " (current-time-string) "\n"
";;\tOriginal SKK dictionary file: "
@@ -545,5 +545,4 @@ To get complete usage, invoke:
;; coding: iso-2022-7bit
;; End:
-;; arch-tag: dec06fb0-8118-45b1-80d7-dc360b6fd3b2
;;; ja-dic-cnv.el ends here
diff --git a/lisp/international/ja-dic-utl.el b/lisp/international/ja-dic-utl.el
index 8e276a240f5..8400c473afa 100644
--- a/lisp/international/ja-dic-utl.el
+++ b/lisp/international/ja-dic-utl.el
@@ -222,5 +222,4 @@ LEIM is available from the same ftp directory as Emacs."))
;; coding: iso-2022-7bit
;; End:
-;; arch-tag: df2218fa-469c-40f6-bace-7f89a053f9c0
;;; ja-dic-utl.el ends here
diff --git a/lisp/international/kinsoku.el b/lisp/international/kinsoku.el
index 835f991957b..b0ca522dee4 100644
--- a/lisp/international/kinsoku.el
+++ b/lisp/international/kinsoku.el
@@ -1,7 +1,6 @@
;;; kinsoku.el --- `Kinsoku' processing funcs -*- coding: iso-2022-7bit; -*-
-;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2001-2011 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -183,5 +182,4 @@ the context of text formatting."
(aref (char-category-set (preceding-char)) ?<))
(kinsoku-shorter linebeg))))
-;; arch-tag: e6b036bc-9e5b-4e9f-a22c-4ed04e37777e
;;; kinsoku.el ends here
diff --git a/lisp/international/kkc.el b/lisp/international/kkc.el
index f26350ac802..03e5202438f 100644
--- a/lisp/international/kkc.el
+++ b/lisp/international/kkc.el
@@ -1,7 +1,6 @@
;;; kkc.el --- Kana Kanji converter -*- coding: iso-2022-7bit; -*-
-;; Copyright (C) 1997, 1998, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-1998, 2001-2011 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -135,7 +134,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>'."
@@ -658,5 +657,4 @@ and change the current conversion to the last one in the group."
;;
(provide 'kkc)
-;; arch-tag: 3cbfd56e-74e6-4f60-bb46-ba7c2d366fbf
;;; kkc.el ends here
diff --git a/lisp/international/latexenc.el b/lisp/international/latexenc.el
index e32624df9fa..d5a7713dbec 100644
--- a/lisp/international/latexenc.el
+++ b/lisp/international/latexenc.el
@@ -1,6 +1,6 @@
;;; latexenc.el --- guess correct coding system in LaTeX files -*-coding: iso-2022-7bit -*-
-;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2005-2011 Free Software Foundation, Inc.
;; Author: Arne J,Ax(Brgensen <arne@arnested.dk>
;; Keywords: mule, coding system, latex
@@ -186,5 +186,4 @@ coding system names is determined from `latex-inputenc-coding-alist'."
(provide 'latexenc)
-;; arch-tag: f971bc3e-1fec-4609-8f2f-73dd41ab22e1
;;; latexenc.el ends here
diff --git a/lisp/international/latin1-disp.el b/lisp/international/latin1-disp.el
index 243bff78e4d..1c9b06beab8 100644
--- a/lisp/international/latin1-disp.el
+++ b/lisp/international/latin1-disp.el
@@ -1,7 +1,6 @@
;;; latin1-disp.el --- display tables for other ISO 8859 on Latin-1 terminals -*-coding: iso-2022-7bit;-*-
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Author: Dave Love <fx@gnu.org>
;; Keywords: i18n
@@ -3196,5 +3195,4 @@ isn't changed if the display can render Unicode characters."
(provide 'latin1-disp)
-;; arch-tag: 68b2872e-d667-4f48-8e2f-ec2ba2d29406
;;; latin1-disp.el ends here
diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el
index 29b2218ae54..5f4d3ea849e 100644
--- a/lisp/international/mule-cmds.el
+++ b/lisp/international/mule-cmds.el
@@ -1,7 +1,6 @@
;;; mule-cmds.el --- commands for multilingual environment -*-coding: iso-2022-7bit -*-
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2011 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -140,7 +139,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 +285,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."
@@ -2038,7 +2036,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")
@@ -2183,7 +2181,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
@@ -2886,8 +2884,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.")
@@ -2897,15 +2897,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)))
@@ -2991,5 +2995,4 @@ properties are sticky."
(define-key ctl-x-map "8\r" 'ucs-insert)
-;; arch-tag: b382c432-4b36-460e-bf4c-05efd0bb18dc
;;; mule-cmds.el ends here
diff --git a/lisp/international/mule-conf.el b/lisp/international/mule-conf.el
index c0a39321ad8..9ba95e4d11a 100644
--- a/lisp/international/mule-conf.el
+++ b/lisp/international/mule-conf.el
@@ -1,7 +1,6 @@
;;; mule-conf.el --- configure multilingual environment
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2011 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
;; Registration Number H14PRO021
@@ -1555,5 +1554,4 @@ for decoding and encoding files, process I/O, etc."
;; code.
(provide 'code-pages)
-;; arch-tag: 7d5fed55-b6df-42f6-8d3d-0011190551f5
;;; mule-conf.el ends here
diff --git a/lisp/international/mule-diag.el b/lisp/international/mule-diag.el
index 966eb89eb45..d9ac587231e 100644
--- a/lisp/international/mule-diag.el
+++ b/lisp/international/mule-diag.el
@@ -1,7 +1,6 @@
;;; mule-diag.el --- show diagnosis of multilingual environment (Mule)
-;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-1998, 2000-2011 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -1057,7 +1056,10 @@ installed LEIM (Libraries of Emacs Input Methods).")
(if (and (consp title) (stringp (car title)))
(car title)
title))
- (nth 4 elt)))))))
+ ;; If the doc is multi-line, indent all
+ ;; non-blank lines. (Bug#8066)
+ (replace-regexp-in-string "\n\\(.\\)" "\n \\1"
+ (or (nth 4 elt) ""))))))))
;;; DIAGNOSIS
@@ -1169,5 +1171,4 @@ The default is 20. If LIMIT is negative, do not limit the listing."
(provide 'mule-diag)
-;; arch-tag: cd3b607c-2893-45a0-a4fa-a6535754dbee
;;; mule-diag.el ends here
diff --git a/lisp/international/mule-util.el b/lisp/international/mule-util.el
index 3992b0f3d3b..ef09cdda2de 100644
--- a/lisp/international/mule-util.el
+++ b/lisp/international/mule-util.el
@@ -1,7 +1,6 @@
;;; mule-util.el --- utility functions for multilingual environment (mule)
-;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-1998, 2000-2011 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -314,7 +313,7 @@ Optional 5th argument NIL-FOR-TOO-LONG non-nil means return nil
;;;###autoload
(defmacro with-coding-priority (coding-systems &rest body)
"Execute BODY like `progn' with CODING-SYSTEMS at the front of priority list.
-CODING-SYSTEMS is a list of coding systems. See `set-coding-priority'.
+CODING-SYSTEMS is a list of coding systems. See `set-coding-system-priority'.
This affects the implicit sorting of lists of coding sysems returned by
operations such as `find-coding-systems-region'."
(let ((current (make-symbol "current")))
@@ -405,5 +404,4 @@ per-character basis, this may not be accurate."
;; coding: iso-2022-7bit
;; End:
-;; arch-tag: 5bdb52b6-a3a5-4529-b7a0-37d01b0e570b
;;; mule-util.el ends here
diff --git a/lisp/international/mule.el b/lisp/international/mule.el
index b71790ee575..4a387a233a0 100644
--- a/lisp/international/mule.el
+++ b/lisp/international/mule.el
@@ -1,8 +1,6 @@
;;; mule.el --- basic commands for multilingual environment
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1997-2011 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -326,8 +324,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 +343,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 +601,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 +657,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 +1151,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 +1226,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))
@@ -1560,7 +1609,7 @@ in-place."
(set-buffer (generate-new-buffer " *temp"))
(set-buffer-multibyte (multibyte-string-p from))
(insert from)
- (setq from 1 to (point-max)))
+ (setq from (point-min) to (point-max)))
(save-restriction
(narrow-to-region from to)
(goto-char from)
@@ -1624,12 +1673,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 +1689,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 +2178,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 +2297,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))
@@ -2394,5 +2442,4 @@ added by processing software."
;;;
(provide 'mule)
-;; arch-tag: 9aebaa6e-0e8a-40a9-b857-cb5d04a39e7c
;;; mule.el ends here
diff --git a/lisp/international/ogonek.el b/lisp/international/ogonek.el
index 5b1a690c46f..0da6cc614fd 100644
--- a/lisp/international/ogonek.el
+++ b/lisp/international/ogonek.el
@@ -1,7 +1,6 @@
;;; ogonek.el --- change the encoding of Polish diacritics
-;; Copyright (C) 1997, 1998, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-1998, 2001-2011 Free Software Foundation, Inc.
;; Author: W{\l}odek Bzyl
;; Ryszard Kubiak
@@ -273,23 +272,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)
@@ -500,5 +499,4 @@ followed by a non-Polish character, that is one not listed in the
(provide 'ogonek)
-;; arch-tag: 672d7744-28ac-412b-965e-06a27e50d1d7
;;; ogonek.el ends here
diff --git a/lisp/international/quail.el b/lisp/international/quail.el
index c1cd8fd6e45..51a0dcace14 100644
--- a/lisp/international/quail.el
+++ b/lisp/international/quail.el
@@ -1,7 +1,6 @@
;;; quail.el --- provides simple input method for multilingual text
-;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-1998, 2000-2011 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -811,7 +810,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)))
@@ -819,7 +818,7 @@ The format of KBD-LAYOUT is the same as `quail-keyboard-layout'."
(bar "|")
lower upper row)
;; Make table without horizontal lines. Each column for a key
- ;; has the form "| LU |" where L is for lower key and and U is
+ ;; has the form "| LU |" where L is for lower key and U is
;; for a upper key. If width of L (U) is greater than 1,
;; preceding (following) space is not inserted.
(put-text-property 0 1 'face 'bold bar)
@@ -3077,5 +3076,4 @@ call it with one argument STRING."
;;
(provide 'quail)
-;; arch-tag: 46d7db54-5467-42c4-a2a9-53ca90a1e886
;;; quail.el ends here
diff --git a/lisp/international/robin.el b/lisp/international/robin.el
index d9478611b5e..7e98a507f93 100644
--- a/lisp/international/robin.el
+++ b/lisp/international/robin.el
@@ -571,5 +571,4 @@ used."
;; coding: utf-8-emacs
;; End:
-;; arch-tag: ba995140-7436-4a57-b875-747fc340f605
;;; robin.el ends here
diff --git a/lisp/international/titdic-cnv.el b/lisp/international/titdic-cnv.el
index 6e6f8ce7384..e68dc8bdc17 100644
--- a/lisp/international/titdic-cnv.el
+++ b/lisp/international/titdic-cnv.el
@@ -1,7 +1,6 @@
;;; titdic-cnv.el --- convert cxterm dictionary (TIT format) to Quail package -*- coding:iso-2022-7bit; -*-
-;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-1998, 2000-2011 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -273,8 +272,7 @@ SPC, 6, 3, 4, or 7 specifing a tone (SPC:$(0?v(N(B, 6:$(0Dm(N(B, 3:$(0&9Vy
(princ ";; Quail package `")
(princ package)
- (princ (format "' -*- coding:%s; " coding-system-for-write))
- (princ "byte-compile-disable-print-circle:t; -*-\n")
+ (princ (format "' -*- coding:%s -*-\n" coding-system-for-write))
(princ ";; Generated by the command `titdic-convert'\n;;\tDate: ")
(princ (current-time-string))
(princ "\n;;\tOriginal TIT dictionary file: ")
@@ -1155,8 +1153,8 @@ the generated Quail package is saved."
(setq coding-system-for-write
(coding-system-change-eol-conversion coding 'unix))
(with-temp-file (expand-file-name quailfile dirname)
- (insert (format ";; Quail package `%s' -*- coding:%s; " name coding))
- (insert "byte-compile-disable-print-circle:t; -*-\n")
+ (insert (format ";; Quail package `%s' -*- coding:%s -*-\n"
+ name coding))
(insert ";; Generated by the command `miscdic-convert'\n")
(insert ";; Date: " (current-time-string) "\n")
(insert ";; Source dictionary file: " dicfile "\n")
@@ -1210,5 +1208,4 @@ to store generated Quail packages."
;; coding: iso-2022-7bit
;; End:
-;; arch-tag: 8ad478b2-a985-4da2-b47f-d8ee5d7c24a3
;;; titdic-cnv.el ends here
diff --git a/lisp/international/ucs-normalize.el b/lisp/international/ucs-normalize.el
index afd6769e659..f83e0f7588f 100644
--- a/lisp/international/ucs-normalize.el
+++ b/lisp/international/ucs-normalize.el
@@ -1,7 +1,6 @@
;;; ucs-normalize.el --- Unicode normalization NFC/NFD/NFKD/NFKC
-;; Copyright (C) 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
;; Author: Taichi Kawabata <kawabata.taichi@gmail.com>
;; Keywords: unicode, normalization
@@ -628,5 +627,4 @@ be decomposed."
;; coding: utf-8
;; End:
-;; arch-tag: cef65ae7-71ad-4e19-8da8-56ab4d42aaa4
;;; ucs-normalize.el ends here
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 e356abca9f2..e27bf26e17d 100644
--- a/lisp/international/utf-7.el
+++ b/lisp/international/utf-7.el
@@ -1,7 +1,6 @@
;;; utf-7.el --- utf-7 coding system
-;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2003-2011 Free Software Foundation, Inc.
;; Author: Dave Love <fx@gnu.org>
;; Keywords: i18n, mail
@@ -62,7 +61,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
@@ -127,5 +126,4 @@ ESC and SKIP-CHARS are adjusted for the normal and IMAP versions."
(provide 'utf-7)
-;; arch-tag: 975ee403-90a4-4286-97d2-4ed1323f4ef9
;;; utf-7.el ends here
diff --git a/lisp/isearch.el b/lisp/isearch.el
index 849ec418f17..7db7f30dd89 100644
--- a/lisp/isearch.el
+++ b/lisp/isearch.el
@@ -1,12 +1,11 @@
;;; isearch.el --- incremental search minor mode
-;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1999, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1992-1997, 1999-2011 Free Software Foundation, Inc.
;; Author: Daniel LaLiberte <liberte@cs.uiuc.edu>
;; Maintainer: FSF
;; Keywords: matching
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -156,6 +155,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 +237,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))
@@ -462,13 +464,16 @@ This is like `describe-bindings', but displays only Isearch keys."
(define-key map "\C-w" 'isearch-yank-word-or-char)
(define-key map "\M-\C-w" 'isearch-del-char)
(define-key map "\M-\C-y" 'isearch-yank-char)
- (define-key map "\C-y" 'isearch-yank-line)
+ (define-key map "\C-y" 'isearch-yank-kill)
+ (define-key map "\M-s\C-e" '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)
- (define-key map "\M-y" 'isearch-yank-kill)
+ (define-key map "\M-y" 'isearch-yank-pop)
(define-key map "\M-\t" 'isearch-complete)
@@ -632,6 +637,8 @@ Type \\[isearch-yank-char] to yank char from buffer onto end of search\
Type \\[isearch-yank-line] to yank rest of line onto end of search string\
and search for it.
Type \\[isearch-yank-kill] to yank the last string of killed text.
+Type \\[isearch-yank-pop] to replace string just yanked into search prompt
+ with string killed before it.
Type \\[isearch-quote-char] to quote control character to search for it.
\\[isearch-abort] while searching or when search has failed cancels input\
back to what has
@@ -872,7 +879,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.
@@ -1052,6 +1060,7 @@ nonincremental search instead via `isearch-edit-string'."
(isearch-done)
(isearch-clean-overlays))
+(defvar minibuffer-history-symbol) ;; from external package gmhist.el
(defun isearch-edit-string ()
"Edit the search string in the minibuffer.
@@ -1071,7 +1080,7 @@ If first char entered is \\[isearch-yank-word-or-char], then do word search inst
;; this could be simplified greatly.
;; Editing doesn't back up the search point. Should it?
(interactive)
- (condition-case err
+ (condition-case nil
(progn
(let ((isearch-nonincremental isearch-nonincremental)
@@ -1116,7 +1125,7 @@ If first char entered is \\[isearch-yank-word-or-char], then do word search inst
;; Actually terminate isearching until editing is done.
;; This is so that the user can do anything without failure,
;; like switch buffers and start another isearch, and return.
- (condition-case err
+ (condition-case nil
(isearch-done t t)
(exit nil)) ; was recursive editing
@@ -1237,9 +1246,9 @@ Use `isearch-exit' to quit without signaling."
(interactive)
;; (ding) signal instead below, if quitting
(discard-input)
- (if isearch-success
- ;; If search is successful, move back to starting point
- ;; and really do quit.
+ (if (and isearch-success (not isearch-error))
+ ;; If search is successful and has no incomplete regexp,
+ ;; move back to starting point and really do quit.
(progn
(setq isearch-success nil)
(isearch-cancel))
@@ -1480,20 +1489,28 @@ 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."
(interactive)
(isearch-yank-string (current-kill 0)))
+(defun isearch-yank-pop ()
+ "Replace just-yanked search string with previously killed string."
+ (interactive)
+ (if (not (memq last-command '(isearch-yank-kill isearch-yank-pop)))
+ ;; Fall back on `isearch-yank-kill' for the benefits of people
+ ;; who are used to the old behavior of `M-y' in isearch mode. In
+ ;; future, this fallback may be changed if we ever change
+ ;; `yank-pop' to do something like the kill-ring-browser.
+ (isearch-yank-kill)
+ (isearch-pop-state)
+ (isearch-yank-string (current-kill 1))))
+
(defun isearch-yank-x-selection ()
"Pull current X selection into search string."
(interactive)
@@ -1542,14 +1559,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 +1733,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 +1753,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 +1782,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 +1846,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 +2008,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)
@@ -2150,7 +2166,7 @@ If there is no completion possible, say so and continue searching."
(isearch-message-suffix c-q-hack ellipsis)))
(if c-q-hack m (let ((message-log-max nil)) (message "%s" m)))))
-(defun isearch-message-prefix (&optional c-q-hack ellipsis nonincremental)
+(defun isearch-message-prefix (&optional _c-q-hack ellipsis nonincremental)
;; If about to search, and previous search regexp was invalid,
;; check that it still is. If it is valid now,
;; let the message we display while searching say that it is valid.
@@ -2183,7 +2199,7 @@ If there is no completion possible, say so and continue searching."
(propertize (concat (upcase (substring m 0 1)) (substring m 1))
'face 'minibuffer-prompt)))
-(defun isearch-message-suffix (&optional c-q-hack ellipsis)
+(defun isearch-message-suffix (&optional c-q-hack _ellipsis)
(concat (if c-q-hack "^Q" "")
(if isearch-error
(concat " [" isearch-error "]")
@@ -2533,7 +2549,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
@@ -2674,6 +2690,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)))
@@ -2763,5 +2781,4 @@ CASE-FOLD non-nil means the search was case-insensitive."
(isearch-search)
(isearch-update))
-;; arch-tag: 74850515-f7d8-43a6-8a2c-ca90a4c1e675
;;; isearch.el ends here
diff --git a/lisp/isearchb.el b/lisp/isearchb.el
index e79d6b26c6b..721fce8ef9a 100644
--- a/lisp/isearchb.el
+++ b/lisp/isearchb.el
@@ -1,7 +1,6 @@
;;; isearchb --- a marriage between iswitchb and isearch
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
;; Maintainer: FSF
@@ -223,5 +222,4 @@ accessed via isearchb."
(provide 'isearchb)
-;; arch-tag: 9277523f-a624-4aa0-ba10-b89eeb7b6e99
;;; isearchb.el ends here
diff --git a/lisp/iswitchb.el b/lisp/iswitchb.el
index a9db65d0cc8..171048e22dc 100644
--- a/lisp/iswitchb.el
+++ b/lisp/iswitchb.el
@@ -1,7 +1,6 @@
;;; iswitchb.el --- switch between buffers using substrings
-;; Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1997, 2000-2011 Free Software Foundation, Inc.
;; Author: Stephen Eglen <stephen@gnu.org>
;; Maintainer: Stephen Eglen <stephen@gnu.org>
@@ -659,7 +658,7 @@ the selection process begins. Used by isearchb.el."
(not (iswitchb-existing-buffer-p)))
(let ((virt (car iswitchb-virtual-buffers))
(new-buf))
- ;; Keep the name of the buffer returned by find-file-noselect, as
+ ;; Keep the name of the buffer returned by find-file-noselect, as
;; the buffer 'virt' could be a symlink to a file of a different name.
(setq new-buf (buffer-name (find-file-noselect (cdr virt))))
(setq iswitchb-matches (list new-buf)
@@ -1016,7 +1015,7 @@ Return the modified list with the last element prepended to it."
(display-completion-list (or iswitchb-matches iswitchb-buflist)
:help-string "iswitchb "
:activate-callback
- (lambda (x y z)
+ (lambda (_x _y _z)
(message "doesn't work yet, sorry!")))
;; else running Emacs
(display-completion-list (or iswitchb-matches iswitchb-buflist))))
@@ -1033,7 +1032,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 +1045,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 +1125,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.
@@ -1443,5 +1436,4 @@ This mode enables switching between buffers using substrings. See
(provide 'iswitchb)
-;; arch-tag: d74198ae-753f-44f2-b34f-0c515398d90a
;;; iswitchb.el ends here
diff --git a/lisp/jit-lock.el b/lisp/jit-lock.el
index bc82f3460fd..b65b186b4e2 100644
--- a/lisp/jit-lock.el
+++ b/lisp/jit-lock.el
@@ -1,10 +1,10 @@
;;; jit-lock.el --- just-in-time fontification
-;; Copyright (C) 1998, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 2000-2011 Free Software Foundation, Inc.
;; Author: Gerd Moellmann <gerd@gnu.org>
;; Keywords: faces files
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -31,33 +31,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.
@@ -610,5 +590,4 @@ will take place when text is fontified stealthily."
(provide 'jit-lock)
-;; arch-tag: 56b5de6e-f581-453b-bb97-49c39372ff9e
;;; jit-lock.el ends here
diff --git a/lisp/jka-cmpr-hook.el b/lisp/jka-cmpr-hook.el
index d19ce809b01..fda9804bbb8 100644
--- a/lisp/jka-cmpr-hook.el
+++ b/lisp/jka-cmpr-hook.el
@@ -1,11 +1,12 @@
;;; jka-cmpr-hook.el --- preloaded code to enable jka-compr.el
-;; Copyright (C) 1993, 1994, 1995, 1997, 1999, 2000, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1995, 1997, 1999-2000, 2002-2011
+;; Free Software Foundation, Inc.
;; Author: jka@ece.cmu.edu (Jay K. Adams)
;; Maintainer: FSF
;; Keywords: data
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -72,10 +73,18 @@ Otherwise, it is nil.")
(defun jka-compr-build-file-regexp ()
(purecopy
- (mapconcat
- 'jka-compr-info-regexp
- jka-compr-compression-info-list
- "\\|")))
+ (let ((re-anchored '())
+ (re-free '()))
+ (dolist (e jka-compr-compression-info-list)
+ (let ((re (jka-compr-info-regexp e)))
+ (if (string-match "\\\\'\\'" re)
+ (push (substring re 0 (match-beginning 0)) re-anchored)
+ (push re re-free))))
+ (concat
+ (if re-free (concat (mapconcat 'identity re-free "\\|") "\\|"))
+ "\\(?:"
+ (mapconcat 'identity re-anchored "\\|")
+ "\\)" file-name-version-regexp "?\\'"))))
;; Functions for accessing the return value of jka-compr-get-compression-info
(defun jka-compr-info-regexp (info) (aref info 0))
@@ -96,11 +105,9 @@ The determination as to which compression scheme, if any, to use is
based on the filename itself and `jka-compr-compression-info-list'."
(catch 'compression-info
(let ((case-fold-search nil))
- (mapc
- (function (lambda (x)
- (and (string-match (jka-compr-info-regexp x) filename)
- (throw 'compression-info x))))
- jka-compr-compression-info-list)
+ (dolist (x jka-compr-compression-info-list)
+ (and (string-match (jka-compr-info-regexp x) filename)
+ (throw 'compression-info x)))
nil)))
(defun jka-compr-install ()
@@ -197,7 +204,7 @@ options through Custom does this automatically."
;; uncomp-message uncomp-prog uncomp-args
;; can-append strip-extension-flag file-magic-bytes]
(mapcar 'purecopy
- '(["\\.Z\\(~\\|\\.~[0-9]+~\\)?\\'"
+ '(["\\.Z\\'"
"compressing" "compress" ("-c")
;; gzip is more common than uncompress. It can only read, not write.
"uncompressing" "gzip" ("-c" "-q" "-d")
@@ -205,7 +212,7 @@ options through Custom does this automatically."
;; Formerly, these had an additional arg "-c", but that fails with
;; "Version 0.1pl2, 29-Aug-97." (RedHat 5.1 GNU/Linux) and
;; "Version 0.9.0b, 9-Sept-98".
- ["\\.bz2\\(~\\|\\.~[0-9]+~\\)?\\'"
+ ["\\.bz2\\'"
"bzip2ing" "bzip2" nil
"bunzip2ing" "bzip2" ("-d")
nil t "BZh"]
@@ -213,15 +220,15 @@ options through Custom does this automatically."
"bzip2ing" "bzip2" nil
"bunzip2ing" "bzip2" ("-d")
nil nil "BZh"]
- ["\\.\\(?:tgz\\|svgz\\|sifz\\)\\(~\\|\\.~[0-9]+~\\)?\\'"
+ ["\\.\\(?:tgz\\|svgz\\|sifz\\)\\'"
"compressing" "gzip" ("-c" "-q")
"uncompressing" "gzip" ("-c" "-q" "-d")
t nil "\037\213"]
- ["\\.g?z\\(~\\|\\.~[0-9]+~\\)?\\'"
+ ["\\.g?z\\'"
"compressing" "gzip" ("-c" "-q")
"uncompressing" "gzip" ("-c" "-q" "-d")
t t "\037\213"]
- ["\\.xz\\(~\\|\\.~[0-9]+~\\)?\\'"
+ ["\\.xz\\'"
"XZ compressing" "xz" ("-c" "-q")
"XZ uncompressing" "xz" ("-c" "-q" "-d")
t t "\3757zXZ\0"]
@@ -334,6 +341,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 +351,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.
@@ -359,5 +365,4 @@ Return the new status of auto compression (non-nil means on)."
(provide 'jka-cmpr-hook)
-;; arch-tag: 4bd73429-f400-45fe-a065-270a113e31a8
;;; jka-cmpr-hook.el ends here
diff --git a/lisp/jka-compr.el b/lisp/jka-compr.el
index 32f3d6d1f58..37c9d40ec65 100644
--- a/lisp/jka-compr.el
+++ b/lisp/jka-compr.el
@@ -1,7 +1,6 @@
;;; jka-compr.el --- reading/writing/loading compressed files
-;; Copyright (C) 1993, 1994, 1995, 1997, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1995, 1997, 1999-2011 Free Software Foundation, Inc.
;; Author: jka@ece.cmu.edu (Jay K. Adams)
;; Maintainer: FSF
@@ -184,7 +183,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))
@@ -225,7 +225,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)
@@ -247,13 +247,10 @@ There should be no more than seven characters after the final `/'."
:type 'string
:group 'jka-compr)
-(defun jka-compr-make-temp-name (&optional local-copy)
+(defun jka-compr-make-temp-name (&optional _local-copy)
"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))
@@ -340,7 +337,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
@@ -575,7 +572,7 @@ There should be no more than seven characters after the final `/'."
;; Support for loading compressed files.
-(defun jka-compr-load (file &optional noerror nomessage nosuffix)
+(defun jka-compr-load (file &optional noerror nomessage _nosuffix)
"Documented as original."
(let* ((local-copy (jka-compr-file-local-copy file))
@@ -606,7 +603,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))
@@ -706,5 +703,4 @@ by `jka-compr-installed'."
(provide 'jka-compr)
-;; arch-tag: 3f15b630-e9a7-46c4-a22a-94afdde86ebc
;;; jka-compr.el ends here
diff --git a/lisp/json.el b/lisp/json.el
index e3899074149..47448f4702a 100644
--- a/lisp/json.el
+++ b/lisp/json.el
@@ -1,6 +1,6 @@
;;; json.el --- JavaScript Object Notation parser / generator
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
;; Author: Edward O'Connor <ted@oconnor.cx>
;; Version: 1.2
@@ -526,5 +526,4 @@ Advances point just past JSON object."
(provide 'json)
-;; arch-tag: 15f6e4c8-b831-4172-8749-bbc680c50ea1
;;; json.el ends here
diff --git a/lisp/kermit.el b/lisp/kermit.el
index c21e9bfa1de..3c8f52db0cd 100644
--- a/lisp/kermit.el
+++ b/lisp/kermit.el
@@ -1,7 +1,6 @@
;;; kermit.el --- additions to shell mode for use with kermit
-;; Copyright (C) 1988, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1988, 2001-2011 Free Software Foundation, Inc.
;; Author: Jeff Norden <jeff@colgate.csnet>
;; Maintainer: FSF
@@ -64,7 +63,7 @@
;; the -c (connect) command line option, which means you also have to specify a
;; line and baud on the command line, as in "kermit -l /dev/tty53 -b 9600 -c".
;; However, this will cause kermit to exit when the connection is closed. So
-;; in order to do a file transfer, you have to think ahead and and add -r
+;; in order to do a file transfer, you have to think ahead and add -r
;; (receive) to the command line. This means that you can't use the server
;; feature. The only fix I can see is to muck around with the source code for
;; kermit, although this probably wouldn't be too hard. What is needed is an
@@ -148,5 +147,4 @@ command `kermit | tr -d '\\015''."
(provide 'kermit)
-;; arch-tag: 6633215d-6c47-4e66-9f27-16fba02a8dce
;;; kermit.el ends here
diff --git a/lisp/kmacro.el b/lisp/kmacro.el
index adf8ffdbe60..e47f571db71 100644
--- a/lisp/kmacro.el
+++ b/lisp/kmacro.el
@@ -1,7 +1,6 @@
;;; kmacro.el --- enhanced keyboard macros
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Kim F. Storm <storm@cua.dk>
;; Keywords: keyboard convenience
@@ -480,7 +479,7 @@ without repeating the prefix."
(kmacro-display (car (car kmacro-ring)) "2nd macro")))
-(defun kmacro-cycle-ring-next (&optional arg)
+(defun kmacro-cycle-ring-next (&optional _arg)
"Move to next keyboard macro in keyboard macro ring.
Displays the selected macro in the echo area."
(interactive)
@@ -499,7 +498,7 @@ Displays the selected macro in the echo area."
(put 'kmacro-cycle-ring-next 'kmacro-repeat 'ring)
-(defun kmacro-cycle-ring-previous (&optional arg)
+(defun kmacro-cycle-ring-previous (&optional _arg)
"Move to previous keyboard macro in keyboard macro ring.
Displays the selected macro in the echo area."
(interactive)
@@ -527,7 +526,7 @@ Displays the selected macro in the echo area."
(kmacro-display last-kbd-macro t)))
-(defun kmacro-delete-ring-head (&optional arg)
+(defun kmacro-delete-ring-head (&optional _arg)
"Delete current macro from keyboard macro ring."
(interactive)
(unless (kmacro-ring-empty-p t)
@@ -642,11 +641,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)
@@ -776,7 +777,7 @@ If kbd macro currently being defined end it before activating it."
mac))
-(defun kmacro-bind-to-key (arg)
+(defun kmacro-bind-to-key (_arg)
"When not defining or executing a macro, offer to bind last macro to a key.
The key sequences [C-x C-k 0] through [C-x C-k 9] and [C-x C-k A]
through [C-x C-k Z] are reserved for user bindings, and to bind to
@@ -836,7 +837,7 @@ Such a \"function\" cannot be called from Lisp, but it is a valid editor command
(put symbol 'kmacro t))
-(defun kmacro-view-macro (&optional arg)
+(defun kmacro-view-macro (&optional _arg)
"Display the last keyboard macro.
If repeated, it shows previous elements in the macro ring."
(interactive)
@@ -915,34 +916,35 @@ without repeating the prefix."
(defvar kmacro-step-edit-help) ;; kmacro step edit help enabled
(defvar kmacro-step-edit-num-input-keys) ;; to ignore duplicate pre-command hook
-(defvar kmacro-step-edit-map (make-sparse-keymap)
+(defvar kmacro-step-edit-map
+ (let ((map (make-sparse-keymap)))
+ ;; query-replace-map answers include: `act', `skip', `act-and-show',
+ ;; `exit', `act-and-exit', `edit', `delete-and-edit', `recenter',
+ ;; `automatic', `backup', `exit-prefix', and `help'.")
+ ;; Also: `quit', `edit-replacement'
+
+ (set-keymap-parent map query-replace-map)
+
+ (define-key map "\t" 'act-repeat)
+ (define-key map [tab] 'act-repeat)
+ (define-key map "\C-k" 'skip-rest)
+ (define-key map "c" 'automatic)
+ (define-key map "f" 'skip-keep)
+ (define-key map "q" 'quit)
+ (define-key map "d" 'skip)
+ (define-key map "\C-d" 'skip)
+ (define-key map "i" 'insert)
+ (define-key map "I" 'insert-1)
+ (define-key map "r" 'replace)
+ (define-key map "R" 'replace-1)
+ (define-key map "a" 'append)
+ (define-key map "A" 'append-end)
+ map)
"Keymap that defines the responses to questions in `kmacro-step-edit-macro'.
This keymap is an extension to the `query-replace-map', allowing the
following additional answers: `insert', `insert-1', `replace', `replace-1',
`append', `append-end', `act-repeat', `skip-end', `skip-keep'.")
-;; query-replace-map answers include: `act', `skip', `act-and-show',
-;; `exit', `act-and-exit', `edit', `delete-and-edit', `recenter',
-;; `automatic', `backup', `exit-prefix', and `help'.")
-;; Also: `quit', `edit-replacement'
-
-(set-keymap-parent kmacro-step-edit-map query-replace-map)
-
-(define-key kmacro-step-edit-map "\t" 'act-repeat)
-(define-key kmacro-step-edit-map [tab] 'act-repeat)
-(define-key kmacro-step-edit-map "\C-k" 'skip-rest)
-(define-key kmacro-step-edit-map "c" 'automatic)
-(define-key kmacro-step-edit-map "f" 'skip-keep)
-(define-key kmacro-step-edit-map "q" 'quit)
-(define-key kmacro-step-edit-map "d" 'skip)
-(define-key kmacro-step-edit-map "\C-d" 'skip)
-(define-key kmacro-step-edit-map "i" 'insert)
-(define-key kmacro-step-edit-map "I" 'insert-1)
-(define-key kmacro-step-edit-map "r" 'replace)
-(define-key kmacro-step-edit-map "R" 'replace-1)
-(define-key kmacro-step-edit-map "a" 'append)
-(define-key kmacro-step-edit-map "A" 'append-end)
-
(defvar kmacro-step-edit-prefix-commands
'(universal-argument universal-argument-more universal-argument-minus
digit-argument negative-argument)
@@ -1268,5 +1270,4 @@ To customize possible responses, change the \"bindings\" in `kmacro-step-edit-ma
(provide 'kmacro)
-;; arch-tag: d3fe0b24-ae41-47de-a4d6-41a77d5559f0
;;; kmacro.el ends here
diff --git a/lisp/language/burmese.el b/lisp/language/burmese.el
index 2742fd315bd..9fce0583161 100644
--- a/lisp/language/burmese.el
+++ b/lisp/language/burmese.el
@@ -57,4 +57,3 @@
(set-char-table-range composition-function-table '(#x1000 . #x107F) elt)
(set-char-table-range composition-function-table '(#xAA60 . #xAA7B) elt))
-;; arch-tag: 8ba5f4cd-ef89-4008-b784-397edd0cb32e
diff --git a/lisp/language/cham.el b/lisp/language/cham.el
index 9ea6b0e28c8..d1ddfb512a9 100644
--- a/lisp/language/cham.el
+++ b/lisp/language/cham.el
@@ -42,4 +42,3 @@
;; coding: utf-8
;; End:
-;; arch-tag: a393ea52-445b-4e22-a967-c244afc88cf6
diff --git a/lisp/language/china-util.el b/lisp/language/china-util.el
index edbed8a7769..9f79dd087bb 100644
--- a/lisp/language/china-util.el
+++ b/lisp/language/china-util.el
@@ -1,7 +1,6 @@
;;; china-util.el --- utilities for Chinese -*- coding: iso-2022-7bit -*-
-;; Copyright (C) 1995, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1995, 2001-2011 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -191,5 +190,4 @@ Return the length of resulting text."
;;
(provide 'china-util)
-;; arch-tag: 5a47b084-b9ac-420e-8191-70c5b3a14836
;;; china-util.el ends here
diff --git a/lisp/language/chinese.el b/lisp/language/chinese.el
index c03849e23e8..c44dc44581d 100644
--- a/lisp/language/chinese.el
+++ b/lisp/language/chinese.el
@@ -1,7 +1,6 @@
;;; chinese.el --- support for Chinese -*- coding: iso-2022-7bit; -*-
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -287,5 +286,4 @@ converted to CNS)."))
(provide 'chinese)
-;; arch-tag: b82fcf7a-84f6-4e0b-b38c-1742dac0e09f
;;; chinese.el ends here
diff --git a/lisp/language/cyril-util.el b/lisp/language/cyril-util.el
index d57edf0ed6c..e833bb7ab04 100644
--- a/lisp/language/cyril-util.el
+++ b/lisp/language/cyril-util.el
@@ -1,7 +1,6 @@
;;; cyril-util.el --- utilities for Cyrillic scripts
-;; Copyright (C) 1997, 1998, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-1998, 2001-2011 Free Software Foundation, Inc.
;; Keywords: mule, multilingual, Cyrillic
@@ -192,5 +191,4 @@ If the argument is nil, we return the display table to its standard state."
;; coding: iso-2022-7bit
;; End:
-;; arch-tag: f6d9dd5d-685c-45d6-a5d8-1e2178228b7e
;;; cyril-util.el ends here
diff --git a/lisp/language/cyrillic.el b/lisp/language/cyrillic.el
index 1d728e48abc..8fb7fae720d 100644
--- a/lisp/language/cyrillic.el
+++ b/lisp/language/cyrillic.el
@@ -1,7 +1,6 @@
;;; cyrillic.el --- support for Cyrillic -*- coding: iso-2022-7bit; -*-
-;; Copyright (C) 1997, 1998, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1997-1998, 2001-2011 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -272,5 +271,4 @@ Support for Russian using koi8-r and the russian-computer input method.")
(provide 'cyrillic)
-;; arch-tag: bda71ae0-ba41-4cb6-a6e0-1dff542313d3
;;; cyrillic.el ends here
diff --git a/lisp/language/czech.el b/lisp/language/czech.el
index fd7834c2243..2325699e30e 100644
--- a/lisp/language/czech.el
+++ b/lisp/language/czech.el
@@ -1,7 +1,6 @@
;;; czech.el --- support for Czech -*- coding: iso-2022-7bit; no-byte-compile: t -*-
-;; Copyright (C) 1998, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation.
+;; Copyright (C) 1998, 2001-2011 Free Software Foundation, Inc.
;; Author: Milan Zamazal <pdm@zamazal.org>
;; Maintainer: Pavel Jan,Am(Bk <Pavel@Janik.cz>
@@ -45,5 +44,4 @@ and selects the Czech tutorial."))
(provide 'czech)
-;; arch-tag: 45ac0d83-ca13-4b5e-9e82-821e44080c24
;;; czech.el ends here
diff --git a/lisp/language/english.el b/lisp/language/english.el
index 9dde2d3ff7e..dd96d38a197 100644
--- a/lisp/language/english.el
+++ b/lisp/language/english.el
@@ -1,7 +1,6 @@
;;; english.el --- support for English -*- no-byte-compile: t -*-
-;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2001-2011 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
;; 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -67,5 +66,4 @@ Nothing special is needed to handle English.")
(set-language-info-alist
"ASCII" (cdr (assoc "English" language-info-alist)))
-;; arch-tag: e440bdb0-91b0-4fb4-ae38-425780f8f745
;;; english.el ends here
diff --git a/lisp/language/ethio-util.el b/lisp/language/ethio-util.el
index 6aa316c8820..bb242a50acc 100644
--- a/lisp/language/ethio-util.el
+++ b/lisp/language/ethio-util.el
@@ -1,7 +1,6 @@
;;; ethio-util.el --- utilities for Ethiopic -*- coding: utf-8; -*-
-;; Copyright (C) 1997, 1998, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1997-1998, 2002-2011 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
;; 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -869,7 +868,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)))))
@@ -2073,5 +2072,4 @@ mark."
;;; ethio-util.el ends here
-;; arch-tag: c8feb3d6-39bf-4b0a-b6ef-26f03fbc8140
;;; ethio-util.el ends here
diff --git a/lisp/language/ethiopic.el b/lisp/language/ethiopic.el
index 07d42278f3f..22ccd56dab3 100644
--- a/lisp/language/ethiopic.el
+++ b/lisp/language/ethiopic.el
@@ -1,7 +1,6 @@
;;; ethiopic.el --- support for Ethiopic -*- coding: utf-8-emacs; -*-
-;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2001-2011 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -85,5 +84,4 @@
(provide 'ethiopic)
-;; arch-tag: e81329d9-1286-43ba-92fd-54ce5c7b213c
;;; ethiopic.el ends here
diff --git a/lisp/language/european.el b/lisp/language/european.el
index 46c37945d19..6dfc03d0f5f 100644
--- a/lisp/language/european.el
+++ b/lisp/language/european.el
@@ -1,7 +1,6 @@
;;; european.el --- support for European languages -*- coding: iso-2022-7bit; -*-
-;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-1998, 2000-2011 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -639,5 +638,4 @@ method and applying Turkish case rules for the characters i, I, $(D)E(B, $(D*
(provide 'european)
-;; arch-tag: 9e018b12-fb02-4120-907b-9adeaf84b5c2
;;; european.el ends here
diff --git a/lisp/language/georgian.el b/lisp/language/georgian.el
index 91c09beb202..be6da8cba17 100644
--- a/lisp/language/georgian.el
+++ b/lisp/language/georgian.el
@@ -1,7 +1,6 @@
;;; georgian.el --- language support for Georgian -*- no-byte-compile: t -*-
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;; Author: Dave Love <fx@gnu.org>
;; Keywords: i18n
@@ -48,5 +47,4 @@
(provide 'georgian)
-;; arch-tag: 15499fbb-26d4-4a13-9d78-135eef7d32f5
;;; georgian.el ends here
diff --git a/lisp/language/greek.el b/lisp/language/greek.el
index bddc791eeb1..e4d239cdf27 100644
--- a/lisp/language/greek.el
+++ b/lisp/language/greek.el
@@ -83,5 +83,4 @@
(provide 'greek)
-;; arch-tag: 9ba48d79-84bc-45e1-9318-685dc3921410
;;; greek.el ends here
diff --git a/lisp/language/hanja-util.el b/lisp/language/hanja-util.el
index 8de533afab5..bd661083406 100644
--- a/lisp/language/hanja-util.el
+++ b/lisp/language/hanja-util.el
@@ -1,6 +1,6 @@
;;; hanja-util.el --- Korean Hanja util module -*- coding: utf-8 -*-
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Jihyun Cho <jihyun.jo@gmail.com>
;; Keywords: multilingual, input method, Korean, Hanja
@@ -6591,5 +6591,4 @@ The value is a hanja character that is selected interactively."
(provide 'hanja-util)
-;; arch-tag: 3358afb4-c63f-472f-989a-5249129924d1
;;; hanja-util.el ends here
diff --git a/lisp/language/hebrew.el b/lisp/language/hebrew.el
index 3ff2538469d..fd3e16b307a 100644
--- a/lisp/language/hebrew.el
+++ b/lisp/language/hebrew.el
@@ -1,7 +1,6 @@
-;;; 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, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -46,28 +45,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,7 +83,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
;;; hebrew.el ends here
diff --git a/lisp/language/ind-util.el b/lisp/language/ind-util.el
index be3fba4a301..56893af1479 100644
--- a/lisp/language/ind-util.el
+++ b/lisp/language/ind-util.el
@@ -1,7 +1,6 @@
;;; ind-util.el --- Transliteration and Misc. Tools for Indian Languages -*- coding: iso-2022-7bit; -*-
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;; Maintainer: KAWABATA, Taichi <kawabata@m17n.org>
;; Keywords: multilingual, Indian, Devanagari
@@ -1213,5 +1212,4 @@ Returns new end position."
(provide 'ind-util)
-;; arch-tag: 59aacd71-46c2-4cb3-bb26-e12bbad55545
;;; ind-util.el ends here
diff --git a/lisp/language/indian.el b/lisp/language/indian.el
index aa0bb5117a2..8203213d8eb 100644
--- a/lisp/language/indian.el
+++ b/lisp/language/indian.el
@@ -1,7 +1,6 @@
;;; indian.el --- Indian languages support -*- coding: utf-8; -*-
-;; Copyright (C) 1997, 1999, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1997, 1999, 2001-2011 Free Software Foundation, Inc.
;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
;; Registration Number H14PRO021
@@ -389,5 +388,4 @@ South Indian language Malayalam is supported in this language environment."))
(provide 'indian)
-;; arch-tag: 83aa8fc7-7ee2-4364-a6e5-498f5e3b8c2f
;;; indian.el ends here
diff --git a/lisp/language/japan-util.el b/lisp/language/japan-util.el
index 5df35643e3f..dcf3dc0f90e 100644
--- a/lisp/language/japan-util.el
+++ b/lisp/language/japan-util.el
@@ -1,7 +1,6 @@
;;; japan-util.el --- utilities for Japanese -*- coding: iso-2022-7bit; -*-
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -325,5 +324,4 @@ If non-nil, second arg INITIAL-INPUT is a string to insert before reading."
;;
(provide 'japan-util)
-;; arch-tag: b579595c-c9ad-4b57-9314-98cd8b214f89
;;; japan-util.el ends here
diff --git a/lisp/language/japanese.el b/lisp/language/japanese.el
index 09800ceb4f6..bf8a4d8d5c2 100644
--- a/lisp/language/japanese.el
+++ b/lisp/language/japanese.el
@@ -1,7 +1,6 @@
;;; japanese.el --- support for Japanese -*- coding: iso-2022-7bit; no-byte-compile: t -*-
-;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2001-2011 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -274,5 +273,4 @@ and the second is a glyph for a variation selector."
(provide 'japanese)
-;; arch-tag: 450f5537-9d53-4d5e-b731-4cf116d8cbc9
;;; japanese.el ends here
diff --git a/lisp/language/khmer.el b/lisp/language/khmer.el
index 9e1dbf6c4b4..d01fa3b33bd 100644
--- a/lisp/language/khmer.el
+++ b/lisp/language/khmer.el
@@ -35,5 +35,4 @@
(set-char-table-range composition-function-table '(#x1780 . #x17FF) val)
(set-char-table-range composition-function-table '(#x19E0 . #x19FF) val))
-;; arch-tag: 032890e4-a936-4584-ad44-79eb5f8bc98e
;; khmer.el ends here
diff --git a/lisp/language/korea-util.el b/lisp/language/korea-util.el
index 43ef614a47c..e2367cf0f7e 100644
--- a/lisp/language/korea-util.el
+++ b/lisp/language/korea-util.el
@@ -1,7 +1,6 @@
;;; korea-util.el --- utilities for Korean
-;; Copyright (C) 1997, 1999, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1997, 1999, 2001-2011 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
;; 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -143,5 +142,4 @@
;;
(provide 'korea-util)
-;; arch-tag: b17d0981-05da-4577-99f8-1db87fff8b44
;;; korea-util.el ends here
diff --git a/lisp/language/korean.el b/lisp/language/korean.el
index d7967a8e956..acb9fea268d 100644
--- a/lisp/language/korean.el
+++ b/lisp/language/korean.el
@@ -1,7 +1,6 @@
;;; korean.el --- support for Korean -*- coding: iso-2022-7bit; no-byte-compile: t -*-
-;; Copyright (C) 1998, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1998, 2001-2011 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -87,5 +86,4 @@ and the following key bindings are available within Korean input methods:
(provide 'korean)
-;; arch-tag: ca7c7348-5ca3-4623-887a-7fd33d725d0e
;;; korean.el ends here
diff --git a/lisp/language/lao-util.el b/lisp/language/lao-util.el
index 6c441a1f30e..81c5577fa57 100644
--- a/lisp/language/lao-util.el
+++ b/lisp/language/lao-util.el
@@ -1,7 +1,6 @@
;;; lao-util.el --- utilities for Lao -*- coding: iso-2022-7bit; -*-
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
;; 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -516,5 +515,4 @@ syllable. In that case, FROM and TO are indexes to STR."
;;
(provide 'lao-util)
-;; arch-tag: 1f828781-3cb8-4695-88af-8f33222338ce
;;; lao-util.el ends here
diff --git a/lisp/language/lao.el b/lisp/language/lao.el
index d60459a1f1d..c09c6f8a0ef 100644
--- a/lisp/language/lao.el
+++ b/lisp/language/lao.el
@@ -1,7 +1,6 @@
;;; lao.el --- support for Lao -*- coding: utf-8; no-byte-compile: t -*-
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
;; 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -83,5 +82,4 @@
(provide 'lao)
-;; arch-tag: ba540fd9-6352-4449-a9cd-669afd21fa57
;;; lao.el ends here
diff --git a/lisp/language/misc-lang.el b/lisp/language/misc-lang.el
index eded44e6613..6fa54ff5c80 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,7 +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
;;; misc-lang.el ends here
diff --git a/lisp/language/romanian.el b/lisp/language/romanian.el
index 5319a18b474..b9c250fd700 100644
--- a/lisp/language/romanian.el
+++ b/lisp/language/romanian.el
@@ -1,7 +1,6 @@
;;; romanian.el --- support for Romanian -*- coding: iso-latin-2; no-byte-compile: t -*-
-;; Copyright (C) 1998, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation.
+;; Copyright (C) 1998, 2001-2011 Free Software Foundation, Inc.
;; Author: Dan Nicolaescu <done@ece.arizona.edu>
;; Keywords: multilingual, Romanian, i18n
@@ -52,5 +51,4 @@ An environment for generic Latin-10 encoding is also available."))
(provide 'romanian)
-;; arch-tag: a0bf93ee-2f02-4678-a477-c08acc35366b
;;; romanian.el ends here
diff --git a/lisp/language/sinhala.el b/lisp/language/sinhala.el
index 0b9bf1279fe..ea8a6a34cd8 100644
--- a/lisp/language/sinhala.el
+++ b/lisp/language/sinhala.el
@@ -45,5 +45,4 @@
"[\u0D80-\u0DFF]")
0 'font-shape-gstring)))
-;; arch-tag: 87b9ad3b-5090-422f-b942-eb85b9d52e7c
;; sinhala.el ends here
diff --git a/lisp/language/slovak.el b/lisp/language/slovak.el
index 458c0327e0d..94aa5fdc94c 100644
--- a/lisp/language/slovak.el
+++ b/lisp/language/slovak.el
@@ -1,7 +1,6 @@
;;; slovak.el --- support for Slovak -*- coding: iso-2022-7bit; no-byte-compile: t -*-
-;; Copyright (C) 1998, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation.
+;; Copyright (C) 1998, 2001-2011 Free Software Foundation, Inc.
;; Authors: Tibor ,B)(Bimko <tibor.simko@fmph.uniba.sk>,
;; Milan Zamazal <pdm@zamazal.org>
@@ -46,5 +45,4 @@ and selects the Slovak tutorial."))
(provide 'slovak)
-;; arch-tag: 1bae098a-33b2-4426-8c29-59e44fe05484
;;; slovak.el ends here
diff --git a/lisp/language/tai-viet.el b/lisp/language/tai-viet.el
index a9b44e49dd6..f6e525b0d25 100644
--- a/lisp/language/tai-viet.el
+++ b/lisp/language/tai-viet.el
@@ -1,9 +1,9 @@
;;; tai-viet.el --- support for Tai Viet -*- coding: utf-8; no-byte-compile: t -*-
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Copyright (C) 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
;; Registration Number H13PRO009
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;; Keywords: multilingual, Tai Viet, i18n
@@ -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)
@@ -61,5 +61,3 @@ is available at this web page:
;; Local Variables:
;; coding: utf-8
;; End:
-
-;; arch-tag: db4e3377-2ba7-47a0-b173-e44420d540c3
diff --git a/lisp/language/thai-util.el b/lisp/language/thai-util.el
index b15197be29e..b7dbcc1a956 100644
--- a/lisp/language/thai-util.el
+++ b/lisp/language/thai-util.el
@@ -1,11 +1,10 @@
;;; thai-util.el --- utilities for Thai -*- coding: utf-8; -*-
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
;; Registration Number H14PRO021
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
;; Keywords: mule, multilingual, Thai, i18n
@@ -282,5 +281,4 @@ The commands affected are \\[forward-word], \\[backward-word], \\[kill-word], \\
;;
(provide 'thai-util)
-;; arch-tag: 59425d6a-8cf9-4e06-a6ab-8ab7dc7a7a97
;;; thai-util.el ends here
diff --git a/lisp/language/thai-word.el b/lisp/language/thai-word.el
index 55a89f462c0..5cb13e08fd6 100644
--- a/lisp/language/thai-word.el
+++ b/lisp/language/thai-word.el
@@ -11077,4 +11077,3 @@ With argument, do this that many times."
;; end of thai-word.el
-;; arch-tag: 29927f02-e177-4224-a270-7e67210b038a
diff --git a/lisp/language/thai.el b/lisp/language/thai.el
index b4f3177a233..dd28ec77edb 100644
--- a/lisp/language/thai.el
+++ b/lisp/language/thai.el
@@ -1,5 +1,6 @@
;;; thai.el --- support for Thai -*- coding: iso-2022-7bit; no-byte-compile: t -*-
+;; Copyright (C) 1997-1998, 2000-2011 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -7,8 +8,6 @@
;; Copyright (C) 2005
;; National Institute of Advanced Industrial Science and Technology (AIST)
;; Registration Number H14PRO021
-;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;; Keywords: multilingual, Thai, i18n
@@ -85,5 +84,4 @@ This is the same as `thai-tis620' with the addition of no-break-space."
(provide 'thai)
-;; arch-tag: c7eb0e91-4db0-4619-81f8-8762e7d51e15
;;; thai.el ends here
diff --git a/lisp/language/tibet-util.el b/lisp/language/tibet-util.el
index 2f446a18141..8458974e753 100644
--- a/lisp/language/tibet-util.el
+++ b/lisp/language/tibet-util.el
@@ -1,7 +1,6 @@
;;; tibet-util.el --- utilities for Tibetan -*- coding: iso-2022-7bit; -*-
-;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2001-2011 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -421,5 +420,4 @@ before writing buffer in Unicode. See also
(provide 'tibet-util)
-;; arch-tag: 7a7333e8-1584-446c-b39c-a02b9def265d
;;; tibet-util.el ends here
diff --git a/lisp/language/tibetan.el b/lisp/language/tibetan.el
index 7ece195b1e7..a23645bae1f 100644
--- a/lisp/language/tibetan.el
+++ b/lisp/language/tibetan.el
@@ -1,7 +1,6 @@
;;; tibetan.el --- support for Tibetan language -*- coding: iso-2022-7bit; -*-
-;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2001-2011 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
;; 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -611,5 +610,4 @@ This also matches some punctuation characters which need conversion.")
(provide 'tibetan)
-;; arch-tag: 8d37c8d7-f95d-450f-9ec2-819e61fc79a7
;;; tibetan.el ends here
diff --git a/lisp/language/tv-util.el b/lisp/language/tv-util.el
index 1e6a4cee281..400856d1aa3 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
@@ -140,4 +139,3 @@
;;
(provide 'tai-viet-util)
-;; arch-tag: a45ac3fc-07d0-44d5-8841-2ebea7e11f5b
diff --git a/lisp/language/utf-8-lang.el b/lisp/language/utf-8-lang.el
index 0eef348e183..dd840772218 100644
--- a/lisp/language/utf-8-lang.el
+++ b/lisp/language/utf-8-lang.el
@@ -1,7 +1,6 @@
;;; utf-8-lang.el --- generic UTF-8 language environment -*- no-byte-compile: t -*-
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;; Author: Dave Love <fx@gnu.org>
;; Keywords: i18n
@@ -52,5 +51,4 @@ encoded in UTF-8."))
(provide 'utf-8-lang)
-;; arch-tag: dfa339e1-296f-4b1e-9fe8-2b65279ec813
;;; utf-8-lang.el ends here
diff --git a/lisp/language/viet-util.el b/lisp/language/viet-util.el
index 9c651e05532..ea601c041e4 100644
--- a/lisp/language/viet-util.el
+++ b/lisp/language/viet-util.el
@@ -1,7 +1,6 @@
;;; viet-util.el --- utilities for Vietnamese -*- coding: iso-2022-7bit; -*-
-;; Copyright (C) 1998, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1998, 2001-2011 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -296,5 +295,4 @@ positions (integers or markers) specifying the stretch of the region."
;;;
(provide 'viet-util)
-;; arch-tag: 082a4d3b-168f-45b4-b3e1-82bfa1b5a194
;;; viet-util.el ends here
diff --git a/lisp/language/vietnamese.el b/lisp/language/vietnamese.el
index 65933c7658e..97d5037f3c5 100644
--- a/lisp/language/vietnamese.el
+++ b/lisp/language/vietnamese.el
@@ -1,7 +1,6 @@
;;; vietnamese.el --- support for Vietnamese -*- coding: iso-2022-7bit; -*-
-;; Copyright (C) 1998, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1998, 2001-2011 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -110,5 +109,4 @@ Telex, VIQR is the default setting.")))
(provide 'vietnamese)
-;; arch-tag: 5bd4f1aa-2d4e-4f33-b7d8-0679c6a19ee6
;;; vietnamese.el ends here
diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el
index 77e95cbf74a..a89e760f0b9 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" (19752 41642))
+;;;;;; "play/5x5.el" (19889 21967))
;;; Generated autoloads from play/5x5.el
(autoload '5x5 "5x5" "\
@@ -64,19 +64,8 @@ should return a grid vector array that is the new solution.
;;;***
-;;;### (autoloads (list-one-abbrev-table) "abbrevlist" "abbrevlist.el"
-;;;;;; (19752 41642))
-;;; Generated autoloads from abbrevlist.el
-
-(autoload 'list-one-abbrev-table "abbrevlist" "\
-Display alphabetical listing of ABBREV-TABLE in buffer OUTPUT-BUFFER.
-
-\(fn ABBREV-TABLE OUTPUT-BUFFER)" nil nil)
-
-;;;***
-
;;;### (autoloads (ada-mode ada-add-extensions) "ada-mode" "progmodes/ada-mode.el"
-;;;;;; (19752 41642))
+;;;;;; (19890 42850))
;;; Generated autoloads from progmodes/ada-mode.el
(autoload 'ada-add-extensions "ada-mode" "\
@@ -96,7 +85,7 @@ Ada mode is the major mode for editing Ada code.
;;;***
;;;### (autoloads (ada-header) "ada-stmt" "progmodes/ada-stmt.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from progmodes/ada-stmt.el
(autoload 'ada-header "ada-stmt" "\
@@ -107,7 +96,7 @@ Insert a descriptive header at the top of the file.
;;;***
;;;### (autoloads (ada-find-file) "ada-xref" "progmodes/ada-xref.el"
-;;;;;; (19752 41642))
+;;;;;; (19890 42850))
;;; Generated autoloads from progmodes/ada-xref.el
(autoload 'ada-find-file "ada-xref" "\
@@ -121,9 +110,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" (19752
-;;;;;; 41642))
-;;; Generated autoloads from add-log.el
+;;;;;; add-log-current-defun-function) "add-log" "vc/add-log.el"
+;;;;;; (19885 24894))
+;;; Generated autoloads from vc/add-log.el
(put 'change-log-default-name 'safe-local-variable 'string-or-null-p)
@@ -261,7 +250,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" (19752 41642))
+;;;;;; "advice" "emacs-lisp/advice.el" (19878 51661))
;;; Generated autoloads from emacs-lisp/advice.el
(defvar ad-redefinition-action 'warn "\
@@ -400,11 +389,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" (19752 41642))
+;;;;;; align) "align" "align.el" (19886 45771))
;;; Generated autoloads from align.el
(autoload 'align "align" "\
@@ -493,10 +484,50 @@ A replacement function for `newline-and-indent', aligning as it goes.
;;;***
-;;;### (autoloads (outlineify-sticky allout-mode) "allout" "allout.el"
-;;;;;; (19813 16320))
+;;;### (autoloads (outlineify-sticky allout-mode allout-mode-p allout-auto-activation
+;;;;;; allout-setup allout-auto-activation-helper) "allout" "allout.el"
+;;;;;; (19859 11635))
;;; Generated autoloads from allout.el
+(autoload 'allout-auto-activation-helper "allout" "\
+Institute `allout-auto-activation'.
+
+Intended to be used as the `allout-auto-activation' :set function.
+
+\(fn VAR VALUE)" nil nil)
+
+(autoload 'allout-setup "allout" "\
+Do fundamental emacs session for allout auto-activation.
+
+Establishes allout processing as part of visiting a file if
+`allout-auto-activation' is non-nil, or removes it otherwise.
+
+The proper way to use this is through customizing the setting of
+`allout-auto-activation'.
+
+\(fn)" nil nil)
+
+(defvar allout-auto-activation nil "\
+Configure allout outline mode auto-activation.
+
+Control whether and how allout outline mode is automatically
+activated when files are visited with non-nil buffer-specific
+file variable `allout-layout'.
+
+When allout-auto-activation is \"On\" (t), allout mode is
+activated in buffers with non-nil `allout-layout', and the
+specified layout is applied.
+
+With value \"ask\", auto-mode-activation is enabled, and endorsement for
+performing auto-layout is asked of the user each time.
+
+With value \"activate\", only auto-mode-activation is enabled.
+Auto-layout is not.
+
+With value nil, inhibit any automatic allout-mode activation.")
+
+(custom-autoload 'allout-auto-activation "allout" nil)
+
(put 'allout-use-hanging-indents 'safe-local-variable (if (fboundp 'booleanp) 'booleanp '(lambda (x) (member x '(t nil)))))
(put 'allout-reindent-bodies 'safe-local-variable '(lambda (x) (memq x '(nil t text force))))
@@ -529,20 +560,23 @@ A replacement function for `newline-and-indent', aligning as it goes.
(put 'allout-passphrase-hint-string 'safe-local-variable 'stringp)
+(autoload 'allout-mode-p "allout" "\
+Return t if `allout-mode' is active in current buffer.
+
+\(fn)" nil (quote macro))
+
(autoload 'allout-mode "allout" "\
Toggle minor mode for controlling exposure and editing of text outlines.
-\\<allout-mode-map>
+\\<allout-mode-map-value>
-Optional prefix argument TOGGLE forces the mode to re-initialize
-if it is positive, otherwise it turns the mode off. Allout
-outline mode always runs as a minor mode.
+Allout outline mode always runs as a minor mode.
-Allout outline mode provides extensive outline oriented formatting and
-manipulation. It enables structural editing of outlines, as well as
-navigation and exposure. It also is specifically aimed at
-accommodating syntax-sensitive text like programming languages. (For
-an example, see the allout code itself, which is organized as an allout
-outline.)
+Allout outline mode provides extensive outline oriented
+formatting and manipulation. It enables structural editing of
+outlines, as well as navigation and exposure. It also is
+specifically aimed at accommodating syntax-sensitive text like
+programming languages. (For example, see the allout code itself,
+which is organized as an allout outline.)
In addition to typical outline navigation and exposure, allout includes:
@@ -550,27 +584,29 @@ In addition to typical outline navigation and exposure, allout includes:
repositioning, promotion/demotion, cut, and paste
- incremental search with dynamic exposure and reconcealment of hidden text
- adjustable format, so programming code can be developed in outline-structure
- - easy topic encryption and decryption
+ - easy topic encryption and decryption, symmetric or key-pair
- \"Hot-spot\" operation, for single-keystroke maneuvering and exposure control
- integral outline layout, for automatic initial exposure when visiting a file
- independent extensibility, using comprehensive exposure and authoring hooks
and many other features.
-Below is a description of the key bindings, and then explanation of
-special `allout-mode' features and terminology. See also the outline
-menubar additions for quick reference to many of the features, and see
-the docstring of the function `allout-init' for instructions on
-priming your emacs session for automatic activation of `allout-mode'.
-
-The bindings are dictated by the customizable `allout-keybindings-list'
-variable. We recommend customizing `allout-command-prefix' to use just
-`\\C-c' as the command prefix, if the allout bindings don't conflict with
-any personal bindings you have on \\C-c. In any case, outline structure
-navigation and authoring is simplified by positioning the cursor on an
-item's bullet character, the \"hot-spot\" -- then you can invoke allout
-commands with just the un-prefixed, un-control-shifted command letters.
-This is described further in the HOT-SPOT Operation section.
+Below is a description of the key bindings, and then description
+of special `allout-mode' features and terminology. See also the
+outline menubar additions for quick reference to many of the
+features. Customize `allout-auto-activation' to prepare your
+emacs session for automatic activation of `allout-mode'.
+
+The bindings are those listed in `allout-prefixed-keybindings'
+and `allout-unprefixed-keybindings'. We recommend customizing
+`allout-command-prefix' to use just `\\C-c' as the command
+prefix, if the allout bindings don't conflict with any personal
+bindings you have on \\C-c. In any case, outline structure
+navigation and authoring is simplified by positioning the cursor
+on an item's bullet character, the \"hot-spot\" -- then you can
+invoke allout commands with just the un-prefixed,
+un-control-shifted command letters. This is described further in
+the HOT-SPOT Operation section.
Exposure Control:
----------------
@@ -643,25 +679,29 @@ M-x outlineify-sticky Activate outline mode for current buffer,
Like above 'copy-exposed', but convert topic
prefixes to section.subsection... numeric
format.
-\\[eval-expression] (allout-init t) Setup Emacs session for outline mode
+\\[customize-variable] allout-auto-activation
+ Prepare Emacs session for allout outline mode
auto-activation.
Topic Encryption
Outline mode supports gpg encryption of topics, with support for
-symmetric and key-pair modes, passphrase timeout, passphrase
-consistency checking, user-provided hinting for symmetric key
-mode, and auto-encryption of topics pending encryption on save.
+symmetric and key-pair modes, and auto-encryption of topics
+pending encryption on save.
Topics pending encryption are, by default, automatically
-encrypted during file saves. If the contents of the topic
-containing the cursor was encrypted for a save, it is
-automatically decrypted for continued editing.
-
-The aim of these measures is reliable topic privacy while
-preventing accidents like neglected encryption before saves,
-forgetting which passphrase was used, and other practical
-pitfalls.
+encrypted during file saves, including checkpoint saves, to avoid
+exposing the plain text of encrypted topics in the file system.
+If the content of the topic containing the cursor was encrypted
+for a save, it is automatically decrypted for continued editing.
+
+NOTE: A few GnuPG v2 versions improperly preserve incorrect
+symmetric decryption keys, preventing entry of the correct key on
+subsequent decryption attempts until the cache times-out. That
+can take several minutes. (Decryption of other entries is not
+affected.) Upgrade your EasyPG version, if you can, and you can
+deliberately clear your gpg-agent's cache by sending it a '-HUP'
+signal.
See `allout-toggle-current-subtree-encryption' function docstring
and `allout-encrypt-unencrypted-on-saves' customization variable
@@ -699,11 +739,13 @@ hooks, by which independent code can cooperate with allout
without changes to the allout core. Here are key ones:
`allout-mode-hook'
-`allout-mode-deactivate-hook'
+`allout-mode-deactivate-hook' (deprecated)
+`allout-mode-off-hook'
`allout-exposure-change-hook'
`allout-structure-added-hook'
`allout-structure-deleted-hook'
`allout-structure-shifted-hook'
+`allout-after-copy-or-kill-hook'
Terminology
@@ -786,22 +828,82 @@ CONCEALED:
CLOSED: A TOPIC whose immediate OFFSPRING and body-text is CONCEALED.
OPEN: A TOPIC that is not CLOSED, though its OFFSPRING or BODY may be.
-\(fn &optional TOGGLE)" t nil)
+\(fn &optional ARG)" t nil)
(defalias 'outlinify-sticky 'outlineify-sticky)
(autoload 'outlineify-sticky "allout" "\
Activate outline mode and establish file var so it is started subsequently.
-See doc-string for `allout-layout' and `allout-init' for details on
-setup for auto-startup.
+See `allout-layout' and customization of `allout-auto-activation'
+for details on preparing emacs for automatic allout activation.
+
+\(fn &optional ARG)" t nil)
+
+;;;***
+
+;;;### (autoloads (allout-widgets-mode allout-widgets-auto-activation
+;;;;;; allout-widgets-setup allout-widgets) "allout-widgets" "allout-widgets.el"
+;;;;;; (19859 11635))
+;;; Generated autoloads from allout-widgets.el
+
+(let ((loads (get 'allout-widgets 'custom-loads))) (if (member '"allout-widgets" loads) nil (put 'allout-widgets 'custom-loads (cons '"allout-widgets" loads))))
+
+(autoload 'allout-widgets-setup "allout-widgets" "\
+Commission or decommision allout-widgets-mode along with allout-mode.
+
+Meant to be used by customization of `allout-widgets-auto-activation'.
+
+\(fn VARNAME VALUE)" nil nil)
+
+(defvar allout-widgets-auto-activation nil "\
+Activate to enable allout icon graphics wherever allout mode is active.
+
+Also enable `allout-auto-activation' for this to take effect upon
+visiting an outline.
+
+When this is set you can disable allout widgets in select files
+by setting `allout-widgets-mode-inhibit'
+
+Instead of setting `allout-widgets-auto-activation' you can
+explicitly invoke `allout-widgets-mode' in allout buffers where
+you want allout widgets operation.
+
+See `allout-widgets-mode' for allout widgets mode features.")
+
+(custom-autoload 'allout-widgets-auto-activation "allout-widgets" nil)
+
+(put 'allout-widgets-mode-inhibit 'safe-local-variable (if (fboundp 'booleanp) 'booleanp '(lambda (x) (member x '(t nil)))))
+
+(autoload 'allout-widgets-mode "allout-widgets" "\
+Allout-mode extension, providing graphical decoration of outline structure.
+
+This is meant to operate along with allout-mode, via `allout-mode-hook'.
+
+If optional argument ARG is greater than 0, enable.
+If optional argument ARG is less than 0, disable.
+Anything else, toggle between active and inactive.
+
+The graphics include:
+
+- guide lines connecting item bullet-icons with those of their subitems.
+
+- icons for item bullets, varying to indicate whether or not the item
+ has subitems, and if so, whether or not the item is expanded.
+
+- cue area between the bullet-icon and the start of the body headline,
+ for item numbering, encryption indicator, and distinctive bullets.
+
+The bullet-icon and guide line graphics provide keybindings and mouse
+bindings for easy outline navigation and exposure control, extending
+outline hot-spot navigation (see `allout-mode').
\(fn &optional ARG)" t nil)
;;;***
;;;### (autoloads (ange-ftp-hook-function ange-ftp-reread-dir) "ange-ftp"
-;;;;;; "net/ange-ftp.el" (19752 41642))
+;;;;;; "net/ange-ftp.el" (19845 45374))
;;; Generated autoloads from net/ange-ftp.el
(defalias 'ange-ftp-re-read-dir 'ange-ftp-reread-dir)
@@ -816,14 +918,14 @@ directory, so that Emacs will know its current contents.
\(fn &optional DIR)" t nil)
(autoload 'ange-ftp-hook-function "ange-ftp" "\
-Not documented
+
\(fn OPERATION &rest ARGS)" nil nil)
;;;***
;;;### (autoloads (animate-birthday-present animate-sequence animate-string)
-;;;;;; "animate" "play/animate.el" (19752 41642))
+;;;;;; "animate" "play/animate.el" (19845 45374))
;;; Generated autoloads from play/animate.el
(autoload 'animate-string "animate" "\
@@ -851,7 +953,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" (19752 41642))
+;;;;;; "ansi-color" "ansi-color.el" (19854 41422))
;;; Generated autoloads from ansi-color.el
(autoload 'ansi-color-for-comint-mode-on "ansi-color" "\
@@ -877,7 +979,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" (19752 41642))
+;;;;;; "antlr-mode" "progmodes/antlr-mode.el" (19890 42850))
;;; Generated autoloads from progmodes/antlr-mode.el
(autoload 'antlr-show-makefile-rules "antlr-mode" "\
@@ -901,7 +1003,6 @@ commentary with value `antlr-help-unknown-file-text' is added. The
(autoload 'antlr-mode "antlr-mode" "\
Major mode for editing ANTLR grammar files.
-\\{antlr-mode-map}
\(fn)" t nil)
@@ -913,8 +1014,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" (19752 41642))
+;;;### (autoloads (appt-activate appt-add) "appt" "calendar/appt.el"
+;;;;;; (19885 24894))
;;; Generated autoloads from calendar/appt.el
(autoload 'appt-add "appt" "\
@@ -926,26 +1027,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 +1038,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" (19752 41642))
+;;;;;; apropos-read-pattern) "apropos" "apropos.el" (19891 63700))
;;; Generated autoloads from apropos.el
(autoload 'apropos-read-pattern "apropos" "\
@@ -1060,8 +1141,8 @@ Returns list of symbols and documentation found.
;;;***
-;;;### (autoloads (archive-mode) "arc-mode" "arc-mode.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (archive-mode) "arc-mode" "arc-mode.el" (19886
+;;;;;; 45771))
;;; Generated autoloads from arc-mode.el
(autoload 'archive-mode "arc-mode" "\
@@ -1081,7 +1162,7 @@ archive.
;;;***
-;;;### (autoloads (array-mode) "array" "array.el" (19752 41642))
+;;;### (autoloads (array-mode) "array" "array.el" (19845 45374))
;;; Generated autoloads from array.el
(autoload 'array-mode "array" "\
@@ -1152,8 +1233,8 @@ Entering array mode calls the function `array-mode-hook'.
;;;***
-;;;### (autoloads (artist-mode) "artist" "textmodes/artist.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (artist-mode) "artist" "textmodes/artist.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from textmodes/artist.el
(autoload 'artist-mode "artist" "\
@@ -1359,8 +1440,8 @@ Keymap summary
;;;***
-;;;### (autoloads (asm-mode) "asm-mode" "progmodes/asm-mode.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (asm-mode) "asm-mode" "progmodes/asm-mode.el" (19890
+;;;;;; 42850))
;;; Generated autoloads from progmodes/asm-mode.el
(autoload 'asm-mode "asm-mode" "\
@@ -1387,8 +1468,21 @@ Special commands:
;;;***
+;;;### (autoloads (auth-source-cache-expiry) "auth-source" "gnus/auth-source.el"
+;;;;;; (19845 45374))
+;;; Generated autoloads from gnus/auth-source.el
+
+(defvar auth-source-cache-expiry 7200 "\
+How many seconds passwords are cached, or nil to disable
+expiring. Overrides `password-cache-expiry' through a
+let-binding.")
+
+(custom-autoload 'auth-source-cache-expiry "auth-source" t)
+
+;;;***
+
;;;### (autoloads (autoarg-kp-mode autoarg-mode) "autoarg" "autoarg.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from autoarg.el
(defvar autoarg-mode nil "\
@@ -1442,7 +1536,7 @@ etc. to supply digit arguments.
;;;***
;;;### (autoloads (autoconf-mode) "autoconf" "progmodes/autoconf.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from progmodes/autoconf.el
(autoload 'autoconf-mode "autoconf" "\
@@ -1453,7 +1547,7 @@ Major mode for editing Autoconf configure.in files.
;;;***
;;;### (autoloads (auto-insert-mode define-auto-insert auto-insert)
-;;;;;; "autoinsert" "autoinsert.el" (19752 41642))
+;;;;;; "autoinsert" "autoinsert.el" (19845 45374))
;;; Generated autoloads from autoinsert.el
(autoload 'auto-insert "autoinsert" "\
@@ -1492,7 +1586,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"
-;;;;;; (19752 41642))
+;;;;;; (19863 8742))
;;; Generated autoloads from emacs-lisp/autoload.el
(put 'generated-autoload-file 'safe-local-variable 'stringp)
@@ -1531,7 +1625,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" (19752 41642))
+;;;;;; "autorevert" "autorevert.el" (19878 51661))
;;; Generated autoloads from autorevert.el
(autoload 'auto-revert-mode "autorevert" "\
@@ -1612,11 +1706,11 @@ specifies in the mode line.
;;;***
;;;### (autoloads (mouse-avoidance-mode mouse-avoidance-mode) "avoid"
-;;;;;; "avoid.el" (19752 41642))
+;;;;;; "avoid.el" (19845 45374))
;;; Generated autoloads from avoid.el
(defvar mouse-avoidance-mode nil "\
-Activate mouse avoidance mode.
+Activate Mouse Avoidance mode.
See function `mouse-avoidance-mode' for possible values.
Setting this variable directly does not take effect;
use either \\[customize] or the function `mouse-avoidance-mode'.")
@@ -1624,7 +1718,7 @@ use either \\[customize] or the function `mouse-avoidance-mode'.")
(custom-autoload 'mouse-avoidance-mode "avoid" nil)
(autoload 'mouse-avoidance-mode "avoid" "\
-Set cursor avoidance mode to MODE.
+Set Mouse Avoidance mode to MODE.
MODE should be one of the symbols `banish', `exile', `jump', `animate',
`cat-and-mouse', `proteus', or `none'.
@@ -1644,7 +1738,7 @@ Effects of the different modes:
Whenever the mouse is moved, the frame is also raised.
-\(see `mouse-avoidance-threshold' for definition of \"too close\",
+\(See `mouse-avoidance-threshold' for definition of \"too close\",
and `mouse-avoidance-nudge-dist' and `mouse-avoidance-nudge-var' for
definition of \"random distance\".)
@@ -1653,7 +1747,7 @@ definition of \"random distance\".)
;;;***
;;;### (autoloads (display-battery-mode battery) "battery" "battery.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from battery.el
(put 'battery-mode-line-string 'risky-local-variable t)
@@ -1685,7 +1779,7 @@ seconds.
;;;***
;;;### (autoloads (benchmark benchmark-run-compiled benchmark-run)
-;;;;;; "benchmark" "emacs-lisp/benchmark.el" (19752 41642))
+;;;;;; "benchmark" "emacs-lisp/benchmark.el" (19845 45374))
;;; Generated autoloads from emacs-lisp/benchmark.el
(autoload 'benchmark-run "benchmark" "\
@@ -1718,7 +1812,7 @@ For non-interactive use see also `benchmark-run' and
;;;***
;;;### (autoloads (bibtex-search-entry bibtex-mode bibtex-initialize)
-;;;;;; "bibtex" "textmodes/bibtex.el" (19752 41642))
+;;;;;; "bibtex" "textmodes/bibtex.el" (19845 45374))
;;; Generated autoloads from textmodes/bibtex.el
(autoload 'bibtex-initialize "bibtex" "\
@@ -1805,9 +1899,8 @@ mode is not `bibtex-mode', START is nil, and DISPLAY is t.
;;;***
;;;### (autoloads (bibtex-style-mode) "bibtex-style" "textmodes/bibtex-style.el"
-;;;;;; (19752 41642))
+;;;;;; (19863 8742))
;;; 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 +1911,7 @@ Major mode for editing BibTeX style files.
;;;### (autoloads (binhex-decode-region binhex-decode-region-external
;;;;;; binhex-decode-region-internal) "binhex" "mail/binhex.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from mail/binhex.el
(defconst binhex-begin-line "^:...............................................................$")
@@ -1841,8 +1934,8 @@ Binhex decode region between START and END.
;;;***
-;;;### (autoloads (blackbox) "blackbox" "play/blackbox.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (blackbox) "blackbox" "play/blackbox.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from play/blackbox.el
(autoload 'blackbox "blackbox" "\
@@ -1965,7 +2058,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" (19752 41642))
+;;;;;; "bookmark.el" (19845 45374))
;;; Generated autoloads from bookmark.el
(define-key ctl-x-r-map "b" 'bookmark-jump)
(define-key ctl-x-r-map "m" 'bookmark-set)
@@ -2018,8 +2111,8 @@ if you wish to give the bookmark a new location, and `bookmark-jump'
will then jump to the new location, as well as recording it in place
of the old one in the permanent bookmark record.
-BOOKMARK may be a bookmark name (a string) or a bookmark record, but
-the latter is usually only used by programmatic callers.
+BOOKMARK is usually a bookmark name (a string). It can also be a
+bookmark record, but this is usually only done by programmatic callers.
If DISPLAY-FUNC is non-nil, it is a function to invoke to display the
bookmark. It defaults to `switch-to-buffer'. A typical value for
@@ -2033,57 +2126,52 @@ Jump to BOOKMARK in another window. See `bookmark-jump' for more.
\(fn BOOKMARK)" t nil)
(autoload 'bookmark-relocate "bookmark" "\
-Relocate BOOKMARK to another file (reading file name with minibuffer).
-BOOKMARK is a bookmark name (a string), not a bookmark record.
+Relocate BOOKMARK-NAME to another file, reading file name with minibuffer.
This makes an already existing bookmark point to that file, instead of
the one it used to point at. Useful when a file has been renamed
after a bookmark was set in it.
-\(fn BOOKMARK)" t nil)
+\(fn BOOKMARK-NAME)" t nil)
(autoload 'bookmark-insert-location "bookmark" "\
-Insert the name of the file associated with BOOKMARK.
-BOOKMARK is a bookmark name (a string), not a bookmark record.
+Insert the name of the file associated with BOOKMARK-NAME.
Optional second arg NO-HISTORY means don't record this in the
minibuffer history list `bookmark-history'.
-\(fn BOOKMARK &optional NO-HISTORY)" t nil)
+\(fn BOOKMARK-NAME &optional NO-HISTORY)" t nil)
(defalias 'bookmark-locate 'bookmark-insert-location)
(autoload 'bookmark-rename "bookmark" "\
-Change the name of OLD bookmark to NEW name.
-If called from keyboard, prompt for OLD and NEW. If called from
-menubar, select OLD from a menu and prompt for NEW.
+Change the name of OLD-NAME bookmark to NEW-NAME name.
+If called from keyboard, prompt for OLD-NAME and NEW-NAME.
+If called from menubar, select OLD-NAME from a menu and prompt for NEW-NAME.
-Both OLD and NEW are bookmark names (strings), never bookmark records.
-
-If called from Lisp, prompt for NEW if only OLD was passed as an
-argument. If called with two strings, then no prompting is done. You
-must pass at least OLD when calling from Lisp.
+If called from Lisp, prompt for NEW-NAME if only OLD-NAME was passed
+as an argument. If called with two strings, then no prompting is done.
+You must pass at least OLD-NAME when calling from Lisp.
While you are entering the new name, consecutive C-w's insert
consecutive words from the text of the buffer into the new bookmark
name.
-\(fn OLD &optional NEW)" t nil)
+\(fn OLD-NAME &optional NEW-NAME)" t nil)
(autoload 'bookmark-insert "bookmark" "\
-Insert the text of the file pointed to by bookmark BOOKMARK.
-BOOKMARK is a bookmark name (a string), not a bookmark record.
+Insert the text of the file pointed to by bookmark BOOKMARK-NAME.
+BOOKMARK-NAME is a bookmark name (a string), not a bookmark record.
You may have a problem using this function if the value of variable
`bookmark-alist' is nil. If that happens, you need to load in some
bookmarks. See help on function `bookmark-load' for more about
this.
-\(fn BOOKMARK)" t nil)
+\(fn BOOKMARK-NAME)" t nil)
(autoload 'bookmark-delete "bookmark" "\
-Delete BOOKMARK from the bookmark list.
-BOOKMARK is a bookmark name (a string), not a bookmark record.
+Delete BOOKMARK-NAME from the bookmark list.
Removes only the first instance of a bookmark with that name. If
there are one or more other bookmarks with the same name, they will
@@ -2092,7 +2180,7 @@ one most recently used in this file, if any).
Optional second arg BATCH means don't update the bookmark list buffer,
probably because we were called from there.
-\(fn BOOKMARK &optional BATCH)" t nil)
+\(fn BOOKMARK-NAME &optional BATCH)" t nil)
(autoload 'bookmark-write "bookmark" "\
Write bookmarks to a file (reading the file name with the minibuffer).
@@ -2167,12 +2255,11 @@ 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-mozilla browse-url-netscape browse-url-xdg-open
;;;;;; 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-browser-function) "browse-url" "net/browse-url.el"
-;;;;;; (19752 41642))
+;;;;;; (19870 57559))
;;; 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,21 +2275,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
-
-\(fn)" nil nil)
-
(autoload 'browse-url-of-file "browse-url" "\
Ask a WWW browser to display FILE.
Display the current buffer's file if FILE is nil or if called
@@ -2234,6 +2306,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)
@@ -2253,22 +2327,10 @@ to use.
\(fn EVENT)" t nil)
-(autoload 'browse-url-default-browser "browse-url" "\
-Find a suitable browser and ask it to load URL.
-Default to the URL around or before point.
-
-When called interactively, if variable `browse-url-new-window-flag' is
-non-nil, load the document in a new window, if possible, otherwise use
-a random existing one. A non-nil interactive prefix argument reverses
-the effect of `browse-url-new-window-flag'.
-
-When called non-interactively, optional second argument NEW-WINDOW is
-used instead of `browse-url-new-window-flag'.
+(autoload 'browse-url-xdg-open "browse-url" "\
-The order attempted is gnome-moz-remote, Mozilla, Firefox,
-Galeon, Konqueror, Netscape, Mosaic, Lynx in an xterm, and then W3.
-\(fn URL &rest ARGS)" nil nil)
+\(fn URL &optional NEW-WINDOW)" t nil)
(autoload 'browse-url-netscape "browse-url" "\
Ask the Netscape WWW browser to load URL.
@@ -2502,8 +2564,8 @@ from `browse-url-elinks-wrapper'.
;;;***
-;;;### (autoloads (snarf-bruces bruce) "bruce" "play/bruce.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (snarf-bruces bruce) "bruce" "play/bruce.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from play/bruce.el
(autoload 'bruce "bruce" "\
@@ -2519,7 +2581,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" (19752 41642))
+;;;;;; "bs" "bs.el" (19870 57559))
;;; Generated autoloads from bs.el
(autoload 'bs-cycle-next "bs" "\
@@ -2559,7 +2621,7 @@ name of buffer configuration.
;;;***
-;;;### (autoloads (bubbles) "bubbles" "play/bubbles.el" (19752 41642))
+;;;### (autoloads (bubbles) "bubbles" "play/bubbles.el" (19889 21967))
;;; Generated autoloads from play/bubbles.el
(autoload 'bubbles "bubbles" "\
@@ -2581,10 +2643,10 @@ columns on its right towards the left.
;;;***
;;;### (autoloads (bug-reference-prog-mode bug-reference-mode) "bug-reference"
-;;;;;; "progmodes/bug-reference.el" (19752 41642))
+;;;;;; "progmodes/bug-reference.el" (19890 42850))
;;; 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.
@@ -2602,7 +2664,7 @@ Like `bug-reference-mode', but only buttonize in comments and strings.
;;;;;; 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)
-;;;;;; "bytecomp" "emacs-lisp/bytecomp.el" (19800 50267))
+;;;;;; "bytecomp" "emacs-lisp/bytecomp.el" (19881 27850))
;;; 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)
@@ -2635,31 +2697,31 @@ Files in subdirectories of DIRECTORY are processed also.
\(fn DIRECTORY)" t nil)
(autoload 'byte-recompile-directory "bytecomp" "\
-Recompile every `.el' file in BYTECOMP-DIRECTORY that needs recompilation.
+Recompile every `.el' file in DIRECTORY that needs recompilation.
This happens when a `.elc' file exists but is older than the `.el' file.
-Files in subdirectories of BYTECOMP-DIRECTORY are processed also.
+Files in subdirectories of DIRECTORY are processed also.
If the `.elc' file does not exist, normally this function *does not*
compile the corresponding `.el' file. However, if the prefix argument
-BYTECOMP-ARG is 0, that means do compile all those files. A nonzero
-BYTECOMP-ARG means ask the user, for each such `.el' file, whether to
-compile it. A nonzero BYTECOMP-ARG also means ask about each subdirectory
+ARG is 0, that means do compile all those files. A nonzero
+ARG means ask the user, for each such `.el' file, whether to
+compile it. A nonzero ARG also means ask about each subdirectory
before scanning it.
-If the third argument BYTECOMP-FORCE is non-nil, recompile every `.el' file
+If the third argument FORCE is non-nil, recompile every `.el' file
that already has a `.elc' file.
-\(fn BYTECOMP-DIRECTORY &optional BYTECOMP-ARG BYTECOMP-FORCE)" t nil)
+\(fn DIRECTORY &optional ARG FORCE)" t nil)
(put 'no-byte-compile 'safe-local-variable 'booleanp)
(autoload 'byte-compile-file "bytecomp" "\
-Compile a file of Lisp code named BYTECOMP-FILENAME into a file of byte code.
-The output file's name is generated by passing BYTECOMP-FILENAME to the
+Compile a file of Lisp code named FILENAME into a file of byte code.
+The output file's name is generated by passing FILENAME to the
function `byte-compile-dest-file' (which see).
With prefix arg (noninteractively: 2nd arg), LOAD the file after compiling.
The value is non-nil if there were no errors, nil if errors.
-\(fn BYTECOMP-FILENAME &optional LOAD)" t nil)
+\(fn FILENAME &optional LOAD)" t nil)
(autoload 'compile-defun "bytecomp" "\
Compile and evaluate the current top-level form.
@@ -2722,8 +2784,8 @@ and corresponding effects.
;;;***
-;;;### (autoloads nil "cal-china" "calendar/cal-china.el" (19752
-;;;;;; 41642))
+;;;### (autoloads nil "cal-china" "calendar/cal-china.el" (19885
+;;;;;; 24894))
;;; Generated autoloads from calendar/cal-china.el
(put 'calendar-chinese-time-zone 'risky-local-variable t)
@@ -2732,7 +2794,7 @@ and corresponding effects.
;;;***
-;;;### (autoloads nil "cal-dst" "calendar/cal-dst.el" (19752 41642))
+;;;### (autoloads nil "cal-dst" "calendar/cal-dst.el" (19885 24894))
;;; Generated autoloads from calendar/cal-dst.el
(put 'calendar-daylight-savings-starts 'risky-local-variable t)
@@ -2744,7 +2806,7 @@ and corresponding effects.
;;;***
;;;### (autoloads (calendar-hebrew-list-yahrzeits) "cal-hebrew" "calendar/cal-hebrew.el"
-;;;;;; (19752 41642))
+;;;;;; (19885 24894))
;;; Generated autoloads from calendar/cal-hebrew.el
(autoload 'calendar-hebrew-list-yahrzeits "cal-hebrew" "\
@@ -2760,8 +2822,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" (19752
-;;;;;; 41642))
+;;;;;; full-calc calc calc-dispatch) "calc" "calc/calc.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from calc/calc.el
(define-key ctl-x-map "*" 'calc-dispatch)
@@ -2841,10 +2903,23 @@ See Info node `(calc)Defining Functions'.
\(fn FUNC ARGS &rest BODY)" nil (quote macro))
+(put 'defmath 'doc-string-elt '3)
+
+;;;***
+
+;;;### (autoloads (calc-undo) "calc-undo" "calc/calc-undo.el" (19845
+;;;;;; 45374))
+;;; Generated autoloads from calc/calc-undo.el
+
+(autoload 'calc-undo "calc-undo" "\
+
+
+\(fn N)" t nil)
+
;;;***
-;;;### (autoloads (calculator) "calculator" "calculator.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (calculator) "calculator" "calculator.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from calculator.el
(autoload 'calculator "calculator" "\
@@ -2855,8 +2930,8 @@ See the documentation for `calculator-mode' for more information.
;;;***
-;;;### (autoloads (calendar) "calendar" "calendar/calendar.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (calendar) "calendar" "calendar/calendar.el" (19885
+;;;;;; 24894))
;;; Generated autoloads from calendar/calendar.el
(autoload 'calendar "calendar" "\
@@ -2900,7 +2975,7 @@ This function is suitable for execution in a .emacs file.
;;;***
;;;### (autoloads (canlock-verify canlock-insert-header) "canlock"
-;;;;;; "gnus/canlock.el" (19752 41642))
+;;;;;; "gnus/canlock.el" (19845 45374))
;;; Generated autoloads from gnus/canlock.el
(autoload 'canlock-insert-header "canlock" "\
@@ -2918,7 +2993,7 @@ it fails.
;;;***
;;;### (autoloads (capitalized-words-mode) "cap-words" "progmodes/cap-words.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from progmodes/cap-words.el
(autoload 'capitalized-words-mode "cap-words" "\
@@ -2953,15 +3028,15 @@ Obsoletes `c-forward-into-nomenclature'.
;;;***
-;;;### (autoloads nil "cc-compat" "progmodes/cc-compat.el" (19752
-;;;;;; 41642))
+;;;### (autoloads nil "cc-compat" "progmodes/cc-compat.el" (19845
+;;;;;; 45374))
;;; 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"
-;;;;;; (19800 14993))
+;;;;;; (19893 19022))
;;; Generated autoloads from progmodes/cc-engine.el
(autoload 'c-guess-basic-syntax "cc-engine" "\
@@ -2973,7 +3048,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from progmodes/cc-mode.el
(autoload 'c-initialize-cc-mode "cc-mode" "\
@@ -3133,7 +3208,7 @@ Key bindings:
;;;***
;;;### (autoloads (c-set-offset c-add-style c-set-style) "cc-styles"
-;;;;;; "progmodes/cc-styles.el" (19752 41642))
+;;;;;; "progmodes/cc-styles.el" (19845 45374))
;;; Generated autoloads from progmodes/cc-styles.el
(autoload 'c-set-style "cc-styles" "\
@@ -3184,7 +3259,7 @@ and exists only for compatibility reasons.
;;;***
-;;;### (autoloads nil "cc-vars" "progmodes/cc-vars.el" (19752 41642))
+;;;### (autoloads nil "cc-vars" "progmodes/cc-vars.el" (19845 45374))
;;; Generated autoloads from progmodes/cc-vars.el
(put 'c-basic-offset 'safe-local-variable 'integerp)
(put 'c-backslash-column 'safe-local-variable 'integerp)
@@ -3194,7 +3269,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from international/ccl.el
(autoload 'ccl-compile "ccl" "\
@@ -3433,6 +3508,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
@@ -3452,8 +3529,23 @@ See the documentation of `define-ccl-program' for the detail of CCL program.
;;;***
+;;;### (autoloads (cconv-closure-convert) "cconv" "emacs-lisp/cconv.el"
+;;;;;; (19869 36706))
+;;; Generated autoloads from emacs-lisp/cconv.el
+
+(autoload 'cconv-closure-convert "cconv" "\
+Main entry point for closure conversion.
+-- FORM is a piece of Elisp code after macroexpansion.
+-- TOPLEVEL(optional) is a boolean variable, true if we are at the root of AST
+
+Returns a form where all lambdas don't have any free variables.
+
+\(fn FORM)" nil nil)
+
+;;;***
+
;;;### (autoloads (cfengine-mode) "cfengine" "progmodes/cfengine.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from progmodes/cfengine.el
(autoload 'cfengine-mode "cfengine" "\
@@ -3468,7 +3560,7 @@ to the action header.
;;;***
;;;### (autoloads (check-declare-directory check-declare-file) "check-declare"
-;;;;;; "emacs-lisp/check-declare.el" (19752 41642))
+;;;;;; "emacs-lisp/check-declare.el" (19845 45374))
;;; Generated autoloads from emacs-lisp/check-declare.el
(autoload 'check-declare-file "check-declare" "\
@@ -3493,7 +3585,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" (19798 54314))
+;;;;;; "checkdoc" "emacs-lisp/checkdoc.el" (19845 45374))
;;; 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)
@@ -3502,7 +3594,7 @@ Returns non-nil if any false statements are found.
(put 'checkdoc-symbol-words 'safe-local-variable 'checkdoc-list-of-strings-p)
(autoload 'checkdoc-list-of-strings-p "checkdoc" "\
-Not documented
+
\(fn OBJ)" nil nil)
@@ -3688,7 +3780,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" (19752 41642))
+;;;;;; "language/china-util.el" (19845 45374))
;;; Generated autoloads from language/china-util.el
(autoload 'decode-hz-region "china-util" "\
@@ -3714,19 +3806,19 @@ Encode the text in the current buffer to HZ.
\(fn)" t nil)
(autoload 'post-read-decode-hz "china-util" "\
-Not documented
+
\(fn LEN)" nil nil)
(autoload 'pre-write-encode-hz "china-util" "\
-Not documented
+
\(fn FROM TO)" nil nil)
;;;***
;;;### (autoloads (command-history list-command-history repeat-matching-complex-command)
-;;;;;; "chistory" "chistory.el" (19752 41642))
+;;;;;; "chistory" "chistory.el" (19845 45374))
;;; Generated autoloads from chistory.el
(autoload 'repeat-matching-complex-command "chistory" "\
@@ -3765,7 +3857,7 @@ and runs the normal hook `command-history-hook'.
;;;***
-;;;### (autoloads nil "cl" "emacs-lisp/cl.el" (19752 41642))
+;;;### (autoloads nil "cl" "emacs-lisp/cl.el" (19863 8742))
;;; Generated autoloads from emacs-lisp/cl.el
(defvar custom-print-functions nil "\
@@ -3781,7 +3873,7 @@ a future Emacs interpreter will be able to use it.")
;;;***
;;;### (autoloads (common-lisp-indent-function) "cl-indent" "emacs-lisp/cl-indent.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from emacs-lisp/cl-indent.el
(autoload 'common-lisp-indent-function "cl-indent" "\
@@ -3860,7 +3952,7 @@ For example, the function `case' has an indent property
;;;***
;;;### (autoloads (c-macro-expand) "cmacexp" "progmodes/cmacexp.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from progmodes/cmacexp.el
(autoload 'c-macro-expand "cmacexp" "\
@@ -3880,8 +3972,8 @@ For use inside Lisp programs, see also `c-macro-expansion'.
;;;***
-;;;### (autoloads (run-scheme) "cmuscheme" "cmuscheme.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (run-scheme) "cmuscheme" "cmuscheme.el" (19886
+;;;;;; 45771))
;;; Generated autoloads from cmuscheme.el
(autoload 'run-scheme "cmuscheme" "\
@@ -3902,10 +3994,29 @@ is run).
;;;***
+;;;### (autoloads (color-name-to-rgb) "color" "color.el" (19845 45374))
+;;; Generated autoloads from color.el
+
+(autoload 'color-name-to-rgb "color" "\
+Convert COLOR string to a list of normalized RGB components.
+COLOR should be a color name (e.g. \"white\") or an RGB triplet
+string (e.g. \"#ff12ec\").
+
+Normally the return value is a list of three floating-point
+numbers, (RED GREEN BLUE), each between 0.0 and 1.0 inclusive.
+
+Optional arg FRAME specifies the frame where the color is to be
+displayed. If FRAME is omitted or nil, use the selected frame.
+If FRAME cannot display COLOR, return nil.
+
+\(fn COLOR &optional FRAME)" nil nil)
+
+;;;***
+
;;;### (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"
-;;;;;; (19776 18606))
+;;;;;; (19888 1100))
;;; Generated autoloads from comint.el
(defvar comint-output-filter-functions '(comint-postoutput-scroll-to-bottom comint-watch-for-password-prompt) "\
@@ -3921,8 +4032,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.
@@ -4001,9 +4110,9 @@ REGEXP-GROUP is the regular expression group in REGEXP to use.
;;;***
-;;;### (autoloads (compare-windows) "compare-w" "compare-w.el" (19752
-;;;;;; 41642))
-;;; Generated autoloads from compare-w.el
+;;;### (autoloads (compare-windows) "compare-w" "vc/compare-w.el"
+;;;;;; (19845 45374))
+;;; Generated autoloads from vc/compare-w.el
(autoload 'compare-windows "compare-w" "\
Compare text in current window with text in next window.
@@ -4039,8 +4148,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" (19770
-;;;;;; 11773))
+;;;;;; compilation-mode-hook) "compile" "progmodes/compile.el" (19890
+;;;;;; 42850))
;;; Generated autoloads from progmodes/compile.el
(defvar compilation-mode-hook nil "\
@@ -4067,9 +4176,7 @@ Number of lines in a compilation window. If nil, use Emacs default.")
*Function to call to customize the compilation process.
This function is called immediately before the compilation process is
started. It can be used to set any variables or functions that are used
-while processing the output of the compilation process. The function
-is called with variables `compilation-buffer' and `compilation-window'
-bound to the compilation buffer and window, respectively.")
+while processing the output of the compilation process.")
(defvar compilation-buffer-name-function nil "\
Function to compute the name of a compilation buffer.
@@ -4213,54 +4320,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"
-;;;;;; (19752 41642))
-;;; 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"
-;;;;;; (19752 41642))
+;;;;;; (19886 45771))
;;; Generated autoloads from completion.el
(defvar dynamic-completion-mode nil "\
@@ -4282,7 +4345,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from textmodes/conf-mode.el
(autoload 'conf-mode "conf-mode" "\
@@ -4438,7 +4501,7 @@ For details see `conf-mode'. Example:
;;;***
;;;### (autoloads (shuffle-vector cookie-snarf cookie-insert cookie)
-;;;;;; "cookie1" "play/cookie1.el" (19752 41642))
+;;;;;; "cookie1" "play/cookie1.el" (19845 45374))
;;; Generated autoloads from play/cookie1.el
(autoload 'cookie "cookie1" "\
@@ -4470,9 +4533,12 @@ 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" (19752
-;;;;;; 41642))
+;;;;;; copyright-update) "copyright" "emacs-lisp/copyright.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from emacs-lisp/copyright.el
+(put 'copyright-at-end-flag 'safe-local-variable 'booleanp)
+(put 'copyright-names-regexp 'safe-local-variable 'stringp)
+(put 'copyright-year-ranges 'safe-local-variable 'booleanp)
(autoload 'copyright-update "copyright" "\
Update copyright notice to indicate the current year.
@@ -4488,6 +4554,8 @@ interactively.
(autoload 'copyright-fix-years "copyright" "\
Convert 2 digit years to 4 digit years.
Uses heuristic: year >= 50 means 19xx, < 50 means 20xx.
+If `copyright-year-ranges' (which see) is non-nil, also
+independently replaces consecutive years with a range.
\(fn)" t nil)
@@ -4498,13 +4566,14 @@ Insert a copyright by $ORGANIZATION notice at cursor.
(autoload 'copyright-update-directory "copyright" "\
Update copyright notice for all files in DIRECTORY matching MATCH.
+If FIX is non-nil, run `copyright-fix-years' instead.
-\(fn DIRECTORY MATCH)" t nil)
+\(fn DIRECTORY MATCH &optional FIX)" t nil)
;;;***
;;;### (autoloads (cperl-perldoc-at-point cperl-perldoc cperl-mode)
-;;;;;; "cperl-mode" "progmodes/cperl-mode.el" (19813 16320))
+;;;;;; "cperl-mode" "progmodes/cperl-mode.el" (19845 45374))
;;; Generated autoloads from progmodes/cperl-mode.el
(put 'cperl-indent-level 'safe-local-variable 'integerp)
(put 'cperl-brace-offset 'safe-local-variable 'integerp)
@@ -4703,7 +4772,7 @@ Run a `perldoc' on the word around point.
;;;***
;;;### (autoloads (cpp-parse-edit cpp-highlight-buffer) "cpp" "progmodes/cpp.el"
-;;;;;; (19752 41642))
+;;;;;; (19890 42850))
;;; Generated autoloads from progmodes/cpp.el
(autoload 'cpp-highlight-buffer "cpp" "\
@@ -4722,7 +4791,7 @@ Edit display information for cpp conditionals.
;;;***
;;;### (autoloads (crisp-mode crisp-mode) "crisp" "emulation/crisp.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from emulation/crisp.el
(defvar crisp-mode nil "\
@@ -4746,7 +4815,7 @@ With ARG, turn CRiSP mode on if ARG is positive, off otherwise.
;;;***
;;;### (autoloads (completing-read-multiple) "crm" "emacs-lisp/crm.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from emacs-lisp/crm.el
(autoload 'completing-read-multiple "crm" "\
@@ -4781,10 +4850,9 @@ INHERIT-INPUT-METHOD.
;;;***
-;;;### (autoloads (css-mode) "css-mode" "textmodes/css-mode.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (css-mode) "css-mode" "textmodes/css-mode.el" (19863
+;;;;;; 8742))
;;; 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.
@@ -4794,7 +4862,7 @@ Major mode to edit Cascading Style Sheets.
;;;***
;;;### (autoloads (cua-selection-mode cua-mode) "cua-base" "emulation/cua-base.el"
-;;;;;; (19798 54314))
+;;;;;; (19894 39890))
;;; Generated autoloads from emulation/cua-base.el
(defvar cua-mode nil "\
@@ -4853,7 +4921,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"
-;;;;;; (19752 41642))
+;;;;;; (19886 45771))
;;; Generated autoloads from cus-edit.el
(defvar custom-browse-sort-alphabetically nil "\
@@ -4861,8 +4929,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)
@@ -5038,15 +5106,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.
@@ -5150,20 +5223,42 @@ The format is suitable for use with `easy-menu-define'.
;;;***
-;;;### (autoloads (customize-create-theme) "cus-theme" "cus-theme.el"
-;;;;;; (19752 41642))
+;;;### (autoloads (customize-themes describe-theme custom-theme-visit-theme
+;;;;;; customize-create-theme) "cus-theme" "cus-theme.el" (19886
+;;;;;; 45771))
;;; 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 'custom-theme-visit-theme "cus-theme" "\
+Set up a Custom buffer to edit custom theme THEME.
+
+\(fn THEME)" 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"
-;;;;;; (19752 41642))
-;;; Generated autoloads from cvs-status.el
+;;;### (autoloads (cvs-status-mode) "cvs-status" "vc/cvs-status.el"
+;;;;;; (19863 8742))
+;;; Generated autoloads from vc/cvs-status.el
(autoload 'cvs-status-mode "cvs-status" "\
Mode used for cvs status output.
@@ -5173,7 +5268,7 @@ Mode used for cvs status output.
;;;***
;;;### (autoloads (global-cwarn-mode turn-on-cwarn-mode cwarn-mode)
-;;;;;; "cwarn" "progmodes/cwarn.el" (19752 41642))
+;;;;;; "cwarn" "progmodes/cwarn.el" (19845 45374))
;;; Generated autoloads from progmodes/cwarn.el
(autoload 'cwarn-mode "cwarn" "\
@@ -5220,7 +5315,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from language/cyril-util.el
(autoload 'cyrillic-encode-koi8-r-char "cyril-util" "\
@@ -5249,7 +5344,7 @@ If the argument is nil, we return the display table to its standard state.
;;;***
;;;### (autoloads (dabbrev-expand dabbrev-completion) "dabbrev" "dabbrev.el"
-;;;;;; (19752 41642))
+;;;;;; (19886 45771))
;;; Generated autoloads from dabbrev.el
(put 'dabbrev-case-fold-search 'risky-local-variable t)
(put 'dabbrev-case-replace 'risky-local-variable t)
@@ -5296,7 +5391,7 @@ See also `dabbrev-abbrev-char-regexp' and \\[dabbrev-completion].
;;;***
;;;### (autoloads (data-debug-new-buffer) "data-debug" "cedet/data-debug.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from cedet/data-debug.el
(autoload 'data-debug-new-buffer "data-debug" "\
@@ -5306,8 +5401,8 @@ Create a new data-debug buffer with NAME.
;;;***
-;;;### (autoloads (dbus-handle-event) "dbus" "net/dbus.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (dbus-handle-event) "dbus" "net/dbus.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from net/dbus.el
(autoload 'dbus-handle-event "dbus" "\
@@ -5320,8 +5415,8 @@ If the HANDLER returns a `dbus-error', it is propagated as return message.
;;;***
-;;;### (autoloads (dcl-mode) "dcl-mode" "progmodes/dcl-mode.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (dcl-mode) "dcl-mode" "progmodes/dcl-mode.el" (19890
+;;;;;; 42850))
;;; Generated autoloads from progmodes/dcl-mode.el
(autoload 'dcl-mode "dcl-mode" "\
@@ -5448,7 +5543,7 @@ There is some minimal font-lock support (see vars
;;;***
;;;### (autoloads (cancel-debug-on-entry debug-on-entry debug) "debug"
-;;;;;; "emacs-lisp/debug.el" (19752 41642))
+;;;;;; "emacs-lisp/debug.el" (19845 45374))
;;; Generated autoloads from emacs-lisp/debug.el
(setq debugger 'debug)
@@ -5492,7 +5587,7 @@ To specify a nil argument interactively, exit with an empty minibuffer.
;;;***
;;;### (autoloads (decipher-mode decipher) "decipher" "play/decipher.el"
-;;;;;; (19752 41642))
+;;;;;; (19889 21967))
;;; Generated autoloads from play/decipher.el
(autoload 'decipher "decipher" "\
@@ -5521,8 +5616,8 @@ The most useful commands are:
;;;***
;;;### (autoloads (delimit-columns-rectangle delimit-columns-region
-;;;;;; delimit-columns-customize) "delim-col" "delim-col.el" (19752
-;;;;;; 41642))
+;;;;;; delimit-columns-customize) "delim-col" "delim-col.el" (19886
+;;;;;; 45771))
;;; Generated autoloads from delim-col.el
(autoload 'delimit-columns-customize "delim-col" "\
@@ -5546,8 +5641,8 @@ START and END delimits the corners of text rectangle.
;;;***
-;;;### (autoloads (delphi-mode) "delphi" "progmodes/delphi.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (delphi-mode) "delphi" "progmodes/delphi.el" (19890
+;;;;;; 42850))
;;; Generated autoloads from progmodes/delphi.el
(autoload 'delphi-mode "delphi" "\
@@ -5558,7 +5653,7 @@ Major mode for editing Delphi code. \\<delphi-mode-map>
\\[delphi-fill-comment] - Fill the current comment.
\\[delphi-new-comment-line] - If in a // comment, do a new comment line.
-M-x indent-region also works for indenting a whole region.
+\\[indent-region] also works for indenting a whole region.
Customization:
@@ -5578,28 +5673,28 @@ Customization:
`delphi-search-path' (default .)
Directories to search when finding external units.
`delphi-verbose' (default nil)
- If true then delphi token processing progress is reported to the user.
+ If true then Delphi token processing progress is reported to the user.
Coloring:
`delphi-comment-face' (default font-lock-comment-face)
- Face used to color delphi comments.
+ Face used to color Delphi comments.
`delphi-string-face' (default font-lock-string-face)
- Face used to color delphi strings.
+ Face used to color Delphi strings.
`delphi-keyword-face' (default font-lock-keyword-face)
- Face used to color delphi keywords.
+ Face used to color Delphi keywords.
`delphi-other-face' (default nil)
Face used to color everything else.
-Turning on Delphi mode calls the value of the variable delphi-mode-hook with
-no args, if that value is non-nil.
+Turning on Delphi mode calls the value of the variable `delphi-mode-hook'
+with no args, if that value is non-nil.
\(fn &optional SKIP-INITIAL-PARSING)" t nil)
;;;***
-;;;### (autoloads (delete-selection-mode) "delsel" "delsel.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (delete-selection-mode) "delsel" "delsel.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from delsel.el
(defalias 'pending-delete-mode 'delete-selection-mode)
@@ -5628,7 +5723,7 @@ any selection.
;;;***
;;;### (autoloads (derived-mode-init-mode-variables define-derived-mode)
-;;;;;; "derived" "emacs-lisp/derived.el" (19752 41642))
+;;;;;; "derived" "emacs-lisp/derived.el" (19849 29307))
;;; Generated autoloads from emacs-lisp/derived.el
(autoload 'define-derived-mode "derived" "\
@@ -5682,6 +5777,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
@@ -5693,7 +5790,7 @@ the first time the mode is used.
;;;***
;;;### (autoloads (describe-char describe-text-properties) "descr-text"
-;;;;;; "descr-text.el" (19752 41642))
+;;;;;; "descr-text.el" (19886 45771))
;;; Generated autoloads from descr-text.el
(autoload 'describe-text-properties "descr-text" "\
@@ -5721,7 +5818,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" (19752 41642))
+;;;;;; "desktop.el" (19886 45771))
;;; Generated autoloads from desktop.el
(defvar desktop-save-mode nil "\
@@ -5905,7 +6002,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" (19752 41642))
+;;;;;; "deuglify" "gnus/deuglify.el" (19845 45374))
;;; Generated autoloads from gnus/deuglify.el
(autoload 'gnus-article-outlook-unwrap-lines "deuglify" "\
@@ -5938,7 +6035,7 @@ Deuglify broken Outlook (Express) articles and redisplay.
;;;***
;;;### (autoloads (diary-mode diary-mail-entries diary) "diary-lib"
-;;;;;; "calendar/diary-lib.el" (19788 46601))
+;;;;;; "calendar/diary-lib.el" (19885 24894))
;;; Generated autoloads from calendar/diary-lib.el
(autoload 'diary "diary-lib" "\
@@ -5980,9 +6077,9 @@ Major mode for editing the diary file.
;;;***
-;;;### (autoloads (diff-backup diff diff-command diff-switches) "diff"
-;;;;;; "diff.el" (19752 41642))
-;;; Generated autoloads from diff.el
+;;;### (autoloads (diff-buffer-with-file diff-backup diff diff-command
+;;;;;; diff-switches) "diff" "vc/diff.el" (19845 45374))
+;;; Generated autoloads from vc/diff.el
(defvar diff-switches (purecopy "-c") "\
A string or list of strings specifying switches to be passed to diff.")
@@ -6016,11 +6113,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"
-;;;;;; (19752 41642))
-;;; Generated autoloads from diff-mode.el
+;;;### (autoloads (diff-minor-mode diff-mode) "diff-mode" "vc/diff-mode.el"
+;;;;;; (19863 8742))
+;;; Generated autoloads from vc/diff-mode.el
(autoload 'diff-mode "diff-mode" "\
Major mode for viewing/editing context diffs.
@@ -6047,7 +6150,7 @@ Minor mode for viewing/editing context diffs.
;;;***
-;;;### (autoloads (dig) "dig" "net/dig.el" (19752 41642))
+;;;### (autoloads (dig) "dig" "net/dig.el" (19845 45374))
;;; Generated autoloads from net/dig.el
(autoload 'dig "dig" "\
@@ -6058,9 +6161,8 @@ 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" (19772 35352))
+;;;### (autoloads (dired-mode dired-noselect dired-other-frame dired-other-window
+;;;;;; dired dired-listing-switches) "dired" "dired.el" (19886 46089))
;;; Generated autoloads from dired.el
(defvar dired-listing-switches (purecopy "-al") "\
@@ -6074,16 +6176,6 @@ 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"))) "\
-Name of chown command (usually `chown' or `/etc/chown').")
-
-(defvar dired-trivial-filenames (purecopy "^\\.\\.?$\\|^#") "\
-Regexp of files to skip when finding first file of a directory.
-A value of nil means move to the subdir line.
-A value of t means move to first file.")
-
-(custom-autoload 'dired-trivial-filenames "dired" t)
-
(defvar dired-directory nil "\
The directory name or wildcard spec that this dired directory lists.
Local to each dired buffer. May be a list, in which case the car is the
@@ -6125,18 +6217,6 @@ Like `dired' but returns the dired buffer as value, does not select it.
\(fn DIR-OR-LIST &optional SWITCHES)" nil nil)
-(defvar dired-auto-revert-buffer nil "\
-Automatically revert dired buffer on revisiting.
-If t, revisiting an existing dired buffer automatically reverts it.
-If its value is a function, call this function with the directory
-name as single argument and revert the buffer if it returns non-nil.
-Otherwise, a message offering to revert the changed dired buffer
-is displayed.
-Note that this is not the same as `auto-revert-mode' that
-periodically reverts at specified time intervals.")
-
-(custom-autoload 'dired-auto-revert-buffer "dired" t)
-
(autoload 'dired-mode "dired" "\
Mode for \"editing\" directory listings.
In Dired, you are \"editing\" a list of the files in a directory and
@@ -6205,7 +6285,7 @@ Keybindings:
;;;***
;;;### (autoloads (dirtrack dirtrack-mode) "dirtrack" "dirtrack.el"
-;;;;;; (19752 41642))
+;;;;;; (19886 45771))
;;; Generated autoloads from dirtrack.el
(autoload 'dirtrack-mode "dirtrack" "\
@@ -6231,8 +6311,8 @@ function `dirtrack-debug-mode' to turn on debugging output.
;;;***
-;;;### (autoloads (disassemble) "disass" "emacs-lisp/disass.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (disassemble) "disass" "emacs-lisp/disass.el" (19863
+;;;;;; 8742))
;;; Generated autoloads from emacs-lisp/disass.el
(autoload 'disassemble "disass" "\
@@ -6251,7 +6331,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" (19752 41642))
+;;;;;; "disp-table" "disp-table.el" (19845 45374))
;;; Generated autoloads from disp-table.el
(autoload 'make-display-table "disp-table" "\
@@ -6373,7 +6453,7 @@ in `.emacs'.
;;;***
;;;### (autoloads (dissociated-press) "dissociate" "play/dissociate.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from play/dissociate.el
(autoload 'dissociated-press "dissociate" "\
@@ -6389,7 +6469,7 @@ Default is 2.
;;;***
-;;;### (autoloads (dnd-protocol-alist) "dnd" "dnd.el" (19752 41642))
+;;;### (autoloads (dnd-protocol-alist) "dnd" "dnd.el" (19886 45771))
;;; 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)) "\
@@ -6410,7 +6490,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" (19752 41642))
+;;;;;; "textmodes/dns-mode.el" (19845 45374))
;;; Generated autoloads from textmodes/dns-mode.el
(autoload 'dns-mode "dns-mode" "\
@@ -6430,17 +6510,18 @@ 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" (19752 41642))
+;;;### (autoloads (doc-view-bookmark-jump doc-view-minor-mode doc-view-mode-maybe
+;;;;;; doc-view-mode doc-view-mode-p) "doc-view" "doc-view.el" (19872
+;;;;;; 12877))
;;; Generated autoloads from doc-view.el
(autoload 'doc-view-mode-p "doc-view" "\
-Return non-nil if image type TYPE is available for `doc-view'.
-Image types are symbols like `dvi', `postscript' or `pdf'.
+Return non-nil if document type TYPE is available for `doc-view'.
+Document types are symbols like `dvi', `ps', `pdf', or `odf' (any
+OpenDocument format).
\(fn TYPE)" nil nil)
@@ -6456,6 +6537,13 @@ toggle between displaying the document or editing it as text.
\(fn)" t nil)
+(autoload 'doc-view-mode-maybe "doc-view" "\
+Switch to `doc-view-mode' if possible.
+If the required external tools are not available, then fallback
+to the next best mode.
+
+\(fn)" nil nil)
+
(autoload 'doc-view-minor-mode "doc-view" "\
Toggle Doc view minor mode.
With arg, turn Doc view minor mode on if arg is positive, off otherwise.
@@ -6464,13 +6552,13 @@ See the command `doc-view-mode' for more information on this mode.
\(fn &optional ARG)" t nil)
(autoload 'doc-view-bookmark-jump "doc-view" "\
-Not documented
+
\(fn BMK)" nil nil)
;;;***
-;;;### (autoloads (doctor) "doctor" "play/doctor.el" (19752 41642))
+;;;### (autoloads (doctor) "doctor" "play/doctor.el" (19890 42850))
;;; Generated autoloads from play/doctor.el
(autoload 'doctor "doctor" "\
@@ -6480,7 +6568,7 @@ Switch to *doctor* buffer and start giving psychotherapy.
;;;***
-;;;### (autoloads (double-mode) "double" "double.el" (19752 41642))
+;;;### (autoloads (double-mode) "double" "double.el" (19845 45374))
;;; Generated autoloads from double.el
(autoload 'double-mode "double" "\
@@ -6495,7 +6583,7 @@ when pressed twice. See variable `double-map' for details.
;;;***
-;;;### (autoloads (dunnet) "dunnet" "play/dunnet.el" (19752 41642))
+;;;### (autoloads (dunnet) "dunnet" "play/dunnet.el" (19845 45374))
;;; Generated autoloads from play/dunnet.el
(autoload 'dunnet "dunnet" "\
@@ -6505,20 +6593,9 @@ Switch to *dungeon* buffer and start game.
;;;***
-;;;### (autoloads (gnus-earcon-display) "earcon" "gnus/earcon.el"
-;;;;;; (19752 41642))
-;;; 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" (19767 41074))
+;;;;;; "emacs-lisp/easy-mmode.el" (19845 45374))
;;; Generated autoloads from emacs-lisp/easy-mmode.el
(defalias 'easy-mmode-define-minor-mode 'define-minor-mode)
@@ -6554,6 +6631,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!\"
@@ -6622,12 +6705,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" (19752
-;;;;;; 41642))
+;;;;;; easy-menu-define) "easymenu" "emacs-lisp/easymenu.el" (19845
+;;;;;; 45374))
;;; 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.
@@ -6650,8 +6731,8 @@ expression has a non-nil value. `:included' is an alias for `:visible'.
:active ENABLE
-ENABLE is an expression; the menu is enabled for selection
-whenever this expression's value is non-nil.
+ENABLE is an expression; the menu is enabled for selection whenever
+this expression's value is non-nil. `:enable' is an alias for `:active'.
The rest of the elements in MENU, are menu items.
@@ -6688,8 +6769,8 @@ keyboard equivalent.
:active ENABLE
-ENABLE is an expression; the item is enabled for selection
-whenever this expression's value is non-nil.
+ENABLE is an expression; the item is enabled for selection whenever
+this expression's value is non-nil. `:enable' is an alias for `:active'.
:visible INCLUDE
@@ -6736,8 +6817,10 @@ 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
+
\(fn SYMBOL MAPS DOC MENU)" nil nil)
@@ -6777,7 +6860,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" (19752 41642))
+;;;;;; "progmodes/ebnf2ps.el" (19845 45374))
;;; Generated autoloads from progmodes/ebnf2ps.el
(autoload 'ebnf-customize "ebnf2ps" "\
@@ -7051,8 +7134,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" (19752
-;;;;;; 41642))
+;;;;;; ebrowse-tree-mode) "ebrowse" "progmodes/ebrowse.el" (19890
+;;;;;; 42850))
;;; Generated autoloads from progmodes/ebrowse.el
(autoload 'ebrowse-tree-mode "ebrowse" "\
@@ -7075,9 +7158,7 @@ Return a buffer containing a tree or nil if no tree found or canceled.
(autoload 'ebrowse-member-mode "ebrowse" "\
Major mode for Ebrowse member buffers.
-\\{ebrowse-member-mode-map}
-
-\(fn)" nil nil)
+\(fn)" t nil)
(autoload 'ebrowse-tags-view-declaration "ebrowse" "\
View declaration of member at point.
@@ -7203,7 +7284,7 @@ Display statistics for a class tree.
;;;***
;;;### (autoloads (electric-buffer-list) "ebuff-menu" "ebuff-menu.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from ebuff-menu.el
(autoload 'electric-buffer-list "ebuff-menu" "\
@@ -7228,7 +7309,7 @@ Run hooks in `electric-buffer-menu-mode-hook' on entry.
;;;***
;;;### (autoloads (Electric-command-history-redo-expression) "echistory"
-;;;;;; "echistory.el" (19752 41642))
+;;;;;; "echistory.el" (19886 45771))
;;; Generated autoloads from echistory.el
(autoload 'Electric-command-history-redo-expression "echistory" "\
@@ -7240,17 +7321,17 @@ With prefix arg NOCONFIRM, execute current line as-is without editing.
;;;***
;;;### (autoloads (ecomplete-setup) "ecomplete" "gnus/ecomplete.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from gnus/ecomplete.el
(autoload 'ecomplete-setup "ecomplete" "\
-Not documented
+
\(fn)" nil nil)
;;;***
-;;;### (autoloads (global-ede-mode) "ede" "cedet/ede.el" (19752 41642))
+;;;### (autoloads (global-ede-mode) "ede" "cedet/ede.el" (19845 45374))
;;; Generated autoloads from cedet/ede.el
(defvar global-ede-mode nil "\
@@ -7276,7 +7357,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" (19752 41642))
+;;;;;; "emacs-lisp/edebug.el" (19863 8742))
;;; Generated autoloads from emacs-lisp/edebug.el
(defvar edebug-all-defs nil "\
@@ -7349,8 +7430,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" (19752 41642))
-;;; Generated autoloads from ediff.el
+;;;;;; ediff-files3 ediff-files) "ediff" "vc/ediff.el" (19845 45374))
+;;; Generated autoloads from vc/ediff.el
(autoload 'ediff-files "ediff" "\
Run Ediff on a pair of files, FILE-A and FILE-B.
@@ -7580,20 +7661,20 @@ With optional NODE, goes to that node.
;;;***
-;;;### (autoloads (ediff-customize) "ediff-help" "ediff-help.el"
-;;;;;; (19752 41642))
-;;; Generated autoloads from ediff-help.el
+;;;### (autoloads (ediff-customize) "ediff-help" "vc/ediff-help.el"
+;;;;;; (19845 45374))
+;;; Generated autoloads from vc/ediff-help.el
(autoload 'ediff-customize "ediff-help" "\
-Not documented
+
\(fn)" t nil)
;;;***
-;;;### (autoloads (ediff-show-registry) "ediff-mult" "ediff-mult.el"
-;;;;;; (19798 54314))
-;;; Generated autoloads from ediff-mult.el
+;;;### (autoloads (ediff-show-registry) "ediff-mult" "vc/ediff-mult.el"
+;;;;;; (19845 45374))
+;;; Generated autoloads from vc/ediff-mult.el
(autoload 'ediff-show-registry "ediff-mult" "\
Display Ediff's registry.
@@ -7605,8 +7686,8 @@ Display Ediff's registry.
;;;***
;;;### (autoloads (ediff-toggle-use-toolbar ediff-toggle-multiframe)
-;;;;;; "ediff-util" "ediff-util.el" (19752 41642))
-;;; Generated autoloads from ediff-util.el
+;;;;;; "ediff-util" "vc/ediff-util.el" (19845 45374))
+;;; Generated autoloads from vc/ediff-util.el
(autoload 'ediff-toggle-multiframe "ediff-util" "\
Switch from multiframe display to single-frame display and back.
@@ -7626,13 +7707,9 @@ 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"
-;;;;;; (19752 41642))
+;;;;;; (19886 45771))
;;; Generated autoloads from edmacro.el
-(defvar edmacro-eight-bits nil "\
-*Non-nil if `edit-kbd-macro' should leave 8-bit characters intact.
-Default nil means to write characters above \\177 in octal notation.")
-
(autoload 'edit-kbd-macro "edmacro" "\
Edit a keyboard macro.
At the prompt, type any key sequence which is bound to a keyboard macro.
@@ -7679,7 +7756,7 @@ or nil, use a compact 80-column format.
;;;***
;;;### (autoloads (edt-emulation-on edt-set-scroll-margins) "edt"
-;;;;;; "emulation/edt.el" (19752 41642))
+;;;;;; "emulation/edt.el" (19845 45374))
;;; Generated autoloads from emulation/edt.el
(autoload 'edt-set-scroll-margins "edt" "\
@@ -7697,7 +7774,7 @@ Turn on EDT Emulation.
;;;***
;;;### (autoloads (electric-helpify with-electric-help) "ehelp" "ehelp.el"
-;;;;;; (19752 41642))
+;;;;;; (19865 50420))
;;; Generated autoloads from ehelp.el
(autoload 'with-electric-help "ehelp" "\
@@ -7722,19 +7799,19 @@ 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)
(autoload 'electric-helpify "ehelp" "\
-Not documented
+
\(fn FUN &optional NAME)" nil nil)
;;;***
;;;### (autoloads (turn-on-eldoc-mode eldoc-mode eldoc-minor-mode-string)
-;;;;;; "eldoc" "emacs-lisp/eldoc.el" (19752 41642))
+;;;;;; "eldoc" "emacs-lisp/eldoc.el" (19845 45374))
;;; Generated autoloads from emacs-lisp/eldoc.el
(defvar eldoc-minor-mode-string (purecopy " ElDoc") "\
@@ -7777,8 +7854,60 @@ Emacs Lisp mode) that support ElDoc.")
;;;***
-;;;### (autoloads (elide-head) "elide-head" "elide-head.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (electric-layout-mode electric-pair-mode electric-indent-mode)
+;;;;;; "electric" "electric.el" (19886 45771))
+;;; 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" (19845
+;;;;;; 45374))
;;; Generated autoloads from elide-head.el
(autoload 'elide-head "elide-head" "\
@@ -7795,7 +7924,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from emacs-lisp/elint.el
(autoload 'elint-file "elint" "\
@@ -7831,8 +7960,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" (19752
-;;;;;; 41642))
+;;;;;; elp-instrument-function) "elp" "emacs-lisp/elp.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from emacs-lisp/elp.el
(autoload 'elp-instrument-function "elp" "\
@@ -7867,7 +7996,7 @@ displayed.
;;;***
;;;### (autoloads (report-emacs-bug) "emacsbug" "mail/emacsbug.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from mail/emacsbug.el
(autoload 'report-emacs-bug "emacsbug" "\
@@ -7882,8 +8011,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" (19845 45374))
+;;; Generated autoloads from vc/emerge.el
(autoload 'emerge-files "emerge" "\
Run Emerge on two files.
@@ -7906,22 +8035,22 @@ Run Emerge on two buffers, giving another buffer as the ancestor.
\(fn BUFFER-A BUFFER-B BUFFER-ANCESTOR &optional STARTUP-HOOKS QUIT-HOOKS)" t nil)
(autoload 'emerge-files-command "emerge" "\
-Not documented
+
\(fn)" nil nil)
(autoload 'emerge-files-with-ancestor-command "emerge" "\
-Not documented
+
\(fn)" nil nil)
(autoload 'emerge-files-remote "emerge" "\
-Not documented
+
\(fn FILE-A FILE-B FILE-OUT)" nil nil)
(autoload 'emerge-files-with-ancestor-remote "emerge" "\
-Not documented
+
\(fn FILE-A FILE-B FILE-ANC FILE-OUT)" nil nil)
@@ -7936,14 +8065,14 @@ Emerge two RCS revisions of a file, with another revision as ancestor.
\(fn ARG FILE REVISION-A REVISION-B ANCESTOR &optional STARTUP-HOOKS QUIT-HOOKS)" t nil)
(autoload 'emerge-merge-directories "emerge" "\
-Not documented
+
\(fn A-DIR B-DIR ANCESTOR-DIR OUTPUT-DIR)" t nil)
;;;***
;;;### (autoloads (enriched-decode enriched-encode enriched-mode)
-;;;;;; "enriched" "textmodes/enriched.el" (19752 41642))
+;;;;;; "enriched" "textmodes/enriched.el" (19845 45374))
;;; Generated autoloads from textmodes/enriched.el
(autoload 'enriched-mode "enriched" "\
@@ -7962,12 +8091,12 @@ Commands:
\(fn &optional ARG)" t nil)
(autoload 'enriched-encode "enriched" "\
-Not documented
+
\(fn FROM TO ORIG-BUF)" nil nil)
(autoload 'enriched-decode "enriched" "\
-Not documented
+
\(fn FROM TO)" nil nil)
@@ -7978,8 +8107,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" (19752
-;;;;;; 41642))
+;;;;;; epa-list-secret-keys epa-list-keys) "epa" "epa.el" (19865
+;;;;;; 50420))
;;; Generated autoloads from epa.el
(autoload 'epa-list-keys "epa" "\
@@ -8152,7 +8281,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" (19752 41642))
+;;;;;; epa-dired-do-decrypt) "epa-dired" "epa-dired.el" (19865 50420))
;;; Generated autoloads from epa-dired.el
(autoload 'epa-dired-do-decrypt "epa-dired" "\
@@ -8178,21 +8307,21 @@ Encrypt marked files.
;;;***
;;;### (autoloads (epa-file-disable epa-file-enable epa-file-handler)
-;;;;;; "epa-file" "epa-file.el" (19797 53811))
+;;;;;; "epa-file" "epa-file.el" (19865 50420))
;;; Generated autoloads from epa-file.el
(autoload 'epa-file-handler "epa-file" "\
-Not documented
+
\(fn OPERATION &rest ARGS)" nil nil)
(autoload 'epa-file-enable "epa-file" "\
-Not documented
+
\(fn)" t nil)
(autoload 'epa-file-disable "epa-file" "\
-Not documented
+
\(fn)" t nil)
@@ -8200,7 +8329,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" (19752 41642))
+;;;;;; "epa-mail" "epa-mail.el" (19865 50420))
;;; Generated autoloads from epa-mail.el
(autoload 'epa-mail-mode "epa-mail" "\
@@ -8264,7 +8393,7 @@ Minor mode to hook EasyPG into Mail mode.
;;;***
-;;;### (autoloads (epg-make-context) "epg" "epg.el" (19797 53798))
+;;;### (autoloads (epg-make-context) "epg" "epg.el" (19865 50420))
;;; Generated autoloads from epg.el
(autoload 'epg-make-context "epg" "\
@@ -8275,7 +8404,7 @@ Return a context object.
;;;***
;;;### (autoloads (epg-expand-group epg-check-configuration epg-configuration)
-;;;;;; "epg-config" "epg-config.el" (19752 41642))
+;;;;;; "epg-config" "epg-config.el" (19845 45374))
;;; Generated autoloads from epg-config.el
(autoload 'epg-configuration "epg-config" "\
@@ -8296,7 +8425,7 @@ Look at CONFIG and try to expand GROUP.
;;;***
;;;### (autoloads (erc-handle-irc-url erc erc-select-read-args) "erc"
-;;;;;; "erc/erc.el" (19752 41642))
+;;;;;; "erc/erc.el" (19895 48172))
;;; Generated autoloads from erc/erc.el
(autoload 'erc-select-read-args "erc" "\
@@ -8338,33 +8467,33 @@ Otherwise, connect to HOST:PORT as USER and /join CHANNEL.
;;;***
-;;;### (autoloads nil "erc-autoaway" "erc/erc-autoaway.el" (19752
-;;;;;; 41642))
+;;;### (autoloads nil "erc-autoaway" "erc/erc-autoaway.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from erc/erc-autoaway.el
(autoload 'erc-autoaway-mode "erc-autoaway")
;;;***
-;;;### (autoloads nil "erc-button" "erc/erc-button.el" (19752 41642))
+;;;### (autoloads nil "erc-button" "erc/erc-button.el" (19895 48172))
;;; Generated autoloads from erc/erc-button.el
(autoload 'erc-button-mode "erc-button" nil t)
;;;***
-;;;### (autoloads nil "erc-capab" "erc/erc-capab.el" (19752 41642))
+;;;### (autoloads nil "erc-capab" "erc/erc-capab.el" (19845 45374))
;;; Generated autoloads from erc/erc-capab.el
(autoload 'erc-capab-identify-mode "erc-capab" nil t)
;;;***
-;;;### (autoloads nil "erc-compat" "erc/erc-compat.el" (19752 41642))
+;;;### (autoloads nil "erc-compat" "erc/erc-compat.el" (19845 45374))
;;; 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" (19752 41642))
+;;;;;; "erc-dcc" "erc/erc-dcc.el" (19895 48172))
;;; Generated autoloads from erc/erc-dcc.el
(autoload 'erc-dcc-mode "erc-dcc")
@@ -8397,7 +8526,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from erc/erc-ezbounce.el
(autoload 'erc-cmd-ezb "erc-ezbounce" "\
@@ -8413,7 +8542,7 @@ in the alist is `nil', prompt for the appropriate values.
\(fn SERVER PORT)" nil nil)
(autoload 'erc-ezb-lookup-action "erc-ezbounce" "\
-Not documented
+
\(fn MESSAGE)" nil nil)
@@ -8459,8 +8588,8 @@ Add EZBouncer convenience functions to ERC.
;;;***
-;;;### (autoloads (erc-fill) "erc-fill" "erc/erc-fill.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (erc-fill) "erc-fill" "erc/erc-fill.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from erc/erc-fill.el
(autoload 'erc-fill-mode "erc-fill" nil t)
@@ -8472,15 +8601,8 @@ You can put this on `erc-insert-modify-hook' and/or `erc-send-modify-hook'.
;;;***
-;;;### (autoloads nil "erc-hecomplete" "erc/erc-hecomplete.el" (19752
-;;;;;; 41642))
-;;; 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" (19752 41642))
+;;;;;; "erc/erc-identd.el" (19845 45374))
;;; Generated autoloads from erc/erc-identd.el
(autoload 'erc-identd-mode "erc-identd")
@@ -8495,37 +8617,37 @@ system.
\(fn &optional PORT)" t nil)
(autoload 'erc-identd-stop "erc-identd" "\
-Not documented
+
\(fn &rest IGNORE)" t nil)
;;;***
;;;### (autoloads (erc-create-imenu-index) "erc-imenu" "erc/erc-imenu.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from erc/erc-imenu.el
(autoload 'erc-create-imenu-index "erc-imenu" "\
-Not documented
+
\(fn)" nil nil)
;;;***
-;;;### (autoloads nil "erc-join" "erc/erc-join.el" (19752 41642))
+;;;### (autoloads nil "erc-join" "erc/erc-join.el" (19845 45374))
;;; Generated autoloads from erc/erc-join.el
(autoload 'erc-autojoin-mode "erc-join" nil t)
;;;***
-;;;### (autoloads nil "erc-list" "erc/erc-list.el" (19752 41642))
+;;;### (autoloads nil "erc-list" "erc/erc-list.el" (19845 45374))
;;; 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" (19752 41642))
+;;;;;; "erc/erc-log.el" (19845 45374))
;;; Generated autoloads from erc/erc-log.el
(autoload 'erc-log-mode "erc-log" nil t)
@@ -8557,7 +8679,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from erc/erc-match.el
(autoload 'erc-match-mode "erc-match")
@@ -8603,14 +8725,14 @@ Delete dangerous-host interactively to `erc-dangerous-hosts'.
;;;***
-;;;### (autoloads nil "erc-menu" "erc/erc-menu.el" (19752 41642))
+;;;### (autoloads nil "erc-menu" "erc/erc-menu.el" (19845 45374))
;;; 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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from erc/erc-netsplit.el
(autoload 'erc-netsplit-mode "erc-netsplit")
@@ -8622,7 +8744,7 @@ Show who's gone.
;;;***
;;;### (autoloads (erc-server-select erc-determine-network) "erc-networks"
-;;;;;; "erc/erc-networks.el" (19752 41642))
+;;;;;; "erc/erc-networks.el" (19845 45374))
;;; Generated autoloads from erc/erc-networks.el
(autoload 'erc-determine-network "erc-networks" "\
@@ -8640,7 +8762,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" (19752 41642))
+;;;;;; "erc/erc-notify.el" (19845 45374))
;;; Generated autoloads from erc/erc-notify.el
(autoload 'erc-notify-mode "erc-notify" nil t)
@@ -8652,39 +8774,39 @@ with args, toggle notify status of people.
\(fn &rest ARGS)" nil nil)
(autoload 'pcomplete/erc-mode/NOTIFY "erc-notify" "\
-Not documented
+
\(fn)" nil nil)
;;;***
-;;;### (autoloads nil "erc-page" "erc/erc-page.el" (19752 41642))
+;;;### (autoloads nil "erc-page" "erc/erc-page.el" (19845 45374))
;;; Generated autoloads from erc/erc-page.el
(autoload 'erc-page-mode "erc-page")
;;;***
-;;;### (autoloads nil "erc-pcomplete" "erc/erc-pcomplete.el" (19752
-;;;;;; 41642))
+;;;### (autoloads nil "erc-pcomplete" "erc/erc-pcomplete.el" (19899
+;;;;;; 57784))
;;; Generated autoloads from erc/erc-pcomplete.el
(autoload 'erc-completion-mode "erc-pcomplete" nil t)
;;;***
-;;;### (autoloads nil "erc-replace" "erc/erc-replace.el" (19752 41642))
+;;;### (autoloads nil "erc-replace" "erc/erc-replace.el" (19845 45374))
;;; Generated autoloads from erc/erc-replace.el
(autoload 'erc-replace-mode "erc-replace")
;;;***
-;;;### (autoloads nil "erc-ring" "erc/erc-ring.el" (19752 41642))
+;;;### (autoloads nil "erc-ring" "erc/erc-ring.el" (19845 45374))
;;; 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" (19752 41642))
+;;;;;; "erc-services" "erc/erc-services.el" (19845 45374))
;;; Generated autoloads from erc/erc-services.el
(autoload 'erc-services-mode "erc-services" nil t)
@@ -8701,14 +8823,14 @@ When called interactively, read the password using `read-passwd'.
;;;***
-;;;### (autoloads nil "erc-sound" "erc/erc-sound.el" (19752 41642))
+;;;### (autoloads nil "erc-sound" "erc/erc-sound.el" (19845 45374))
;;; Generated autoloads from erc/erc-sound.el
(autoload 'erc-sound-mode "erc-sound")
;;;***
;;;### (autoloads (erc-speedbar-browser) "erc-speedbar" "erc/erc-speedbar.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from erc/erc-speedbar.el
(autoload 'erc-speedbar-browser "erc-speedbar" "\
@@ -8719,21 +8841,21 @@ This will add a speedbar major display mode.
;;;***
-;;;### (autoloads nil "erc-spelling" "erc/erc-spelling.el" (19752
-;;;;;; 41642))
+;;;### (autoloads nil "erc-spelling" "erc/erc-spelling.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from erc/erc-spelling.el
(autoload 'erc-spelling-mode "erc-spelling" nil t)
;;;***
-;;;### (autoloads nil "erc-stamp" "erc/erc-stamp.el" (19752 41642))
+;;;### (autoloads nil "erc-stamp" "erc/erc-stamp.el" (19845 45374))
;;; 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"
-;;;;;; (19783 2570))
+;;;;;; (19845 45374))
;;; Generated autoloads from erc/erc-track.el
(defvar erc-track-minor-mode nil "\
@@ -8756,7 +8878,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" (19752 41642))
+;;;;;; "erc-truncate" "erc/erc-truncate.el" (19845 45374))
;;; Generated autoloads from erc/erc-truncate.el
(autoload 'erc-truncate-mode "erc-truncate" nil t)
@@ -8776,7 +8898,7 @@ Meant to be used in hooks, like `erc-insert-post-hook'.
;;;***
;;;### (autoloads (erc-xdcc-add-file) "erc-xdcc" "erc/erc-xdcc.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from erc/erc-xdcc.el
(autoload 'erc-xdcc-mode "erc-xdcc")
@@ -8787,32 +8909,105 @@ Add a file to `erc-xdcc-files'.
;;;***
-;;;### (autoloads (eshell-mode) "esh-mode" "eshell/esh-mode.el" (19752
-;;;;;; 41642))
-;;; Generated autoloads from eshell/esh-mode.el
+;;;### (autoloads (ert-describe-test ert-run-tests-interactively
+;;;;;; ert-run-tests-batch-and-exit ert-run-tests-batch ert-deftest)
+;;;;;; "ert" "emacs-lisp/ert.el" (19846 36966))
+;;; Generated autoloads from emacs-lisp/ert.el
-(autoload 'eshell-mode "esh-mode" "\
-Emacs shell interactive mode.
+(autoload 'ert-deftest "ert" "\
+Define NAME (a symbol) as a test.
-\\{eshell-mode-map}
+BODY is evaluated as a `progn' when the test is run. It should
+signal a condition on failure or just return if the test passes.
-\(fn)" nil nil)
+`should', `should-not' and `should-error' are useful for
+assertions in BODY.
+
+Use `ert' to run tests interactively.
+
+Tests that are expected to fail can be marked as such
+using :expected-result. See `ert-test-result-type-p' for a
+description of valid values for RESULT-TYPE.
+
+\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] [:tags '(TAG...)] BODY...)" nil (quote macro))
+
+(put 'ert-deftest 'lisp-indent-function '2)
+
+(put 'ert-deftest 'doc-string-elt '3)
+
+(put 'ert-deftest 'lisp-indent-function 2)
+
+(put 'ert-info 'lisp-indent-function 1)
+
+(autoload 'ert-run-tests-batch "ert" "\
+Run the tests specified by SELECTOR, printing results to the terminal.
+
+SELECTOR works as described in `ert-select-tests', except if
+SELECTOR is nil, in which case all tests rather than none will be
+run; this makes the command line \"emacs -batch -l my-tests.el -f
+ert-run-tests-batch-and-exit\" useful.
+
+Returns the stats object.
+
+\(fn &optional SELECTOR)" nil nil)
+
+(autoload 'ert-run-tests-batch-and-exit "ert" "\
+Like `ert-run-tests-batch', but exits Emacs when done.
+
+The exit status will be 0 if all test results were as expected, 1
+on unexpected results, or 2 if the tool detected an error outside
+of the tests (e.g. invalid SELECTOR or bug in the code that runs
+the tests).
+
+\(fn &optional SELECTOR)" nil nil)
+
+(autoload 'ert-run-tests-interactively "ert" "\
+Run the tests specified by SELECTOR and display the results in a buffer.
+
+SELECTOR works as described in `ert-select-tests'.
+OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they
+are used for automated self-tests and specify which buffer to use
+and how to display message.
+
+\(fn SELECTOR &optional OUTPUT-BUFFER-NAME MESSAGE-FN)" t nil)
+
+(defalias 'ert 'ert-run-tests-interactively)
+
+(autoload 'ert-describe-test "ert" "\
+Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test).
+
+\(fn TEST-OR-TEST-NAME)" t nil)
;;;***
-;;;### (autoloads (eshell-test) "esh-test" "eshell/esh-test.el" (19752
-;;;;;; 41642))
-;;; Generated autoloads from eshell/esh-test.el
+;;;### (autoloads (ert-kill-all-test-buffers) "ert-x" "emacs-lisp/ert-x.el"
+;;;;;; (19845 45374))
+;;; Generated autoloads from emacs-lisp/ert-x.el
-(autoload 'eshell-test "esh-test" "\
-Test Eshell to verify that it works as expected.
+(put 'ert-with-test-buffer 'lisp-indent-function 1)
-\(fn &optional ARG)" t nil)
+(autoload 'ert-kill-all-test-buffers "ert-x" "\
+Kill all test buffers that are still live.
+
+\(fn)" t nil)
+
+;;;***
+
+;;;### (autoloads (eshell-mode) "esh-mode" "eshell/esh-mode.el" (19890
+;;;;;; 42850))
+;;; Generated autoloads from eshell/esh-mode.el
+
+(autoload 'eshell-mode "esh-mode" "\
+Emacs shell interactive mode.
+
+\\{eshell-mode-map}
+
+\(fn)" nil nil)
;;;***
;;;### (autoloads (eshell-command-result eshell-command eshell) "eshell"
-;;;;;; "eshell/eshell.el" (19752 41642))
+;;;;;; "eshell/eshell.el" (19845 45374))
;;; Generated autoloads from eshell/eshell.el
(autoload 'eshell "eshell" "\
@@ -8853,7 +9048,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"
-;;;;;; (19752 41642))
+;;;;;; (19893 19022))
;;; Generated autoloads from progmodes/etags.el
(defvar tags-file-name nil "\
@@ -8862,6 +9057,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.
@@ -8879,7 +9075,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
@@ -8948,6 +9144,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.
@@ -9161,11 +9362,11 @@ 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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from language/ethio-util.el
(autoload 'setup-ethiopic-environment-internal "ethio-util" "\
-Not documented
+
\(fn)" nil nil)
@@ -9323,7 +9524,7 @@ With ARG, insert that many delimiters.
\(fn ARG)" t nil)
(autoload 'ethio-composition-function "ethio-util" "\
-Not documented
+
\(fn POS TO FONT-OBJECT STRING)" nil nil)
@@ -9331,7 +9532,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from net/eudc.el
(autoload 'eudc-set-server "eudc" "\
@@ -9387,7 +9588,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" (19752 41642))
+;;;;;; "eudc-bob" "net/eudc-bob.el" (19845 45374))
;;; Generated autoloads from net/eudc-bob.el
(autoload 'eudc-display-generic-binary "eudc-bob" "\
@@ -9423,7 +9624,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" (19752 41642))
+;;;;;; "eudc-export" "net/eudc-export.el" (19845 45374))
;;; Generated autoloads from net/eudc-export.el
(autoload 'eudc-insert-record-at-point-into-bbdb "eudc-export" "\
@@ -9440,7 +9641,7 @@ Call `eudc-insert-record-at-point-into-bbdb' if on a record.
;;;***
;;;### (autoloads (eudc-edit-hotlist) "eudc-hotlist" "net/eudc-hotlist.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from net/eudc-hotlist.el
(autoload 'eudc-edit-hotlist "eudc-hotlist" "\
@@ -9450,8 +9651,8 @@ Edit the hotlist of directory servers in a specialized buffer.
;;;***
-;;;### (autoloads (ewoc-create) "ewoc" "emacs-lisp/ewoc.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (ewoc-create) "ewoc" "emacs-lisp/ewoc.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from emacs-lisp/ewoc.el
(autoload 'ewoc-create "ewoc" "\
@@ -9480,7 +9681,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"
-;;;;;; (19752 41642))
+;;;;;; (19890 42850))
;;; Generated autoloads from progmodes/executable.el
(autoload 'executable-command-find-posix-p "executable" "\
@@ -9523,7 +9724,7 @@ file modes.
;;;### (autoloads (expand-jump-to-next-slot expand-jump-to-previous-slot
;;;;;; expand-abbrev-hook expand-add-abbrevs) "expand" "expand.el"
-;;;;;; (19752 41642))
+;;;;;; (19886 45771))
;;; Generated autoloads from expand.el
(autoload 'expand-add-abbrevs "expand" "\
@@ -9572,7 +9773,7 @@ This is used only in conjunction with `expand-add-abbrevs'.
;;;***
-;;;### (autoloads (f90-mode) "f90" "progmodes/f90.el" (19788 46601))
+;;;### (autoloads (f90-mode) "f90" "progmodes/f90.el" (19882 48702))
;;; Generated autoloads from progmodes/f90.el
(autoload 'f90-mode "f90" "\
@@ -9638,8 +9839,8 @@ with no args, if that value is non-nil.
;;;### (autoloads (variable-pitch-mode buffer-face-toggle buffer-face-set
;;;;;; 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" (19752
-;;;;;; 41642))
+;;;;;; face-remap-add-relative) "face-remap" "face-remap.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from face-remap.el
(autoload 'face-remap-add-relative "face-remap" "\
@@ -9779,7 +9980,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" (19845 45374))
;;; Generated autoloads from mail/feedmail.el
(autoload 'feedmail-send-it "feedmail" "\
@@ -9833,7 +10034,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" (19752 41642))
+;;;;;; find-file-at-point ffap-next) "ffap" "ffap.el" (19845 45374))
;;; Generated autoloads from ffap.el
(autoload 'ffap-next "ffap" "\
@@ -9897,7 +10098,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" (19752 41642))
+;;;;;; "filecache" "filecache.el" (19845 45374))
;;; Generated autoloads from filecache.el
(autoload 'file-cache-add-directory "filecache" "\
@@ -9957,7 +10158,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" (19752 41642))
+;;;;;; add-file-local-variable) "files-x" "files-x.el" (19886 45771))
;;; Generated autoloads from files-x.el
(autoload 'add-file-local-variable "files-x" "\
@@ -10022,8 +10223,8 @@ Copy directory-local variables to the -*- line.
;;;***
-;;;### (autoloads (filesets-init) "filesets" "filesets.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (filesets-init) "filesets" "filesets.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from filesets.el
(autoload 'filesets-init "filesets" "\
@@ -10034,7 +10235,7 @@ Set up hooks, load the cache file -- if existing -- and build the menu.
;;;***
-;;;### (autoloads (find-cmd) "find-cmd" "find-cmd.el" (19752 41642))
+;;;### (autoloads (find-cmd) "find-cmd" "find-cmd.el" (19845 45374))
;;; Generated autoloads from find-cmd.el
(autoload 'find-cmd "find-cmd" "\
@@ -10053,42 +10254,18 @@ 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"
-;;;;;; (19752 41642))
+;;;### (autoloads (find-grep-dired find-name-dired find-dired) "find-dired"
+;;;;;; "find-dired.el" (19864 29553))
;;; Generated autoloads from find-dired.el
-(defvar find-ls-option (if (eq system-type 'berkeley-unix) (purecopy '("-ls" . "-gilsb")) (purecopy '("-exec ls -ld {} \\;" . "-ld"))) "\
-Description of the option to `find' to produce an `ls -l'-type listing.
-This is a cons of two strings (FIND-OPTION . LS-SWITCHES). FIND-OPTION
-gives the option (or options) to `find' that produce the desired output.
-LS-SWITCHES is a list of `ls' switches to tell dired how to parse the output.")
-
-(custom-autoload 'find-ls-option "find-dired" t)
-
-(defvar find-ls-subdir-switches (purecopy "-al") "\
-`ls' switches for inserting subdirectories in `*Find*' buffers.
-This should contain the \"-l\" switch.
-Use the \"-F\" or \"-b\" switches if and only if you also use
-them for `find-ls-option'.")
-
-(custom-autoload 'find-ls-subdir-switches "find-dired" t)
-
-(defvar find-grep-options (purecopy (if (or (eq system-type 'berkeley-unix) (string-match "solaris2" system-configuration) (string-match "irix" system-configuration)) "-s" "-q")) "\
-Option to grep to be as silent as possible.
-On Berkeley systems, this is `-s'; on Posix, and with GNU grep, `-q' does it.
-On other systems, the closest you can come is to use `-l'.")
-
-(custom-autoload 'find-grep-options "find-dired" t)
-
(autoload 'find-dired "find-dired" "\
Run `find' and go into Dired mode on a buffer of the output.
-The command run (after changing into DIR) is
+The command run (after changing into DIR) is essentially
find . \\( ARGS \\) -ls
-except that the variable `find-ls-option' specifies what to use
-as the final argument.
+except that the car of the variable `find-ls-option' specifies what to
+use in place of \"-ls\" as the final argument.
\(fn DIR ARGS)" t nil)
@@ -10106,9 +10283,11 @@ The command run (after changing into DIR) is
Find files in DIR containing a regexp REGEXP and start Dired on output.
The command run (after changing into DIR) is
- find . -exec grep -s -e REGEXP {} \\; -ls
+ find . \\( -type f -exec `grep-program' `find-grep-options' \\
+ -e REGEXP {} \\; \\) -ls
-Thus ARG can also contain additional grep options.
+where the car of the variable `find-ls-option' specifies what to
+use in place of \"-ls\" as the final argument.
\(fn DIR REGEXP)" t nil)
@@ -10116,7 +10295,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; 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)))) "\
@@ -10210,7 +10389,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" (19752 41642))
+;;;;;; "emacs-lisp/find-func.el" (19845 45374))
;;; Generated autoloads from emacs-lisp/find-func.el
(autoload 'find-library "find-func" "\
@@ -10365,7 +10544,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" (19752 41642))
+;;;;;; find-lisp-find-dired) "find-lisp" "find-lisp.el" (19886 45771))
;;; Generated autoloads from find-lisp.el
(autoload 'find-lisp-find-dired "find-lisp" "\
@@ -10386,7 +10565,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" (19752 41642))
+;;;;;; "finder" "finder.el" (19893 19022))
;;; Generated autoloads from finder.el
(autoload 'finder-list-keywords "finder" "\
@@ -10408,7 +10587,7 @@ Find packages matching a given keyword.
;;;***
;;;### (autoloads (enable-flow-control-on enable-flow-control) "flow-ctrl"
-;;;;;; "flow-ctrl.el" (19752 41642))
+;;;;;; "flow-ctrl.el" (19845 45374))
;;; Generated autoloads from flow-ctrl.el
(autoload 'enable-flow-control "flow-ctrl" "\
@@ -10430,23 +10609,23 @@ to get the effect of a C-q.
;;;***
;;;### (autoloads (fill-flowed fill-flowed-encode) "flow-fill" "gnus/flow-fill.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from gnus/flow-fill.el
(autoload 'fill-flowed-encode "flow-fill" "\
-Not documented
+
\(fn &optional BUFFER)" nil nil)
(autoload 'fill-flowed "flow-fill" "\
-Not documented
+
\(fn &optional BUFFER DELETE-SPACE)" nil nil)
;;;***
;;;### (autoloads (flymake-mode-off flymake-mode-on flymake-mode)
-;;;;;; "flymake" "progmodes/flymake.el" (19752 41642))
+;;;;;; "flymake" "progmodes/flymake.el" (19890 42850))
;;; Generated autoloads from progmodes/flymake.el
(autoload 'flymake-mode "flymake" "\
@@ -10470,7 +10649,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" (19752 41642))
+;;;;;; "flyspell" "textmodes/flyspell.el" (19865 50420))
;;; Generated autoloads from textmodes/flyspell.el
(autoload 'flyspell-prog-mode "flyspell" "\
@@ -10540,7 +10719,7 @@ Flyspell whole buffer.
;;;### (autoloads (follow-delete-other-windows-and-split follow-mode
;;;;;; turn-off-follow-mode turn-on-follow-mode) "follow" "follow.el"
-;;;;;; (19752 41642))
+;;;;;; (19886 45771))
;;; Generated autoloads from follow.el
(autoload 'turn-on-follow-mode "follow" "\
@@ -10613,8 +10792,8 @@ in your `~/.emacs' file, replacing [f7] by your favourite key:
;;;***
-;;;### (autoloads (footnote-mode) "footnote" "mail/footnote.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (footnote-mode) "footnote" "mail/footnote.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from mail/footnote.el
(autoload 'footnote-mode "footnote" "\
@@ -10628,7 +10807,7 @@ started, play around with the following keys:
;;;***
;;;### (autoloads (forms-find-file-other-window forms-find-file forms-mode)
-;;;;;; "forms" "forms.el" (19752 41642))
+;;;;;; "forms" "forms.el" (19886 45771))
;;; Generated autoloads from forms.el
(autoload 'forms-mode "forms" "\
@@ -10665,7 +10844,7 @@ Visit a file in Forms mode in other window.
;;;***
;;;### (autoloads (fortran-mode) "fortran" "progmodes/fortran.el"
-;;;;;; (19752 41642))
+;;;;;; (19890 42850))
;;; Generated autoloads from progmodes/fortran.el
(autoload 'fortran-mode "fortran" "\
@@ -10743,7 +10922,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" (19752 41642))
+;;;;;; fortune-add-fortune) "fortune" "play/fortune.el" (19889 21967))
;;; Generated autoloads from play/fortune.el
(autoload 'fortune-add-fortune "fortune" "\
@@ -10791,14 +10970,19 @@ and choose the directory as the fortune-file.
;;;***
-;;;### (autoloads (gdb-enable-debug gdb) "gdb-ui" "progmodes/gdb-ui.el"
-;;;;;; (19752 41642))
-;;; Generated autoloads from progmodes/gdb-ui.el
+;;;### (autoloads (gdb gdb-enable-debug) "gdb-mi" "progmodes/gdb-mi.el"
+;;;;;; (19890 42850))
+;;; Generated autoloads from progmodes/gdb-mi.el
+
+(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-ui" "\
+(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
@@ -10806,10 +10990,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.
@@ -10821,37 +11003,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" (19752
-;;;;;; 41642))
+;;;;;; define-generic-mode) "generic" "emacs-lisp/generic.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from emacs-lisp/generic.el
(defvar generic-mode-list nil "\
@@ -10895,6 +11077,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.
@@ -10926,7 +11110,7 @@ regular expression that can be used as an element of
;;;***
;;;### (autoloads (glasses-mode) "glasses" "progmodes/glasses.el"
-;;;;;; (19752 41642))
+;;;;;; (19890 42850))
;;; Generated autoloads from progmodes/glasses.el
(autoload 'glasses-mode "glasses" "\
@@ -10940,7 +11124,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from gnus/gmm-utils.el
(autoload 'gmm-regexp-concat "gmm-utils" "\
@@ -10995,7 +11179,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" (19806 64998))
+;;;;;; gnus-slave-no-server) "gnus" "gnus/gnus.el" (19889 21967))
;;; Generated autoloads from gnus/gnus.el
(when (fboundp 'custom-autoload)
(custom-autoload 'gnus-select-method "gnus"))
@@ -11048,7 +11232,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" (19813 16320))
+;;;;;; "gnus/gnus-agent.el" (19860 32495))
;;; Generated autoloads from gnus/gnus-agent.el
(autoload 'gnus-unplugged "gnus-agent" "\
@@ -11139,7 +11323,7 @@ If CLEAN, obsolete (ignore).
;;;***
;;;### (autoloads (gnus-article-prepare-display) "gnus-art" "gnus/gnus-art.el"
-;;;;;; (19752 41642))
+;;;;;; (19874 54611))
;;; Generated autoloads from gnus/gnus-art.el
(autoload 'gnus-article-prepare-display "gnus-art" "\
@@ -11149,19 +11333,8 @@ Make the current buffer look like a nice article.
;;;***
-;;;### (autoloads (gnus-audio-play) "gnus-audio" "gnus/gnus-audio.el"
-;;;;;; (19752 41642))
-;;; 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" (19752 41642))
+;;;;;; "gnus-bookmark" "gnus/gnus-bookmark.el" (19845 45374))
;;; Generated autoloads from gnus/gnus-bookmark.el
(autoload 'gnus-bookmark-set "gnus-bookmark" "\
@@ -11186,8 +11359,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" (19752
-;;;;;; 41642))
+;;;;;; gnus-jog-cache) "gnus-cache" "gnus/gnus-cache.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from gnus/gnus-cache.el
(autoload 'gnus-jog-cache "gnus-cache" "\
@@ -11229,7 +11402,7 @@ supported.
;;;***
;;;### (autoloads (gnus-delay-initialize gnus-delay-send-queue gnus-delay-article)
-;;;;;; "gnus-delay" "gnus/gnus-delay.el" (19752 41642))
+;;;;;; "gnus-delay" "gnus/gnus-delay.el" (19845 45374))
;;; Generated autoloads from gnus/gnus-delay.el
(autoload 'gnus-delay-article "gnus-delay" "\
@@ -11265,23 +11438,23 @@ 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" (19752 41642))
+;;;;;; "gnus-diary" "gnus/gnus-diary.el" (19845 45374))
;;; Generated autoloads from gnus/gnus-diary.el
(autoload 'gnus-user-format-function-d "gnus-diary" "\
-Not documented
+
\(fn HEADER)" nil nil)
(autoload 'gnus-user-format-function-D "gnus-diary" "\
-Not documented
+
\(fn HEADER)" nil nil)
;;;***
;;;### (autoloads (turn-on-gnus-dired-mode) "gnus-dired" "gnus/gnus-dired.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from gnus/gnus-dired.el
(autoload 'turn-on-gnus-dired-mode "gnus-dired" "\
@@ -11292,7 +11465,7 @@ Convenience method to turn on gnus-dired-mode.
;;;***
;;;### (autoloads (gnus-draft-reminder) "gnus-draft" "gnus/gnus-draft.el"
-;;;;;; (19752 41642))
+;;;;;; (19881 27850))
;;; Generated autoloads from gnus/gnus-draft.el
(autoload 'gnus-draft-reminder "gnus-draft" "\
@@ -11304,8 +11477,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" (19752
-;;;;;; 41642))
+;;;;;; gnus-random-x-face) "gnus-fun" "gnus/gnus-fun.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from gnus/gnus-fun.el
(autoload 'gnus-random-x-face "gnus-fun" "\
@@ -11349,8 +11522,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" (19845 45374))
+;;; 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" (19752 41642))
+;;;;;; "gnus-group" "gnus/gnus-group.el" (19845 45374))
;;; Generated autoloads from gnus/gnus-group.el
(autoload 'gnus-fetch-group "gnus-group" "\
@@ -11367,8 +11558,24 @@ Pop up a frame and enter GROUP.
;;;***
+;;;### (autoloads (gnus-html-prefetch-images gnus-article-html) "gnus-html"
+;;;;;; "gnus/gnus-html.el" (19845 45374))
+;;; Generated autoloads from gnus/gnus-html.el
+
+(autoload 'gnus-article-html "gnus-html" "\
+
+
+\(fn &optional HANDLE)" nil nil)
+
+(autoload 'gnus-html-prefetch-images "gnus-html" "\
+
+
+\(fn SUMMARY)" nil nil)
+
+;;;***
+
;;;### (autoloads (gnus-batch-score) "gnus-kill" "gnus/gnus-kill.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from gnus/gnus-kill.el
(defalias 'gnus-batch-kill 'gnus-batch-score)
@@ -11383,11 +11590,11 @@ 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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from gnus/gnus-ml.el
(autoload 'turn-on-gnus-mailing-list-mode "gnus-ml" "\
-Not documented
+
\(fn)" nil nil)
@@ -11408,7 +11615,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from gnus/gnus-mlspl.el
(autoload 'gnus-group-split-setup "gnus-mlspl" "\
@@ -11508,20 +11715,8 @@ Calling (gnus-group-split-fancy nil nil \"mail.others\") returns:
;;;***
-;;;### (autoloads (gnus-change-server) "gnus-move" "gnus/gnus-move.el"
-;;;;;; (19752 41642))
-;;; 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" (19752 41642))
+;;;;;; "gnus-msg" "gnus/gnus-msg.el" (19845 45374))
;;; Generated autoloads from gnus/gnus-msg.el
(autoload 'gnus-msg-mail "gnus-msg" "\
@@ -11529,7 +11724,7 @@ Start editing a mail message to be sent.
Like `message-mail', but with Gnus paraphernalia, particularly the
Gcc: header for archiving purposes.
-\(fn &optional TO SUBJECT OTHER-HEADERS CONTINUE SWITCH-ACTION YANK-ACTION SEND-ACTIONS)" t nil)
+\(fn &optional TO SUBJECT OTHER-HEADERS CONTINUE SWITCH-ACTION YANK-ACTION SEND-ACTIONS RETURN-ACTION)" t nil)
(autoload 'gnus-button-mailto "gnus-msg" "\
Mail to ADDRESS.
@@ -11545,25 +11740,9 @@ Like `message-reply'.
;;;***
-;;;### (autoloads (gnus-nocem-load-cache gnus-nocem-scan-groups)
-;;;;;; "gnus-nocem" "gnus/gnus-nocem.el" (19752 41642))
-;;; 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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from gnus/gnus-picon.el
(autoload 'gnus-treat-from-picon "gnus-picon" "\
@@ -11590,7 +11769,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" (19813 16320))
+;;;;;; "gnus/gnus-range.el" (19845 45374))
;;; Generated autoloads from gnus/gnus-range.el
(autoload 'gnus-sorted-difference "gnus-range" "\
@@ -11614,7 +11793,7 @@ Both lists have to be sorted over <.
\(fn LIST1 LIST2)" nil nil)
(autoload 'gnus-intersection "gnus-range" "\
-Not documented
+
\(fn LIST1 LIST2)" nil nil)
@@ -11658,7 +11837,7 @@ Add NUM into sorted LIST by side effect.
;;;***
;;;### (autoloads (gnus-registry-install-hooks gnus-registry-initialize)
-;;;;;; "gnus-registry" "gnus/gnus-registry.el" (19752 41642))
+;;;;;; "gnus-registry" "gnus/gnus-registry.el" (19893 19022))
;;; Generated autoloads from gnus/gnus-registry.el
(autoload 'gnus-registry-initialize "gnus-registry" "\
@@ -11674,8 +11853,8 @@ Install the registry hooks.
;;;***
;;;### (autoloads (gnus-sieve-article-add-rule gnus-sieve-generate
-;;;;;; gnus-sieve-update) "gnus-sieve" "gnus/gnus-sieve.el" (19752
-;;;;;; 41642))
+;;;;;; gnus-sieve-update) "gnus-sieve" "gnus/gnus-sieve.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from gnus/gnus-sieve.el
(autoload 'gnus-sieve-update "gnus-sieve" "\
@@ -11696,34 +11875,14 @@ See the documentation for these variables and functions for details.
\(fn)" t nil)
(autoload 'gnus-sieve-article-add-rule "gnus-sieve" "\
-Not documented
-\(fn)" t nil)
-
-;;;***
-
-;;;### (autoloads (gnus-batch-brew-soup) "gnus-soup" "gnus/gnus-soup.el"
-;;;;;; (19752 41642))
-;;; 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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from gnus/gnus-spec.el
(autoload 'gnus-update-format "gnus-spec" "\
@@ -11733,9 +11892,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" (19813
-;;;;;; 16320))
+;;;### (autoloads (gnus-declare-backend) "gnus-start" "gnus/gnus-start.el"
+;;;;;; (19877 30798))
;;; Generated autoloads from gnus/gnus-start.el
(autoload 'gnus-declare-backend "gnus-start" "\
@@ -11743,15 +11901,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"
+;;;;;; (19890 42850))
+;;; 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" (19845 45374))
+;;; 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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from gnus/gnus-win.el
(autoload 'gnus-add-configuration "gnus-win" "\
@@ -11761,7 +11942,7 @@ Add the window configuration CONF to `gnus-buffer-configuration'.
;;;***
-;;;### (autoloads (gomoku) "gomoku" "play/gomoku.el" (19752 41642))
+;;;### (autoloads (gomoku) "gomoku" "play/gomoku.el" (19889 21967))
;;; Generated autoloads from play/gomoku.el
(autoload 'gomoku "gomoku" "\
@@ -11788,8 +11969,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" (19752
-;;;;;; 41642))
+;;;;;; goto-address-at-point) "goto-addr" "net/goto-addr.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from net/goto-addr.el
(define-obsolete-function-alias 'goto-address-at-mouse 'goto-address-at-point "22.1")
@@ -11827,9 +12008,26 @@ Turn on `goto-address-mode', but only in comments and strings.
;;;***
+;;;### (autoloads (gravatar-retrieve-synchronously gravatar-retrieve)
+;;;;;; "gravatar" "gnus/gravatar.el" (19845 45374))
+;;; 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)
+
+(autoload 'gravatar-retrieve-synchronously "gravatar" "\
+Retrieve MAIL-ADDRESS gravatar and returns it.
+
+\(fn MAIL-ADDRESS)" 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" (19754 9185))
+;;;;;; grep-window-height) "grep" "progmodes/grep.el" (19864 29553))
;;; Generated autoloads from progmodes/grep.el
(defvar grep-window-height nil "\
@@ -11862,7 +12060,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 '(("^\\(.+?\\)\\(:[ ]*\\)\\([1-9][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") "\
@@ -11879,10 +12077,11 @@ See `grep-find-use-xargs'.
This variable's value takes effect when `grep-compute-defaults' is called.")
(defvar grep-find-use-xargs nil "\
-Non-nil means that `grep-find' uses the `xargs' utility by default.
-If `exec', use `find -exec'.
+How to invoke find and grep.
+If `exec', use `find -exec {} ;'.
+If `exec-plus' use `find -exec {} +'.
If `gnu', use `find -print0' and `xargs -0'.
-Any other non-nil value means to use `find -print' and `xargs'.
+Any other value means to use `find -print' and `xargs'.
This variable's value takes effect when `grep-compute-defaults' is called.")
@@ -11897,7 +12096,7 @@ Set up `compilation-exit-message-function' and run `grep-setup-hook'.
\(fn)" nil nil)
(autoload 'grep-compute-defaults "grep" "\
-Not documented
+
\(fn)" nil nil)
@@ -11985,7 +12184,7 @@ file name to `*.gz', and sets `grep-highlight-matches' to `always'.
;;;***
-;;;### (autoloads (gs-load-image) "gs" "gs.el" (19752 41642))
+;;;### (autoloads (gs-load-image) "gs" "gs.el" (19845 45374))
;;; Generated autoloads from gs.el
(autoload 'gs-load-image "gs" "\
@@ -11999,7 +12198,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" (19752 41642))
+;;;;;; xdb dbx sdb gud-gdb) "gud" "progmodes/gud.el" (19890 42850))
;;; Generated autoloads from progmodes/gud.el
(autoload 'gud-gdb "gud" "\
@@ -12064,8 +12263,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.
@@ -12087,8 +12284,8 @@ Toggle the display of GUD tooltips.
;;;***
-;;;### (autoloads (handwrite) "handwrite" "play/handwrite.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (handwrite) "handwrite" "play/handwrite.el" (19889
+;;;;;; 21967))
;;; Generated autoloads from play/handwrite.el
(autoload 'handwrite "handwrite" "\
@@ -12096,17 +12293,17 @@ Turns the buffer into a \"handwritten\" document.
The functions `handwrite-10pt', `handwrite-11pt', `handwrite-12pt'
and `handwrite-13pt' set up for various sizes of output.
-Variables: handwrite-linespace (default 12)
- handwrite-fontsize (default 11)
- handwrite-numlines (default 60)
- handwrite-pagenumbering (default nil)
+Variables: `handwrite-linespace' (default 12)
+ `handwrite-fontsize' (default 11)
+ `handwrite-numlines' (default 60)
+ `handwrite-pagenumbering' (default nil)
\(fn)" t nil)
;;;***
;;;### (autoloads (hanoi-unix-64 hanoi-unix hanoi) "hanoi" "play/hanoi.el"
-;;;;;; (19636 58496))
+;;;;;; (19889 21967))
;;; Generated autoloads from play/hanoi.el
(autoload 'hanoi "hanoi" "\
@@ -12135,7 +12332,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" (19752 41642))
+;;;;;; "hashcash" "mail/hashcash.el" (19845 45374))
;;; Generated autoloads from mail/hashcash.el
(autoload 'hashcash-insert-payment "hashcash" "\
@@ -12180,7 +12377,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" (19752 41642))
+;;;;;; help-at-pt-string) "help-at-pt" "help-at-pt.el" (19845 45374))
;;; Generated autoloads from help-at-pt.el
(autoload 'help-at-pt-string "help-at-pt" "\
@@ -12307,10 +12504,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"
-;;;;;; (19752 41642))
+;;;### (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" (19878 51661))
;;; Generated autoloads from help-fns.el
(autoload 'describe-function "help-fns" "\
@@ -12342,7 +12539,7 @@ suitable file is found, return nil.
\(fn OBJECT TYPE)" nil nil)
(autoload 'describe-function-1 "help-fns" "\
-Not documented
+
\(fn FUNCTION)" nil nil)
@@ -12377,10 +12574,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from help-macro.el
(defvar three-step-help nil "\
@@ -12396,8 +12603,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" (19752
-;;;;;; 41642))
+;;;;;; help-mode-setup help-mode) "help-mode" "help-mode.el" (19886
+;;;;;; 45771))
;;; Generated autoloads from help-mode.el
(autoload 'help-mode "help-mode" "\
@@ -12409,12 +12616,12 @@ Commands:
\(fn)" t nil)
(autoload 'help-mode-setup "help-mode" "\
-Not documented
+
\(fn)" nil nil)
(autoload 'help-mode-finish "help-mode" "\
-Not documented
+
\(fn)" nil nil)
@@ -12435,9 +12642,10 @@ restore it properly when going back.
(autoload 'help-buffer "help-mode" "\
Return the name of a buffer for inserting help.
If `help-xref-following' is non-nil, this is the name of the
-current buffer.
-Otherwise, it is *Help*; if no buffer with that name currently
-exists, it is created.
+current buffer. Signal an error if this buffer is not derived
+from `help-mode'.
+Otherwise, return \"*Help*\", creating a buffer with that name if
+it does not already exist.
\(fn)" nil nil)
@@ -12489,7 +12697,7 @@ Add xrefs for symbols in `pp's output between FROM and TO.
;;;***
;;;### (autoloads (Helper-help Helper-describe-bindings) "helper"
-;;;;;; "emacs-lisp/helper.el" (19752 41642))
+;;;;;; "emacs-lisp/helper.el" (19845 45374))
;;; Generated autoloads from emacs-lisp/helper.el
(autoload 'Helper-describe-bindings "helper" "\
@@ -12505,7 +12713,7 @@ Provide help for current mode.
;;;***
;;;### (autoloads (hexlify-buffer hexl-find-file hexl-mode) "hexl"
-;;;;;; "hexl.el" (19752 41642))
+;;;;;; "hexl.el" (19865 50420))
;;; Generated autoloads from hexl.el
(autoload 'hexl-mode "hexl" "\
@@ -12602,7 +12810,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from hi-lock.el
(autoload 'hi-lock-mode "hi-lock" "\
@@ -12736,7 +12944,7 @@ be found in variable `hi-lock-interactive-patterns'.
;;;***
;;;### (autoloads (hide-ifdef-mode) "hideif" "progmodes/hideif.el"
-;;;;;; (19752 41642))
+;;;;;; (19890 42850))
;;; Generated autoloads from progmodes/hideif.el
(autoload 'hide-ifdef-mode "hideif" "\
@@ -12776,7 +12984,7 @@ how the hiding is done:
;;;***
;;;### (autoloads (turn-off-hideshow hs-minor-mode) "hideshow" "progmodes/hideshow.el"
-;;;;;; (19752 41642))
+;;;;;; (19890 42850))
;;; 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))) "\
@@ -12838,8 +13046,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" (19752
-;;;;;; 41642))
+;;;;;; highlight-changes-mode) "hilit-chg" "hilit-chg.el" (19886
+;;;;;; 45771))
;;; Generated autoloads from hilit-chg.el
(autoload 'highlight-changes-mode "hilit-chg" "\
@@ -12968,7 +13176,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" (19752 41642))
+;;;;;; "hippie-exp.el" (19845 45374))
;;; 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) "\
@@ -13041,7 +13249,7 @@ argument VERBOSE non-nil makes the function verbose.
;;;***
;;;### (autoloads (global-hl-line-mode hl-line-mode) "hl-line" "hl-line.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from hl-line.el
(autoload 'hl-line-mode "hl-line" "\
@@ -13085,9 +13293,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" (19752 41642))
+;;;;;; "calendar/holidays.el" (19882 48702))
;;; 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.")
@@ -13096,7 +13306,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.
@@ -13106,7 +13316,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.
@@ -13116,7 +13326,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.
@@ -13126,8 +13336,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'.")
@@ -13148,6 +13356,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.")
@@ -13156,7 +13366,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.
@@ -13166,7 +13376,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.
@@ -13176,7 +13386,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.
@@ -13186,7 +13396,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.
@@ -13196,8 +13406,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" "\
@@ -13233,8 +13441,8 @@ The optional LABEL is used to label the buffer created.
;;;***
-;;;### (autoloads (html2text) "html2text" "gnus/html2text.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (html2text) "html2text" "gnus/html2text.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from gnus/html2text.el
(autoload 'html2text "html2text" "\
@@ -13245,7 +13453,7 @@ Convert HTML to plain text in the current buffer.
;;;***
;;;### (autoloads (htmlfontify-copy-and-link-dir htmlfontify-buffer)
-;;;;;; "htmlfontify" "htmlfontify.el" (19752 41642))
+;;;;;; "htmlfontify" "htmlfontify.el" (19886 45771))
;;; Generated autoloads from htmlfontify.el
(autoload 'htmlfontify-buffer "htmlfontify" "\
@@ -13278,8 +13486,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" (19752
-;;;;;; 41642))
+;;;;;; define-ibuffer-column) "ibuf-macs" "ibuf-macs.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from ibuf-macs.el
(autoload 'define-ibuffer-column "ibuf-macs" "\
@@ -13307,6 +13515,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
@@ -13319,6 +13529,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
@@ -13352,6 +13564,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.
@@ -13365,10 +13579,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" (19789 64363))
+;;;;;; "ibuffer" "ibuffer.el" (19886 45771))
;;; Generated autoloads from ibuffer.el
(autoload 'ibuffer-list-buffers "ibuffer" "\
@@ -13409,7 +13625,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" (19752 41642))
+;;;;;; "calendar/icalendar.el" (19897 16090))
;;; Generated autoloads from calendar/icalendar.el
(autoload 'icalendar-export-file "icalendar" "\
@@ -13461,8 +13677,8 @@ buffer `*icalendar-errors*'.
;;;***
-;;;### (autoloads (icomplete-mode) "icomplete" "icomplete.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (icomplete-mode) "icomplete" "icomplete.el" (19874
+;;;;;; 54611))
;;; Generated autoloads from icomplete.el
(defvar icomplete-mode nil "\
@@ -13483,7 +13699,7 @@ otherwise turn it off.
;;;***
-;;;### (autoloads (icon-mode) "icon" "progmodes/icon.el" (19752 41642))
+;;;### (autoloads (icon-mode) "icon" "progmodes/icon.el" (19890 42850))
;;; Generated autoloads from progmodes/icon.el
(autoload 'icon-mode "icon" "\
@@ -13524,7 +13740,7 @@ with no args, if that value is non-nil.
;;;***
;;;### (autoloads (idlwave-shell) "idlw-shell" "progmodes/idlw-shell.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from progmodes/idlw-shell.el
(autoload 'idlwave-shell "idlw-shell" "\
@@ -13550,7 +13766,7 @@ See also the variable `idlwave-shell-prompt-pattern'.
;;;***
;;;### (autoloads (idlwave-mode) "idlwave" "progmodes/idlwave.el"
-;;;;;; (19813 16320))
+;;;;;; (19863 8742))
;;; Generated autoloads from progmodes/idlwave.el
(autoload 'idlwave-mode "idlwave" "\
@@ -13684,8 +13900,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" (19752
-;;;;;; 41642))
+;;;;;; ido-switch-buffer ido-mode ido-mode) "ido" "ido.el" (19886
+;;;;;; 45771))
;;; Generated autoloads from ido.el
(defvar ido-mode nil "\
@@ -13703,8 +13919,8 @@ use either \\[customize] or the function `ido-mode'.")
(custom-autoload 'ido-mode "ido" nil)
(autoload 'ido-mode "ido" "\
-Toggle ido speed-ups on or off.
-With ARG, turn ido speed-up on if arg is positive, off otherwise.
+Toggle ido mode on or off.
+With ARG, turn ido-mode on if arg is positive, off otherwise.
Turning on ido-mode will remap (via a minor-mode keymap) the default
keybindings for the `find-file' and `switch-to-buffer' families of
commands to the ido versions of these functions.
@@ -13931,8 +14147,8 @@ Ido replacement for the built-in `completing-read'.
Read a string in the minibuffer with ido-style completion.
PROMPT is a string to prompt with; normally it ends in a colon and a space.
CHOICES is a list of strings which are the possible completions.
-PREDICATE is currently ignored; it is included to be compatible
- with `completing-read'.
+PREDICATE and INHERIT-INPUT-METHOD is currently ignored; it is included
+ to be compatible with `completing-read'.
If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless
the input is (or completes to) an element of CHOICES or is null.
If the input is null, `ido-completing-read' returns DEF, or an empty
@@ -13942,11 +14158,11 @@ If INITIAL-INPUT is non-nil, insert it in the minibuffer initially,
HIST, if non-nil, specifies a history list.
DEF, if non-nil, is the default value.
-\(fn PROMPT CHOICES &optional PREDICATE REQUIRE-MATCH INITIAL-INPUT HIST DEF)" nil nil)
+\(fn PROMPT CHOICES &optional PREDICATE REQUIRE-MATCH INITIAL-INPUT HIST DEF INHERIT-INPUT-METHOD)" nil nil)
;;;***
-;;;### (autoloads (ielm) "ielm" "ielm.el" (19752 41642))
+;;;### (autoloads (ielm) "ielm" "ielm.el" (19886 45771))
;;; Generated autoloads from ielm.el
(add-hook 'same-window-buffer-names (purecopy "*ielm*"))
@@ -13958,14 +14174,10 @@ Switches to the buffer `*ielm*', or creates it if it does not exist.
;;;***
-;;;### (autoloads (iimage-mode turn-on-iimage-mode) "iimage" "iimage.el"
-;;;;;; (19752 41642))
+;;;### (autoloads (iimage-mode) "iimage" "iimage.el" (19845 45374))
;;; 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.
@@ -13974,11 +14186,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" (19752 41642))
+;;;### (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"
+;;;;;; (19849 29307))
;;; Generated autoloads from image.el
(autoload 'image-type-from-data "image" "\
@@ -14152,6 +14365,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
@@ -14160,14 +14396,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" (19779 1536))
+;;;;;; image-dired-dired-with-window-configuration image-dired-dired-toggle-marked-thumbs)
+;;;;;; "image-dired" "image-dired.el" (19886 45771))
;;; 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.
@@ -14295,7 +14535,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" (19752 41642))
+;;;;;; "image-file.el" (19845 45374))
;;; 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")) "\
@@ -14357,17 +14597,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" (19806 64998))
+;;;;;; image-mode) "image-mode" "image-mode.el" (19890 42850))
;;; 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.
@@ -14400,14 +14631,14 @@ on these modes.
\(fn)" t nil)
(autoload 'image-bookmark-jump "image-mode" "\
-Not documented
+
\(fn BMK)" nil nil)
;;;***
;;;### (autoloads (imenu imenu-add-menubar-index imenu-add-to-menubar
-;;;;;; imenu-sort-function) "imenu" "imenu.el" (19752 41642))
+;;;;;; imenu-sort-function) "imenu" "imenu.el" (19845 45374))
;;; Generated autoloads from imenu.el
(defvar imenu-sort-function nil "\
@@ -14524,7 +14755,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" (19752 41642))
+;;;;;; "ind-util" "language/ind-util.el" (19845 45374))
;;; Generated autoloads from language/ind-util.el
(autoload 'indian-compose-region "ind-util" "\
@@ -14533,17 +14764,17 @@ Compose the region according to `composition-function-table'.
\(fn FROM TO)" t nil)
(autoload 'indian-compose-string "ind-util" "\
-Not documented
+
\(fn STRING)" nil nil)
(autoload 'in-is13194-post-read-conversion "ind-util" "\
-Not documented
+
\(fn LEN)" nil nil)
(autoload 'in-is13194-pre-write-conversion "ind-util" "\
-Not documented
+
\(fn FROM TO)" nil nil)
@@ -14556,7 +14787,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" (19752 41642))
+;;;;;; "progmodes/inf-lisp.el" (19845 45374))
;;; Generated autoloads from progmodes/inf-lisp.el
(defvar inferior-lisp-filter-regexp (purecopy "\\`\\s *\\(:\\(\\w\\|\\s_\\)\\)?\\s *\\'") "\
@@ -14620,11 +14851,11 @@ of `inferior-lisp-program'). Runs the hooks from
;;;***
-;;;### (autoloads (Info-bookmark-jump Info-speedbar-browser Info-goto-emacs-key-command-node
-;;;;;; 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"
-;;;;;; (19752 41642))
+;;;### (autoloads (info-display-manual Info-bookmark-jump Info-speedbar-browser
+;;;;;; Info-goto-emacs-key-command-node 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" (19867 52471))
;;; Generated autoloads from info.el
(autoload 'info-other-window "info" "\
@@ -14699,8 +14930,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 of 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.
@@ -14764,7 +14998,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" "\
@@ -14799,11 +15033,16 @@ type returned by `Info-bookmark-make-record', which see.
\(fn BMK)" nil nil)
+(autoload 'info-display-manual "info" "\
+Go to Info buffer that displays MANUAL, creating it if none already exists.
+
+\(fn MANUAL)" t nil)
+
;;;***
;;;### (autoloads (info-complete-file info-complete-symbol info-lookup-file
;;;;;; info-lookup-symbol info-lookup-reset) "info-look" "info-look.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from info-look.el
(autoload 'info-lookup-reset "info-look" "\
@@ -14850,35 +15089,92 @@ Perform completion on file preceding point.
;;;***
-;;;### (autoloads (info-xref-check-all-custom info-xref-check-all
-;;;;;; info-xref-check) "info-xref" "info-xref.el" (19752 41642))
+;;;### (autoloads (info-xref-docstrings info-xref-check-all-custom
+;;;;;; info-xref-check-all info-xref-check) "info-xref" "info-xref.el"
+;;;;;; (19886 45771))
;;; Generated autoloads from info-xref.el
(autoload 'info-xref-check "info-xref" "\
Check external references in FILENAME, an info document.
+Interactively from an `Info-mode' or `texinfo-mode' buffer the
+current info file is the default.
+
+Results are shown in a `compilation-mode' buffer. The format is
+a bit rough, but there shouldn't be many problems normally. The
+file:line:column: is the info document, but of course normally
+any correction should be made in the original .texi file.
+Finding the right place in the .texi is a manual process.
+
+When a target info file doesn't exist there's obviously no way to
+validate node references within it. A message is given for
+missing target files once per source document. It could be
+simply that you don't have the target installed, or it could be a
+mistake in the reference.
+
+Indirect info files are understood, just pass the top-level
+foo.info to `info-xref-check' and it traverses all sub-files.
+Compressed info files are accepted too as usual for `Info-mode'.
+
+\"makeinfo\" checks references internal to an info document, but
+not external references, which makes it rather easy for mistakes
+to creep in or node name changes to go unnoticed.
+`Info-validate' doesn't check external references either.
\(fn FILENAME)" t nil)
(autoload 'info-xref-check-all "info-xref" "\
-Check external references in all info documents in the usual path.
-The usual path is `Info-directory-list' and `Info-additional-directory-list'.
+Check external references in all info documents in the info path.
+`Info-directory-list' and `Info-additional-directory-list' are
+the info paths. See `info-xref-check' for how each file is
+checked.
+
+The search for \"all\" info files is rather permissive, since
+info files don't necessarily have a \".info\" extension and in
+particular the Emacs manuals normally don't. If you have a
+source code directory in `Info-directory-list' then a lot of
+extraneous files might be read. This will be time consuming but
+should be harmless.
\(fn)" t nil)
(autoload 'info-xref-check-all-custom "info-xref" "\
Check info references in all customize groups and variables.
-`custom-manual' and `info-link' entries in the `custom-links' list are checked.
+Info references can be in `custom-manual' or `info-link' entries
+of the `custom-links' for a variable.
-`custom-load' autoloads for all symbols are loaded in order to get all the
-link information. This will be a lot of lisp packages loaded, and can take
-quite a while.
+Any `custom-load' autoloads in variables are loaded in order to
+get full link information. This will be a lot of Lisp packages
+and can take a long time.
\(fn)" t nil)
+(autoload 'info-xref-docstrings "info-xref" "\
+Check docstring info node references in source files.
+The given files are searched for docstring hyperlinks like
+
+ Info node `(elisp)Documentation Tips'
+
+and those links checked by attempting to visit the target nodes
+as per `info-xref-check' does.
+
+Interactively filenames are read as a wildcard pattern like
+\"foo*.el\", with the current file as a default. Usually this
+will be lisp sources, but anything with such hyperlinks can be
+checked, including the Emacs .c sources (or the etc/DOC file of
+all builtins).
+
+Because info node hyperlinks are found by a simple regexp search
+in the files, the Lisp code checked doesn't have to be loaded,
+and links can be in the file commentary or elsewhere too. Even
+.elc files can usually be checked successfully if you don't have
+the sources handy.
+
+\(fn FILENAME-LIST)" t nil)
+
;;;***
;;;### (autoloads (batch-info-validate Info-validate Info-split Info-split-threshold
-;;;;;; Info-tagify) "informat" "informat.el" (19752 41642))
+;;;;;; Info-tagify) "informat" "informat.el" (19886 45771))
;;; Generated autoloads from informat.el
(autoload 'Info-tagify "informat" "\
@@ -14925,7 +15221,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from international/isearch-x.el
(autoload 'isearch-toggle-specified-input-method "isearch-x" "\
@@ -14939,14 +15235,14 @@ Toggle input method in interactive search.
\(fn)" t nil)
(autoload 'isearch-process-search-multibyte-characters "isearch-x" "\
-Not documented
+
\(fn LAST-CHAR)" nil nil)
;;;***
-;;;### (autoloads (isearchb-activate) "isearchb" "isearchb.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (isearchb-activate) "isearchb" "isearchb.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from isearchb.el
(autoload 'isearchb-activate "isearchb" "\
@@ -14962,7 +15258,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" (19752 41642))
+;;;;;; "international/iso-cvt.el" (19845 45374))
;;; Generated autoloads from international/iso-cvt.el
(autoload 'iso-spanish "iso-cvt" "\
@@ -15053,7 +15349,7 @@ Add submenus to the File menu, to convert to and from various formats.
;;;***
;;;### (autoloads nil "iso-transl" "international/iso-transl.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; 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)
@@ -15065,8 +15361,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" (19752 41642))
+;;;;;; "ispell" "textmodes/ispell.el" (19845 45374))
;;; 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 "\
@@ -15076,6 +15373,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 "\
@@ -15283,8 +15581,8 @@ You can bind this to the key C-c i in GNUS or mail by adding to
;;;***
-;;;### (autoloads (iswitchb-mode) "iswitchb" "iswitchb.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (iswitchb-mode) "iswitchb" "iswitchb.el" (19886
+;;;;;; 45771))
;;; Generated autoloads from iswitchb.el
(defvar iswitchb-mode nil "\
@@ -15309,11 +15607,11 @@ 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" (19752 41642))
+;;;;;; "japan-util" "language/japan-util.el" (19845 45374))
;;; Generated autoloads from language/japan-util.el
(autoload 'setup-japanese-environment-internal "japan-util" "\
-Not documented
+
\(fn)" nil nil)
@@ -15387,7 +15685,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" (19754 9185))
+;;;;;; "jka-compr.el" (19886 45771))
;;; Generated autoloads from jka-compr.el
(defvar jka-compr-inhibit nil "\
@@ -15396,7 +15694,7 @@ Lisp programs can bind this to t to do that.
It is not recommended to set this variable permanently to anything but nil.")
(autoload 'jka-compr-handler "jka-compr" "\
-Not documented
+
\(fn OPERATION &rest ARGS)" nil nil)
@@ -15410,16 +15708,12 @@ by `jka-compr-installed'.
;;;***
-;;;### (autoloads (js-mode) "js" "progmodes/js.el" (19770 11773))
+;;;### (autoloads (js-mode) "js" "progmodes/js.el" (19890 42850))
;;; Generated autoloads from progmodes/js.el
(autoload 'js-mode "js" "\
Major mode for editing JavaScript.
-Key bindings:
-
-\\{js-mode-map}
-
\(fn)" t nil)
(defalias 'javascript-mode 'js-mode)
@@ -15428,7 +15722,7 @@ Key bindings:
;;;### (autoloads (keypad-setup keypad-numlock-shifted-setup keypad-shifted-setup
;;;;;; keypad-numlock-setup keypad-setup) "keypad" "emulation/keypad.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from emulation/keypad.el
(defvar keypad-setup nil "\
@@ -15484,7 +15778,7 @@ the decimal key on the keypad is mapped to DECIMAL instead of `.'
;;;***
;;;### (autoloads (kinsoku) "kinsoku" "international/kinsoku.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from international/kinsoku.el
(autoload 'kinsoku "kinsoku" "\
@@ -15505,8 +15799,8 @@ the context of text formatting.
;;;***
-;;;### (autoloads (kkc-region) "kkc" "international/kkc.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (kkc-region) "kkc" "international/kkc.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from international/kkc.el
(defvar kkc-after-update-conversion-functions nil "\
@@ -15531,7 +15825,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" (19752 41642))
+;;;;;; "kmacro" "kmacro.el" (19886 45771))
;;; Generated autoloads from kmacro.el
(global-set-key "\C-x(" 'kmacro-start-macro)
(global-set-key "\C-x)" 'kmacro-end-macro)
@@ -15642,7 +15936,7 @@ If kbd macro currently being defined end it before activating it.
;;;***
;;;### (autoloads (setup-korean-environment-internal) "korea-util"
-;;;;;; "language/korea-util.el" (19752 41642))
+;;;;;; "language/korea-util.el" (19845 45374))
;;; Generated autoloads from language/korea-util.el
(defvar default-korean-keyboard (purecopy (if (string-match "3" (or (getenv "HANGUL_KEYBOARD_TYPE") "")) "3" "")) "\
@@ -15650,27 +15944,25 @@ If kbd macro currently being defined end it before activating it.
\"\" for 2, \"3\" for 3.")
(autoload 'setup-korean-environment-internal "korea-util" "\
-Not documented
+
\(fn)" nil nil)
;;;***
-;;;### (autoloads (lm lm-test-run) "landmark" "play/landmark.el"
-;;;;;; (19752 41642))
+;;;### (autoloads (landmark landmark-test-run) "landmark" "play/landmark.el"
+;;;;;; (19889 21967))
;;; Generated autoloads from play/landmark.el
-(defalias 'landmark-repeat 'lm-test-run)
+(defalias 'landmark-repeat 'landmark-test-run)
-(autoload 'lm-test-run "landmark" "\
-Run 100 Lm games, each time saving the weights from the previous game.
+(autoload 'landmark-test-run "landmark" "\
+Run 100 Landmark games, each time saving the weights from the previous game.
\(fn)" t nil)
-(defalias 'landmark 'lm)
-
-(autoload 'lm "landmark" "\
-Start or resume an Lm game.
+(autoload 'landmark "landmark" "\
+Start or resume an Landmark game.
If a game is in progress, this command allows you to resume it.
Here is the relation between prefix args and game options:
@@ -15681,7 +15973,7 @@ none / 1 | yes | no
3 | no | yes
4 | no | no
-You start by moving to a square and typing \\[lm-start-robot],
+You start by moving to a square and typing \\[landmark-start-robot],
if you did not use a prefix arg to ask for automatic start.
Use \\[describe-mode] for more info.
@@ -15691,11 +15983,11 @@ 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" (19752 41642))
+;;;;;; "lao-util" "language/lao-util.el" (19845 45374))
;;; Generated autoloads from language/lao-util.el
(autoload 'lao-compose-string "lao-util" "\
-Not documented
+
\(fn STR)" nil nil)
@@ -15717,12 +16009,12 @@ Transcribe Romanized Lao string STR to Lao character string.
\(fn STR)" nil nil)
(autoload 'lao-composition-function "lao-util" "\
-Not documented
+
\(fn GSTRING)" nil nil)
(autoload 'lao-compose-region "lao-util" "\
-Not documented
+
\(fn FROM TO)" t nil)
@@ -15730,7 +16022,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" (19752 41642))
+;;;;;; "latexenc" "international/latexenc.el" (19845 45374))
;;; 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))) "\
@@ -15762,7 +16054,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" (19752 41642))
+;;;;;; "latin1-disp" "international/latin1-disp.el" (19845 45374))
;;; Generated autoloads from international/latin1-disp.el
(defvar latin1-display nil "\
@@ -15804,15 +16096,9 @@ use either \\[customize] or the function `latin1-display'.")
;;;***
;;;### (autoloads (ld-script-mode) "ld-script" "progmodes/ld-script.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; 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
@@ -15821,7 +16107,7 @@ A major mode to edit GNU ld script files
;;;***
;;;### (autoloads (ledit-from-lisp-mode ledit-mode) "ledit" "ledit.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from ledit.el
(defconst ledit-save-files t "\
@@ -15850,13 +16136,13 @@ do (setq lisp-mode-hook 'ledit-from-lisp-mode)
\(fn)" t nil)
(autoload 'ledit-from-lisp-mode "ledit" "\
-Not documented
+
\(fn)" nil nil)
;;;***
-;;;### (autoloads (life) "life" "play/life.el" (19752 41642))
+;;;### (autoloads (life) "life" "play/life.el" (19845 45374))
;;; Generated autoloads from play/life.el
(autoload 'life "life" "\
@@ -15870,7 +16156,7 @@ generations (this defaults to 1).
;;;***
;;;### (autoloads (global-linum-mode linum-mode linum-format) "linum"
-;;;;;; "linum.el" (19752 41642))
+;;;;;; "linum.el" (19865 50420))
;;; Generated autoloads from linum.el
(defvar linum-format 'dynamic "\
@@ -15908,8 +16194,8 @@ See `linum-mode' for more information on Linum mode.
;;;***
-;;;### (autoloads (unload-feature) "loadhist" "loadhist.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (unload-feature) "loadhist" "loadhist.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from loadhist.el
(autoload 'unload-feature "loadhist" "\
@@ -15941,7 +16227,7 @@ something strange, such as redefining an Emacs function.
;;;***
;;;### (autoloads (locate-with-filter locate locate-ls-subdir-switches)
-;;;;;; "locate" "locate.el" (19752 41642))
+;;;;;; "locate" "locate.el" (19886 45771))
;;; Generated autoloads from locate.el
(defvar locate-ls-subdir-switches (purecopy "-al") "\
@@ -15993,8 +16279,8 @@ except that FILTER is not optional.
;;;***
-;;;### (autoloads (log-edit) "log-edit" "log-edit.el" (19806 64998))
-;;; Generated autoloads from log-edit.el
+;;;### (autoloads (log-edit) "log-edit" "vc/log-edit.el" (19870 57559))
+;;; Generated autoloads from vc/log-edit.el
(autoload 'log-edit "log-edit" "\
Setup a buffer to enter a log message.
@@ -16020,9 +16306,9 @@ uses the current buffer.
;;;***
-;;;### (autoloads (log-view-mode) "log-view" "log-view.el" (19752
-;;;;;; 41642))
-;;; Generated autoloads from log-view.el
+;;;### (autoloads (log-view-mode) "log-view" "vc/log-view.el" (19863
+;;;;;; 8742))
+;;; Generated autoloads from vc/log-view.el
(autoload 'log-view-mode "log-view" "\
Major mode for browsing CVS log output.
@@ -16031,8 +16317,8 @@ Major mode for browsing CVS log output.
;;;***
-;;;### (autoloads (longlines-mode) "longlines" "longlines.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (longlines-mode) "longlines" "longlines.el" (19886
+;;;;;; 45771))
;;; Generated autoloads from longlines.el
(autoload 'longlines-mode "longlines" "\
@@ -16053,8 +16339,8 @@ are indicated with a symbol.
;;;***
;;;### (autoloads (print-region lpr-region print-buffer lpr-buffer
-;;;;;; lpr-command lpr-switches printer-name) "lpr" "lpr.el" (19752
-;;;;;; 41642))
+;;;;;; lpr-command lpr-switches printer-name) "lpr" "lpr.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from lpr.el
(defvar lpr-windows-system (memq system-type '(ms-dos windows-nt)))
@@ -16148,7 +16434,7 @@ for further customization of the printer command.
;;;***
;;;### (autoloads (ls-lisp-support-shell-wildcards) "ls-lisp" "ls-lisp.el"
-;;;;;; (19752 41642))
+;;;;;; (19886 45771))
;;; Generated autoloads from ls-lisp.el
(defvar ls-lisp-support-shell-wildcards t "\
@@ -16159,8 +16445,8 @@ Otherwise they are treated as Emacs regexps (for backward compatibility).")
;;;***
-;;;### (autoloads (lunar-phases) "lunar" "calendar/lunar.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (lunar-phases) "lunar" "calendar/lunar.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from calendar/lunar.el
(autoload 'lunar-phases "lunar" "\
@@ -16174,20 +16460,19 @@ This function is suitable for execution in a .emacs file.
;;;***
-;;;### (autoloads (m4-mode) "m4-mode" "progmodes/m4-mode.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (m4-mode) "m4-mode" "progmodes/m4-mode.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from progmodes/m4-mode.el
(autoload 'm4-mode "m4-mode" "\
A major mode to edit m4 macro files.
-\\{m4-mode-map}
\(fn)" t nil)
;;;***
;;;### (autoloads (macroexpand-all) "macroexp" "emacs-lisp/macroexp.el"
-;;;;;; (19752 41642))
+;;;;;; (19863 8742))
;;; Generated autoloads from emacs-lisp/macroexp.el
(autoload 'macroexpand-all "macroexp" "\
@@ -16201,7 +16486,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" (19752 41642))
+;;;;;; name-last-kbd-macro) "macros" "macros.el" (19886 45771))
;;; Generated autoloads from macros.el
(autoload 'name-last-kbd-macro "macros" "\
@@ -16290,7 +16575,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" (19752 41642))
+;;;;;; "mail/mail-extr.el" (19845 45374))
;;; Generated autoloads from mail/mail-extr.el
(autoload 'mail-extract-address-components "mail-extr" "\
@@ -16322,7 +16607,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from mail/mail-hist.el
(autoload 'mail-hist-define-keys "mail-hist" "\
@@ -16331,7 +16616,7 @@ Define keys for accessing mail header history. For use in hooks.
\(fn)" nil nil)
(autoload 'mail-hist-enable "mail-hist" "\
-Not documented
+
\(fn)" nil nil)
@@ -16353,8 +16638,8 @@ 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"
-;;;;;; (19744 33840))
+;;;;;; mail-file-babyl-p mail-dont-reply-to-names mail-use-rfc822)
+;;;;;; "mail-utils" "mail/mail-utils.el" (19845 45374))
;;; Generated autoloads from mail/mail-utils.el
(defvar mail-use-rfc822 nil "\
@@ -16364,6 +16649,16 @@ often correct parser.")
(custom-autoload 'mail-use-rfc822 "mail-utils" t)
+(defvar mail-dont-reply-to-names nil "\
+Regexp specifying addresses to prune from a reply message.
+If this is nil, it is set the first time you compose a reply, to
+a value which excludes your own email address.
+
+Matching addresses are excluded from the CC field in replies, and
+also the To field, unless this would leave an empty To field.")
+
+(custom-autoload 'mail-dont-reply-to-names "mail-utils" t)
+
(autoload 'mail-file-babyl-p "mail-utils" "\
Return non-nil if FILE is a Babyl file.
@@ -16416,8 +16711,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" (19752
-;;;;;; 41642))
+;;;;;; mail-abbrevs-mode) "mailabbrev" "mail/mailabbrev.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from mail/mailabbrev.el
(defvar mail-abbrevs-mode nil "\
@@ -16458,9 +16753,9 @@ double-quotes.
;;;***
-;;;### (autoloads (mail-complete define-mail-alias expand-mail-aliases
-;;;;;; mail-complete-style) "mailalias" "mail/mailalias.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (mail-complete mail-completion-at-point-function
+;;;;;; define-mail-alias expand-mail-aliases mail-complete-style)
+;;;;;; "mailalias" "mail/mailalias.el" (19881 27850))
;;; Generated autoloads from mail/mailalias.el
(defvar mail-complete-style 'angles "\
@@ -16496,17 +16791,23 @@ if it is quoted with double-quotes.
\(fn NAME DEFINITION &optional FROM-MAILRC-FILE)" t nil)
+(autoload 'mail-completion-at-point-function "mailalias" "\
+Compute completion data for mail aliases.
+For use on `completion-at-point-functions'.
+
+\(fn)" nil nil)
+
(autoload 'mail-complete "mailalias" "\
Perform completion on header field or word preceding point.
Completable headers are according to `mail-complete-alist'. If none matches
-current header, calls `mail-complete-function' and passes prefix arg if any.
+current header, calls `mail-complete-function' and passes prefix ARG if any.
\(fn ARG)" t nil)
;;;***
;;;### (autoloads (mailclient-send-it) "mailclient" "mail/mailclient.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from mail/mailclient.el
(autoload 'mailclient-send-it "mailclient" "\
@@ -16520,7 +16821,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" (19752 41642))
+;;;;;; "make-mode" "progmodes/make-mode.el" (19890 42850))
;;; Generated autoloads from progmodes/make-mode.el
(autoload 'makefile-mode "make-mode" "\
@@ -16637,8 +16938,8 @@ An adapted `makefile-mode' that knows about imake.
;;;***
-;;;### (autoloads (make-command-summary) "makesum" "makesum.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (make-command-summary) "makesum" "makesum.el" (19886
+;;;;;; 45771))
;;; Generated autoloads from makesum.el
(autoload 'make-command-summary "makesum" "\
@@ -16649,7 +16950,8 @@ Previous contents of that buffer are killed first.
;;;***
-;;;### (autoloads (man-follow man) "man" "man.el" (19752 41642))
+;;;### (autoloads (Man-bookmark-jump man-follow man) "man" "man.el"
+;;;;;; (19870 57559))
;;; Generated autoloads from man.el
(defalias 'manual-entry 'man)
@@ -16696,9 +16998,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" (19752 41642))
+;;;### (autoloads (master-mode) "master" "master.el" (19845 45374))
;;; Generated autoloads from master.el
(autoload 'master-mode "master" "\
@@ -16721,7 +17028,7 @@ yourself the value of `master-of' by calling `master-show-slave'.
;;;***
;;;### (autoloads (minibuffer-depth-indicate-mode) "mb-depth" "mb-depth.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from mb-depth.el
(defvar minibuffer-depth-indicate-mode nil "\
@@ -16752,7 +17059,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" (19757 55474))
+;;;;;; "gnus/message.el" (19881 27850))
;;; 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)
@@ -16804,7 +17111,7 @@ OTHER-HEADERS is an alist of header/value pairs. CONTINUE says whether
to continue editing a message already being composed. SWITCH-FUNCTION
is a function used to switch to and display the mail buffer.
-\(fn &optional TO SUBJECT OTHER-HEADERS CONTINUE SWITCH-FUNCTION YANK-ACTION SEND-ACTIONS)" t nil)
+\(fn &optional TO SUBJECT OTHER-HEADERS CONTINUE SWITCH-FUNCTION YANK-ACTION SEND-ACTIONS RETURN-ACTION &rest IGNORED)" t nil)
(autoload 'message-news "message" "\
Start editing a news article to be sent.
@@ -16814,7 +17121,7 @@ Start editing a news article to be sent.
(autoload 'message-reply "message" "\
Start editing a reply to the article in the current buffer.
-\(fn &optional TO-ADDRESS WIDE)" t nil)
+\(fn &optional TO-ADDRESS WIDE SWITCH-FUNCTION)" t nil)
(autoload 'message-wide-reply "message" "\
Make a \"wide\" reply to the message in the current buffer.
@@ -16853,12 +17160,12 @@ Optional DIGEST will use digest to forward.
\(fn &optional NEWS DIGEST)" t nil)
(autoload 'message-forward-make-body "message" "\
-Not documented
+
\(fn FORWARD-BUFFER &optional DIGEST)" nil nil)
(autoload 'message-forward-rmail-make-body "message" "\
-Not documented
+
\(fn FORWARD-BUFFER)" nil nil)
@@ -16918,26 +17225,16 @@ which specify the range to operate on.
;;;***
;;;### (autoloads (metapost-mode metafont-mode) "meta-mode" "progmodes/meta-mode.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from progmodes/meta-mode.el
(autoload 'metafont-mode "meta-mode" "\
Major mode for editing Metafont sources.
-Special commands:
-\\{meta-mode-map}
-
-Turning on Metafont mode calls the value of the variables
-`meta-common-mode-hook' and `metafont-mode-hook'.
\(fn)" t nil)
(autoload 'metapost-mode "meta-mode" "\
Major mode for editing MetaPost sources.
-Special commands:
-\\{meta-mode-map}
-
-Turning on MetaPost mode calls the value of the variable
-`meta-common-mode-hook' and `metafont-mode-hook'.
\(fn)" t nil)
@@ -16945,7 +17242,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from mail/metamail.el
(autoload 'metamail-interpret-header "metamail" "\
@@ -16990,7 +17287,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" (19752 41642))
+;;;;;; "mh-e/mh-comp.el" (19845 45374))
;;; Generated autoloads from mh-e/mh-comp.el
(autoload 'mh-smail "mh-comp" "\
@@ -17036,10 +17333,10 @@ OTHER-HEADERS is an alist specifying additional header fields.
Elements look like (HEADER . VALUE) where both HEADER and VALUE
are strings.
-CONTINUE, SWITCH-FUNCTION, YANK-ACTION and SEND-ACTIONS are
-ignored.
+CONTINUE, SWITCH-FUNCTION, YANK-ACTION, SEND-ACTIONS, and
+RETURN-ACTION are ignored.
-\(fn &optional TO SUBJECT OTHER-HEADERS CONTINUE SWITCH-FUNCTION YANK-ACTION SEND-ACTIONS)" nil nil)
+\(fn &optional TO SUBJECT OTHER-HEADERS CONTINUE SWITCH-FUNCTION YANK-ACTION SEND-ACTIONS RETURN-ACTION &rest IGNORED)" nil nil)
(autoload 'mh-send-letter "mh-comp" "\
Save draft and send message.
@@ -17080,7 +17377,7 @@ delete the draft message.
;;;***
-;;;### (autoloads (mh-version) "mh-e" "mh-e/mh-e.el" (19752 41642))
+;;;### (autoloads (mh-version) "mh-e" "mh-e/mh-e.el" (19898 36953))
;;; Generated autoloads from mh-e/mh-e.el
(put 'mh-progs 'risky-local-variable t)
@@ -17097,7 +17394,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" (19752 41642))
+;;;;;; "mh-e/mh-folder.el" (19845 45374))
;;; Generated autoloads from mh-e/mh-folder.el
(autoload 'mh-rmail "mh-folder" "\
@@ -17179,7 +17476,7 @@ perform the operation on all messages in that region.
;;;***
;;;### (autoloads (midnight-delay-set clean-buffer-list) "midnight"
-;;;;;; "midnight.el" (19752 41642))
+;;;;;; "midnight.el" (19853 59245))
;;; Generated autoloads from midnight.el
(autoload 'clean-buffer-list "midnight" "\
@@ -17206,7 +17503,7 @@ to its second argument TM.
;;;***
;;;### (autoloads (minibuffer-electric-default-mode) "minibuf-eldef"
-;;;;;; "minibuf-eldef.el" (19752 41642))
+;;;;;; "minibuf-eldef.el" (19845 45374))
;;; Generated autoloads from minibuf-eldef.el
(defvar minibuffer-electric-default-mode nil "\
@@ -17233,7 +17530,7 @@ Returns non-nil if the new state is enabled.
;;;***
-;;;### (autoloads (butterfly) "misc" "misc.el" (19752 41642))
+;;;### (autoloads (butterfly) "misc" "misc.el" (19845 45374))
;;; Generated autoloads from misc.el
(autoload 'butterfly "misc" "\
@@ -17252,7 +17549,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" (19752 41642))
+;;;;;; "misearch" "misearch.el" (19886 45771))
;;; Generated autoloads from misearch.el
(add-hook 'isearch-mode-hook 'multi-isearch-setup)
@@ -17334,21 +17631,18 @@ whose file names match the specified wildcard.
;;;***
;;;### (autoloads (mixal-mode) "mixal-mode" "progmodes/mixal-mode.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from progmodes/mixal-mode.el
(autoload 'mixal-mode "mixal-mode" "\
Major mode for the mixal asm language.
-\\{mixal-mode-map}
\(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" (19752 41642))
+;;;;;; "mm-extern" "gnus/mm-extern.el" (19845 45374))
;;; Generated autoloads from gnus/mm-extern.el
(autoload 'mm-extern-cache-contents "mm-extern" "\
@@ -17367,7 +17661,7 @@ If NO-DISPLAY is nil, display it. Otherwise, do nothing after replacing.
;;;***
;;;### (autoloads (mm-inline-partial) "mm-partial" "gnus/mm-partial.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from gnus/mm-partial.el
(autoload 'mm-inline-partial "mm-partial" "\
@@ -17381,7 +17675,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" (19752 41642))
+;;;;;; "mm-url" "gnus/mm-url.el" (19877 30798))
;;; Generated autoloads from gnus/mm-url.el
(autoload 'mm-url-insert-file-contents "mm-url" "\
@@ -17398,7 +17692,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" (19752 41642))
+;;;;;; "gnus/mm-uu.el" (19845 45374))
;;; Generated autoloads from gnus/mm-uu.el
(autoload 'mm-uu-dissect "mm-uu" "\
@@ -17418,16 +17712,16 @@ Assume text has been decoded if DECODED is non-nil.
;;;***
;;;### (autoloads (mml1991-sign mml1991-encrypt) "mml1991" "gnus/mml1991.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from gnus/mml1991.el
(autoload 'mml1991-encrypt "mml1991" "\
-Not documented
+
\(fn CONT &optional SIGN)" nil nil)
(autoload 'mml1991-sign "mml1991" "\
-Not documented
+
\(fn CONT)" nil nil)
@@ -17435,51 +17729,53 @@ Not documented
;;;### (autoloads (mml2015-self-encrypt mml2015-sign mml2015-encrypt
;;;;;; mml2015-verify-test mml2015-verify mml2015-decrypt-test mml2015-decrypt)
-;;;;;; "mml2015" "gnus/mml2015.el" (19752 41642))
+;;;;;; "mml2015" "gnus/mml2015.el" (19845 45374))
;;; Generated autoloads from gnus/mml2015.el
(autoload 'mml2015-decrypt "mml2015" "\
-Not documented
+
\(fn HANDLE CTL)" nil nil)
(autoload 'mml2015-decrypt-test "mml2015" "\
-Not documented
+
\(fn HANDLE CTL)" nil nil)
(autoload 'mml2015-verify "mml2015" "\
-Not documented
+
\(fn HANDLE CTL)" nil nil)
(autoload 'mml2015-verify-test "mml2015" "\
-Not documented
+
\(fn HANDLE CTL)" nil nil)
(autoload 'mml2015-encrypt "mml2015" "\
-Not documented
+
\(fn CONT &optional SIGN)" nil nil)
(autoload 'mml2015-sign "mml2015" "\
-Not documented
+
\(fn CONT)" nil nil)
(autoload 'mml2015-self-encrypt "mml2015" "\
-Not documented
+
\(fn)" nil nil)
;;;***
-;;;### (autoloads (modula-2-mode) "modula2" "progmodes/modula2.el"
-;;;;;; (19636 58496))
+;;;### (autoloads (m2-mode) "modula2" "progmodes/modula2.el" (19845
+;;;;;; 45374))
;;; 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.
@@ -17507,8 +17803,8 @@ followed by the first character of the construct.
;;;***
-;;;### (autoloads (unmorse-region morse-region) "morse" "play/morse.el"
-;;;;;; (19752 41642))
+;;;### (autoloads (denato-region nato-region unmorse-region morse-region)
+;;;;;; "morse" "play/morse.el" (19869 36706))
;;; Generated autoloads from play/morse.el
(autoload 'morse-region "morse" "\
@@ -17521,10 +17817,20 @@ Convert morse coded text in region to ordinary ASCII text.
\(fn BEG END)" t nil)
+(autoload 'nato-region "morse" "\
+Convert all text in a given region to NATO phonetic alphabet.
+
+\(fn BEG END)" t nil)
+
+(autoload 'denato-region "morse" "\
+Convert NATO phonetic alphabet in region to ordinary ASCII text.
+
+\(fn BEG END)" t nil)
+
;;;***
;;;### (autoloads (mouse-drag-drag mouse-drag-throw) "mouse-drag"
-;;;;;; "mouse-drag.el" (19752 41642))
+;;;;;; "mouse-drag.el" (19890 42850))
;;; Generated autoloads from mouse-drag.el
(autoload 'mouse-drag-throw "mouse-drag" "\
@@ -17535,7 +17841,7 @@ from the original mouse click to the current mouse location. Try it;
you'll like it. It's easier to observe than to explain.
If the mouse is clicked and released in the same place of time we
-assume that the user didn't want to scdebugroll but wanted to whatever
+assume that the user didn't want to scroll but wanted to whatever
mouse-2 used to do, so we pass it through.
Throw scrolling was inspired (but is not identical to) the \"hand\"
@@ -17571,8 +17877,8 @@ To test this function, evaluate:
;;;***
-;;;### (autoloads (mouse-sel-mode) "mouse-sel" "mouse-sel.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (mouse-sel-mode) "mouse-sel" "mouse-sel.el" (19886
+;;;;;; 45771))
;;; Generated autoloads from mouse-sel.el
(defvar mouse-sel-mode nil "\
@@ -17624,7 +17930,7 @@ primary selection and region.
;;;***
-;;;### (autoloads (mpc) "mpc" "mpc.el" (19752 41642))
+;;;### (autoloads (mpc) "mpc" "mpc.el" (19863 8742))
;;; Generated autoloads from mpc.el
(autoload 'mpc "mpc" "\
@@ -17634,7 +17940,7 @@ Main entry point for MPC.
;;;***
-;;;### (autoloads (mpuz) "mpuz" "play/mpuz.el" (19752 41642))
+;;;### (autoloads (mpuz) "mpuz" "play/mpuz.el" (19890 42850))
;;; Generated autoloads from play/mpuz.el
(autoload 'mpuz "mpuz" "\
@@ -17644,7 +17950,7 @@ Multiplication puzzle with GNU Emacs.
;;;***
-;;;### (autoloads (msb-mode) "msb" "msb.el" (19777 41324))
+;;;### (autoloads (msb-mode) "msb" "msb.el" (19845 45374))
;;; Generated autoloads from msb.el
(defvar msb-mode nil "\
@@ -17671,7 +17977,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from international/mule-diag.el
(autoload 'list-character-sets "mule-diag" "\
@@ -17808,7 +18114,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" (19752 41642))
+;;;;;; "mule-util" "international/mule-util.el" (19845 45374))
;;; Generated autoloads from international/mule-util.el
(autoload 'string-to-sequence "mule-util" "\
@@ -17913,7 +18219,7 @@ Return the value of CODING-SYSTEM's `encode-translation-table' property.
(autoload 'with-coding-priority "mule-util" "\
Execute BODY like `progn' with CODING-SYSTEMS at the front of priority list.
-CODING-SYSTEMS is a list of coding systems. See `set-coding-priority'.
+CODING-SYSTEMS is a list of coding systems. See `set-coding-system-priority'.
This affects the implicit sorting of lists of coding sysems returned by
operations such as `find-coding-systems-region'.
@@ -17948,8 +18254,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" (19752
-;;;;;; 41642))
+;;;;;; iwconfig ifconfig) "net-utils" "net/net-utils.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from net/net-utils.el
(autoload 'ifconfig "net-utils" "\
@@ -18027,7 +18333,7 @@ from SEARCH-STRING. With argument, prompt for whois server.
\(fn ARG SEARCH-STRING)" t nil)
(autoload 'whois-reverse-lookup "net-utils" "\
-Not documented
+
\(fn)" t nil)
@@ -18043,12 +18349,96 @@ Open a network connection to HOST on PORT.
;;;***
+;;;### (autoloads (netrc-credentials) "netrc" "net/netrc.el" (19845
+;;;;;; 45374))
+;;; 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 (open-network-stream) "network-stream" "net/network-stream.el"
+;;;;;; (19893 19022))
+;;; Generated autoloads from net/network-stream.el
+
+(autoload 'open-network-stream "network-stream" "\
+Open a TCP connection to HOST, optionally with encryption.
+Normally, return a network process object; with a non-nil
+:return-list parameter, return a list instead (see below).
+Input and output work as for subprocesses; `delete-process'
+closes it.
+
+NAME is the name for the process. It is modified if necessary to
+ make it unique.
+BUFFER is a buffer or buffer name to associate with the process.
+ Process output goes at end of that buffer. BUFFER may be nil,
+ meaning that the process is not associated with any buffer.
+HOST is the name or IP address of the host to connect to.
+SERVICE is the name of the service desired, or an integer specifying
+ a port number to connect to.
+
+The remaining PARAMETERS should be a sequence of keywords and
+values:
+
+:type specifies the connection type, one of the following:
+ nil or `network'
+ -- Begin with an ordinary network connection, and if
+ the parameters :success and :capability-command
+ are also supplied, try to upgrade to an encrypted
+ connection via STARTTLS. Even if that
+ fails (e.g. if HOST does not support TLS), retain
+ an unencrypted connection.
+ `plain' -- An ordinary, unencrypted network connection.
+ `starttls' -- Begin with an ordinary connection, and try
+ upgrading via STARTTLS. If that fails for any
+ reason, drop the connection; in that case the
+ returned object is a killed process.
+ `tls' -- A TLS connection.
+ `ssl' -- Equivalent to `tls'.
+ `shell' -- A shell connection.
+
+:return-list specifies this function's return value.
+ If omitted or nil, return a process object. A non-nil means to
+ return (PROC . PROPS), where PROC is a process object and PROPS
+ is a plist of connection properties, with these keywords:
+ :greeting -- the greeting returned by HOST (a string), or nil.
+ :capabilities -- a string representing HOST's capabilities,
+ or nil if none could be found.
+ :type -- the resulting connection type; `plain' (unencrypted)
+ or `tls' (TLS-encrypted).
+
+:end-of-command specifies a regexp matching the end of a command.
+
+:success specifies a regexp matching a message indicating a
+ successful STARTTLS negotiation. For instance, the default
+ should be \"^3\" for an NNTP connection.
+
+:capability-command specifies a command used to query the HOST
+ for its capabilities. For instance, for IMAP this should be
+ \"1 CAPABILITY\\r\\n\".
+
+:starttls-function specifies a function for handling STARTTLS.
+ This function should take one parameter, the response to the
+ capability command, and should return the command to switch on
+ STARTTLS if the server supports STARTTLS, and nil otherwise.
+
+\(fn NAME BUFFER HOST SERVICE &rest PARAMETERS)" nil nil)
+
+(defalias 'open-protocol-stream 'open-network-stream)
+
+;;;***
+
;;;### (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" (19752 41642))
+;;;;;; "newcomment.el" (19863 8742))
;;; Generated autoloads from newcomment.el
(defalias 'indent-for-comment 'comment-indent)
@@ -18212,8 +18602,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'.
@@ -18248,7 +18638,7 @@ unless optional argument SOFT is non-nil.
;;;***
;;;### (autoloads (newsticker-start newsticker-running-p) "newst-backend"
-;;;;;; "net/newst-backend.el" (19752 41642))
+;;;;;; "net/newst-backend.el" (19845 45374))
;;; Generated autoloads from net/newst-backend.el
(autoload 'newsticker-running-p "newst-backend" "\
@@ -18270,7 +18660,7 @@ Run `newsticker-start-hook' if newsticker was not running already.
;;;***
;;;### (autoloads (newsticker-plainview) "newst-plainview" "net/newst-plainview.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from net/newst-plainview.el
(autoload 'newsticker-plainview "newst-plainview" "\
@@ -18281,7 +18671,7 @@ Start newsticker plainview.
;;;***
;;;### (autoloads (newsticker-show-news) "newst-reader" "net/newst-reader.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from net/newst-reader.el
(autoload 'newsticker-show-news "newst-reader" "\
@@ -18292,7 +18682,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" (19752 41642))
+;;;;;; "newst-ticker" "net/newst-ticker.el" (19845 45374))
;;; Generated autoloads from net/newst-ticker.el
(autoload 'newsticker-ticker-running-p "newst-ticker" "\
@@ -18313,7 +18703,7 @@ running already.
;;;***
;;;### (autoloads (newsticker-treeview) "newst-treeview" "net/newst-treeview.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from net/newst-treeview.el
(autoload 'newsticker-treeview "newst-treeview" "\
@@ -18324,7 +18714,7 @@ Start newsticker treeview.
;;;***
;;;### (autoloads (nndiary-generate-nov-databases) "nndiary" "gnus/nndiary.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from gnus/nndiary.el
(autoload 'nndiary-generate-nov-databases "nndiary" "\
@@ -18334,8 +18724,8 @@ Generate NOV databases in all nndiary directories.
;;;***
-;;;### (autoloads (nndoc-add-type) "nndoc" "gnus/nndoc.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (nndoc-add-type) "nndoc" "gnus/nndoc.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from gnus/nndoc.el
(autoload 'nndoc-add-type "nndoc" "\
@@ -18350,7 +18740,7 @@ symbol in the alist.
;;;***
;;;### (autoloads (nnfolder-generate-active-file) "nnfolder" "gnus/nnfolder.el"
-;;;;;; (19802 41007))
+;;;;;; (19845 45374))
;;; Generated autoloads from gnus/nnfolder.el
(autoload 'nnfolder-generate-active-file "nnfolder" "\
@@ -18361,20 +18751,8 @@ This command does not work if you use short group names.
;;;***
-;;;### (autoloads (nnkiboze-generate-groups) "nnkiboze" "gnus/nnkiboze.el"
-;;;;;; (19752 41642))
-;;; 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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from gnus/nnml.el
(autoload 'nnml-generate-nov-databases "nnml" "\
@@ -18384,29 +18762,8 @@ Generate NOV databases in all nnml directories.
;;;***
-;;;### (autoloads (nnsoup-revert-variables nnsoup-set-variables nnsoup-pack-replies)
-;;;;;; "nnsoup" "gnus/nnsoup.el" (19752 41642))
-;;; 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" (19752 41642))
+;;;;;; "novice" "novice.el" (19845 45374))
;;; Generated autoloads from novice.el
(defvar disabled-command-function 'disabled-command-function "\
@@ -18416,7 +18773,7 @@ If nil, the feature is disabled, i.e., all commands work normally.")
(define-obsolete-variable-alias 'disabled-command-hook 'disabled-command-function "22.1")
(autoload 'disabled-command-function "novice" "\
-Not documented
+
\(fn &optional CMD KEYS)" nil nil)
@@ -18439,7 +18796,7 @@ to future sessions.
;;;***
;;;### (autoloads (nroff-mode) "nroff-mode" "textmodes/nroff-mode.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from textmodes/nroff-mode.el
(autoload 'nroff-mode "nroff-mode" "\
@@ -18454,7 +18811,7 @@ closing requests for requests that are used in matched pairs.
;;;***
;;;### (autoloads (nxml-glyph-display-string) "nxml-glyph" "nxml/nxml-glyph.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from nxml/nxml-glyph.el
(autoload 'nxml-glyph-display-string "nxml-glyph" "\
@@ -18466,8 +18823,8 @@ Return nil if the face cannot display a glyph for N.
;;;***
-;;;### (autoloads (nxml-mode) "nxml-mode" "nxml/nxml-mode.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (nxml-mode) "nxml-mode" "nxml/nxml-mode.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from nxml/nxml-mode.el
(autoload 'nxml-mode "nxml-mode" "\
@@ -18529,7 +18886,7 @@ Many aspects this mode can be customized using
;;;***
;;;### (autoloads (nxml-enable-unicode-char-name-sets) "nxml-uchnm"
-;;;;;; "nxml/nxml-uchnm.el" (19752 41642))
+;;;;;; "nxml/nxml-uchnm.el" (19845 45374))
;;; Generated autoloads from nxml/nxml-uchnm.el
(autoload 'nxml-enable-unicode-char-name-sets "nxml-uchnm" "\
@@ -18541,8 +18898,277 @@ 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-map-src-blocks 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" (19845 45374))
+;;; Generated autoloads from org/ob.el
+
+(autoload 'org-babel-execute-safely-maybe "ob" "\
+
+
+\(fn)" nil nil)
+
+(autoload 'org-babel-execute-maybe "ob" "\
+
+
+\(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-map-src-blocks "ob" "\
+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
+
+\(fn FILE &rest BODY)" nil (quote macro))
+
+(put 'org-babel-map-src-blocks 'lisp-indent-function '1)
+
+(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"
+;;;;;; (19845 45374))
+;;; 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" (19845 45374))
+;;; 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"
+;;;;;; (19845 45374))
+;;; 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)" t 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"
-;;;;;; (19752 41642))
+;;;;;; (19894 39890))
;;; Generated autoloads from progmodes/octave-inf.el
(autoload 'inferior-octave "octave-inf" "\
@@ -18565,7 +19191,7 @@ startup file, `~/.emacs-octave'.
;;;***
;;;### (autoloads (octave-mode) "octave-mod" "progmodes/octave-mod.el"
-;;;;;; (19752 41642))
+;;;;;; (19894 39890))
;;; Generated autoloads from progmodes/octave-mod.el
(autoload 'octave-mode "octave-mod" "\
@@ -18596,14 +19222,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.
@@ -18656,13 +19274,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" (19813 31420))
+;;;;;; org-mode org-babel-do-load-languages) "org" "org/org.el"
+;;;;;; (19845 45374))
;;; 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.\"
@@ -18688,17 +19312,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
@@ -18824,14 +19448,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'.
@@ -18852,7 +19481,7 @@ information about your Org-mode version and configuration.
\(fn)" t nil)
(autoload 'org-require-autoloaded-modules "org" "\
-Not documented
+
\(fn)" t nil)
@@ -18873,7 +19502,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" (19813 31420))
+;;;;;; org-agenda) "org-agenda" "org/org-agenda.el" (19845 45374))
;;; Generated autoloads from org/org-agenda.el
(autoload 'org-agenda "org-agenda" "\
@@ -18917,7 +19546,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))
@@ -18927,7 +19556,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
@@ -18960,7 +19589,7 @@ agenda-day The day in the agenda where this is listed
\(fn CMD-KEY &rest PARAMETERS)" nil (quote macro))
(autoload 'org-store-agenda-views "org-agenda" "\
-Not documented
+
\(fn &rest PARAMETERS)" t nil)
@@ -18980,18 +19609,16 @@ This feature is considered obsolete, please use the TODO list or a block
agenda instead.
With a numeric prefix argument in an interactive call, the agenda will
-span INCLUDE-ALL days. Lisp programs should instead specify NDAYS to change
-the number of days. NDAYS defaults to `org-agenda-ndays'.
+span INCLUDE-ALL days. Lisp programs should instead specify SPAN to change
+the number of days. SPAN defaults to `org-agenda-span'.
START-DAY defaults to TODAY, or to the most recent match for the weekday
given in `org-agenda-start-on-weekday'.
-\(fn &optional INCLUDE-ALL START-DAY NDAYS)" t nil)
+\(fn &optional INCLUDE-ALL START-DAY SPAN)" 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
@@ -18999,28 +19626,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'.
@@ -19028,7 +19664,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
@@ -19047,7 +19683,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)
@@ -19056,27 +19691,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:
@@ -19100,7 +19716,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)
@@ -19136,7 +19752,7 @@ belonging to the \"Work\" category.
;;;### (autoloads (org-archive-subtree-default-with-confirmation
;;;;;; org-archive-subtree-default) "org-archive" "org/org-archive.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from org/org-archive.el
(autoload 'org-archive-subtree-default "org-archive" "\
@@ -19154,10 +19770,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" (19752 41642))
+;;;;;; 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" (19845
+;;;;;; 45374))
;;; 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'.
@@ -19208,8 +19846,8 @@ publishing directory.
;;;***
-;;;### (autoloads (org-attach) "org-attach" "org/org-attach.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (org-attach) "org-attach" "org/org-attach.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from org/org-attach.el
(autoload 'org-attach "org-attach" "\
@@ -19221,7 +19859,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from org/org-bbdb.el
(autoload 'org-bbdb-anniversaries "org-bbdb" "\
@@ -19231,8 +19869,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" (19845 45374))
+;;; 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" "\
+
+
+\(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" (19752 41642))
+;;;;;; "org-clock" "org/org-clock.el" (19845 45374))
;;; Generated autoloads from org/org-clock.el
(autoload 'org-get-clocktable "org-clock" "\
@@ -19243,16 +19919,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" (19845 45374))
+;;; 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" (19752 41642))
+;;;;;; "org-docbook" "org/org-docbook.el" (19845 45374))
;;; Generated autoloads from org/org-docbook.el
(autoload 'org-export-as-docbook-batch "org-docbook" "\
@@ -19329,7 +20019,7 @@ publishing directory.
;;;### (autoloads (org-insert-export-options-template org-export-as-org
;;;;;; org-export-visible org-export) "org-exp" "org/org-exp.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from org/org-exp.el
(autoload 'org-export "org-exp" "\
@@ -19339,7 +20029,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)
@@ -19347,12 +20037,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)
@@ -19386,8 +20076,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" (19752
-;;;;;; 41642))
+;;;;;; org-feed-update-all) "org-feed" "org/org-feed.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from org/org-feed.el
(autoload 'org-feed-update-all "org-feed" "\
@@ -19415,7 +20105,7 @@ Show the raw feed buffer of a feed.
;;;***
;;;### (autoloads (org-footnote-normalize org-footnote-action) "org-footnote"
-;;;;;; "org/org-footnote.el" (19752 41642))
+;;;;;; "org/org-footnote.el" (19845 45374))
;;; Generated autoloads from org/org-footnote.el
(autoload 'org-footnote-action "org-footnote" "\
@@ -19442,13 +20132,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" (19752 41642))
+;;;;;; "org/org-freemind.el" (19845 45374))
;;; 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.
@@ -19457,11 +20160,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)
@@ -19480,7 +20193,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" (19752 41642))
+;;;;;; "org/org-html.el" (19845 45374))
;;; Generated autoloads from org/org-html.el
(put 'org-export-html-style-include-default 'safe-local-variable 'booleanp)
@@ -19498,7 +20211,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)\"
@@ -19573,7 +20287,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"
-;;;;;; (19813 31420))
+;;;;;; (19845 45374))
;;; Generated autoloads from org/org-icalendar.el
(autoload 'org-export-icalendar-this-file "org-icalendar" "\
@@ -19584,7 +20298,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'.
@@ -19598,9 +20312,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" (19752 41642))
+;;;### (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"
+;;;;;; (19845 45374))
;;; Generated autoloads from org/org-id.el
(autoload 'org-id-get-create "org-id" "\
@@ -19661,10 +20376,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from org/org-indent.el
(autoload 'org-indent-mode "org-indent" "\
@@ -19679,7 +20399,7 @@ FIXME: How to update when broken?
;;;***
;;;### (autoloads (org-irc-store-link) "org-irc" "org/org-irc.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from org/org-irc.el
(autoload 'org-irc-store-link "org-irc" "\
@@ -19692,7 +20412,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from org/org-latex.el
(autoload 'org-export-as-latex-batch "org-latex" "\
@@ -19753,8 +20473,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)
@@ -19772,8 +20492,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" (19752
-;;;;;; 41642))
+;;;;;; org-mobile-push) "org-mobile" "org/org-mobile.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from org/org-mobile.el
(autoload 'org-mobile-push "org-mobile" "\
@@ -19798,11 +20518,11 @@ Create a file that contains all custom agenda views.
;;;***
;;;### (autoloads (org-plot/gnuplot) "org-plot" "org/org-plot.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; 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.
@@ -19812,7 +20532,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from org/org-publish.el
(defalias 'org-publish-project 'org-publish)
@@ -19846,7 +20566,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" (19752 41642))
+;;;;;; "org/org-remember.el" (19845 45374))
;;; Generated autoloads from org/org-remember.el
(autoload 'org-remember-insinuate "org-remember" "\
@@ -19874,9 +20594,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
@@ -19889,21 +20609,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
@@ -19921,7 +20642,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" (19813 31420))
+;;;;;; "org-table" "org/org-table.el" (19845 45374))
;;; Generated autoloads from org/org-table.el
(autoload 'turn-on-orgtbl "org-table" "\
@@ -19944,9 +20665,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" (19845 45374))
+;;; 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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from org/org-timer.el
(autoload 'org-timer-start "org-timer" "\
@@ -19965,12 +20713,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.
@@ -19983,14 +20734,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.
-\(fn MINUTES)" t nil)
+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.
+
+\(fn &optional OPT)" t nil)
;;;***
;;;### (autoloads (org-export-as-xoxo) "org-xoxo" "org/org-xoxo.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from org/org-xoxo.el
(autoload 'org-export-as-xoxo "org-xoxo" "\
@@ -20002,9 +20767,10 @@ The XOXO buffer is named *xoxo-<source buffer name>*
;;;***
;;;### (autoloads (outline-minor-mode outline-mode) "outline" "outline.el"
-;;;;;; (19752 41642))
+;;;;;; (19886 45771))
;;; Generated autoloads from outline.el
-(put 'outline-regexp 'safe-local-variable 'string-or-null-p)
+(put 'outline-regexp 'safe-local-variable 'stringp)
+(put 'outline-heading-end-regexp 'safe-local-variable 'stringp)
(autoload 'outline-mode "outline" "\
Set major mode for editing outlines with selective display.
@@ -20059,7 +20825,73 @@ See the command `outline-mode' for more information on this mode.
;;;***
-;;;### (autoloads (show-paren-mode) "paren" "paren.el" (19752 41642))
+;;;### (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"
+;;;;;; (19893 19022))
+;;; 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.
+This first fetches the updated list of packages before
+displaying, unless a prefix argument NO-FETCH is specified.
+The list is displayed in a buffer named `*Packages*'.
+
+\(fn &optional NO-FETCH)" t nil)
+
+(defalias 'package-list-packages 'list-packages)
+
+;;;***
+
+;;;### (autoloads (show-paren-mode) "paren" "paren.el" (19845 45374))
;;; Generated autoloads from paren.el
(defvar show-paren-mode nil "\
@@ -20084,7 +20916,7 @@ in `show-paren-style' after `show-paren-delay' seconds of Emacs idle time.
;;;***
;;;### (autoloads (parse-time-string) "parse-time" "calendar/parse-time.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from calendar/parse-time.el
(put 'parse-time-rules 'risky-local-variable t)
@@ -20097,8 +20929,8 @@ unknown are returned as nil.
;;;***
-;;;### (autoloads (pascal-mode) "pascal" "progmodes/pascal.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (pascal-mode) "pascal" "progmodes/pascal.el" (19899
+;;;;;; 57784))
;;; Generated autoloads from progmodes/pascal.el
(autoload 'pascal-mode "pascal" "\
@@ -20122,26 +20954,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.
@@ -20150,93 +20982,90 @@ no args, if that value is non-nil.
;;;***
-;;;### (autoloads (pc-bindings-mode) "pc-mode" "emulation/pc-mode.el"
-;;;;;; (19752 41642))
-;;; Generated autoloads from emulation/pc-mode.el
+;;;### (autoloads (password-in-cache-p password-cache-expiry password-cache)
+;;;;;; "password-cache" "password-cache.el" (19845 45374))
+;;; Generated autoloads from password-cache.el
-(autoload 'pc-bindings-mode "pc-mode" "\
-Set up certain key bindings for PC compatibility.
-The keys affected are:
-Delete (and its variants) delete forward instead of backward.
-C-Backspace kills backward a word (as C-Delete normally would).
-M-Backspace does undo.
-Home and End move to beginning and end of line
-C-Home and C-End move to beginning and end of buffer.
-C-Escape does list-buffers.
+(defvar password-cache t "\
+Whether to cache passwords.")
-\(fn)" t nil)
+(custom-autoload 'password-cache "password-cache" t)
-;;;***
-
-;;;### (autoloads (pc-selection-mode) "pc-select" "emulation/pc-select.el"
-;;;;;; (19752 41642))
-;;; Generated autoloads from emulation/pc-select.el
+(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'.")
-(defvar pc-selection-mode nil "\
-Non-nil if Pc-Selection mode is enabled.
-See the command `pc-selection-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 `pc-selection-mode'.")
+(custom-autoload 'password-cache-expiry "password-cache" t)
-(custom-autoload 'pc-selection-mode "pc-select" nil)
+(autoload 'password-in-cache-p "password-cache" "\
+Check if KEY is in the cache.
-(autoload 'pc-selection-mode "pc-select" "\
-Change mark behavior to emulate Motif, Mac or MS-Windows cut and paste style.
+\(fn KEY)" nil nil)
-This mode enables Delete Selection mode and Transient Mark mode.
+;;;***
+
+;;;### (autoloads (pcase-let pcase-let* pcase) "pcase" "emacs-lisp/pcase.el"
+;;;;;; (19863 8742))
+;;; Generated autoloads from emacs-lisp/pcase.el
-The arrow keys (and others) are bound to new functions
-which modify the status of the mark.
+(autoload 'pcase "pcase" "\
+Perform ML-style pattern matching on EXP.
+CASES is a list of elements of the form (UPATTERN CODE...).
-The ordinary arrow keys disable the mark.
-The shift-arrow keys move, leaving the mark behind.
+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.
+ (let UPAT EXP) matches if EXP matches UPAT.
+If a SYMBOL is used twice in the same pattern (i.e. the pattern is
+\"non-linear\"), then the second occurrence is turned into an `eq'uality test.
-C-LEFT and C-RIGHT move back or forward one word, disabling the mark.
-S-C-LEFT and S-C-RIGHT move back or forward one word, leaving the mark behind.
+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.
-M-LEFT and M-RIGHT move back or forward one word or sexp, disabling the mark.
-S-M-LEFT and S-M-RIGHT move back or forward one word or sexp, leaving the mark
-behind. To control whether these keys move word-wise or sexp-wise set the
-variable `pc-select-meta-moves-sexps' after loading pc-select.el but before
-turning PC Selection mode on.
+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))))
-C-DOWN and C-UP move back or forward a paragraph, disabling the mark.
-S-C-DOWN and S-C-UP move back or forward a paragraph, leaving the mark behind.
+\(fn EXP &rest CASES)" nil (quote macro))
-HOME moves to beginning of line, disabling the mark.
-S-HOME moves to beginning of line, leaving the mark behind.
-With Ctrl or Meta, these keys move to beginning of buffer instead.
+(put 'pcase 'lisp-indent-function '1)
-END moves to end of line, disabling the mark.
-S-END moves to end of line, leaving the mark behind.
-With Ctrl or Meta, these keys move to end of buffer instead.
+(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).
-PRIOR or PAGE-UP scrolls and disables the mark.
-S-PRIOR or S-PAGE-UP scrolls and leaves the mark behind.
+\(fn BINDINGS &rest BODY)" nil (quote macro))
-S-DELETE kills the region (`kill-region').
-S-INSERT yanks text from the kill ring (`yank').
-C-INSERT copies the region into the kill ring (`copy-region-as-kill').
+(put 'pcase-let* 'lisp-indent-function '1)
-In addition, certain other PC bindings are imitated (to avoid this, set
-the variable `pc-select-selection-keys-only' to t after loading pc-select.el
-but before calling PC Selection mode):
+(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).
- F6 other-window
- DELETE delete-char
- C-DELETE kill-line
- M-DELETE kill-word
- C-M-DELETE kill-sexp
- C-BACKSPACE backward-kill-word
- M-BACKSPACE undo
+\(fn BINDINGS &rest BODY)" nil (quote macro))
-\(fn &optional ARG)" t nil)
+(put 'pcase-let 'lisp-indent-function '1)
;;;***
-;;;### (autoloads (pcomplete/cvs) "pcmpl-cvs" "pcmpl-cvs.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (pcomplete/cvs) "pcmpl-cvs" "pcmpl-cvs.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from pcmpl-cvs.el
(autoload 'pcomplete/cvs "pcmpl-cvs" "\
@@ -20247,7 +21076,7 @@ Completion rules for the `cvs' command.
;;;***
;;;### (autoloads (pcomplete/tar pcomplete/make pcomplete/bzip2 pcomplete/gzip)
-;;;;;; "pcmpl-gnu" "pcmpl-gnu.el" (19752 41642))
+;;;;;; "pcmpl-gnu" "pcmpl-gnu.el" (19845 45374))
;;; Generated autoloads from pcmpl-gnu.el
(autoload 'pcomplete/gzip "pcmpl-gnu" "\
@@ -20275,7 +21104,7 @@ Completion for the GNU tar utility.
;;;***
;;;### (autoloads (pcomplete/mount pcomplete/umount pcomplete/kill)
-;;;;;; "pcmpl-linux" "pcmpl-linux.el" (19752 41642))
+;;;;;; "pcmpl-linux" "pcmpl-linux.el" (19845 45374))
;;; Generated autoloads from pcmpl-linux.el
(autoload 'pcomplete/kill "pcmpl-linux" "\
@@ -20295,8 +21124,8 @@ Completion for GNU/Linux `mount'.
;;;***
-;;;### (autoloads (pcomplete/rpm) "pcmpl-rpm" "pcmpl-rpm.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (pcomplete/rpm) "pcmpl-rpm" "pcmpl-rpm.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from pcmpl-rpm.el
(autoload 'pcomplete/rpm "pcmpl-rpm" "\
@@ -20308,7 +21137,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" (19752 41642))
+;;;;;; pcomplete/cd) "pcmpl-unix" "pcmpl-unix.el" (19845 45374))
;;; Generated autoloads from pcmpl-unix.el
(autoload 'pcomplete/cd "pcmpl-unix" "\
@@ -20365,8 +21194,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" (19786
-;;;;;; 56078))
+;;;;;; pcomplete-reverse pcomplete) "pcomplete" "pcomplete.el" (19899
+;;;;;; 57784))
;;; Generated autoloads from pcomplete.el
(autoload 'pcomplete "pcomplete" "\
@@ -20425,8 +21254,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" (19752 41642))
-;;; Generated autoloads from pcvs.el
+;;;;;; "vc/pcvs.el" (19845 45374))
+;;; Generated autoloads from vc/pcvs.el
(autoload 'cvs-checkout "pcvs" "\
Run a 'cvs checkout MODULES' in DIR.
@@ -20500,15 +21329,15 @@ The exact behavior is determined also by `cvs-dired-use-hook'." (when (stringp d
;;;***
-;;;### (autoloads nil "pcvs-defs" "pcvs-defs.el" (19752 41642))
-;;; Generated autoloads from pcvs-defs.el
+;;;### (autoloads nil "pcvs-defs" "vc/pcvs-defs.el" (19845 45374))
+;;; 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"
-;;;;;; (19752 41642))
+;;;;;; (19890 42850))
;;; Generated autoloads from progmodes/perl-mode.el
(put 'perl-indent-level 'safe-local-variable 'integerp)
(put 'perl-continued-statement-offset 'safe-local-variable 'integerp)
@@ -20569,155 +21398,8 @@ 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" (19752 41642))
-;;; Generated autoloads from pgg.el
-
-(autoload 'pgg-encrypt-region "pgg" "\
-Encrypt the current region between START and END for RCPTS.
-
-If optional argument SIGN is non-nil, do a combined sign and encrypt.
-
-If optional PASSPHRASE is not specified, it will be obtained from the
-passphrase cache or user.
-
-\(fn START END RCPTS &optional SIGN PASSPHRASE)" t nil)
-
-(autoload 'pgg-encrypt-symmetric-region "pgg" "\
-Encrypt the current region between START and END symmetric with passphrase.
-
-If optional PASSPHRASE is not specified, it will be obtained from the
-cache or user.
-
-\(fn START END &optional PASSPHRASE)" t nil)
-
-(autoload 'pgg-encrypt-symmetric "pgg" "\
-Encrypt the current buffer using a symmetric, rather than key-pair, cipher.
-
-If optional arguments START and END are specified, only encrypt within
-the region.
-
-If optional PASSPHRASE is not specified, it will be obtained from the
-passphrase cache or user.
-
-\(fn &optional START END PASSPHRASE)" t nil)
-
-(autoload 'pgg-encrypt "pgg" "\
-Encrypt the current buffer for RCPTS.
-
-If optional argument SIGN is non-nil, do a combined sign and encrypt.
-
-If optional arguments START and END are specified, only encrypt within
-the region.
-
-If optional PASSPHRASE is not specified, it will be obtained from the
-passphrase cache or user.
-
-\(fn RCPTS &optional SIGN START END PASSPHRASE)" t nil)
-
-(autoload 'pgg-decrypt-region "pgg" "\
-Decrypt the current region between START and END.
-
-If optional PASSPHRASE is not specified, it will be obtained from the
-passphrase cache or user.
-
-\(fn START END &optional PASSPHRASE)" t nil)
-
-(autoload 'pgg-decrypt "pgg" "\
-Decrypt the current buffer.
-
-If optional arguments START and END are specified, only decrypt within
-the region.
-
-If optional PASSPHRASE is not specified, it will be obtained from the
-passphrase cache or user.
-
-\(fn &optional START END PASSPHRASE)" t nil)
-
-(autoload 'pgg-sign-region "pgg" "\
-Make the signature from text between START and END.
-
-If the optional 3rd argument CLEARTEXT is non-nil, it does not create
-a detached signature.
-
-If this function is called interactively, CLEARTEXT is enabled
-and the output is displayed.
-
-If optional PASSPHRASE is not specified, it will be obtained from the
-passphrase cache or user.
-
-\(fn START END &optional CLEARTEXT PASSPHRASE)" t nil)
-
-(autoload 'pgg-sign "pgg" "\
-Sign the current buffer.
-
-If the optional argument CLEARTEXT is non-nil, it does not create a
-detached signature.
-
-If optional arguments START and END are specified, only sign data
-within the region.
-
-If this function is called interactively, CLEARTEXT is enabled
-and the output is displayed.
-
-If optional PASSPHRASE is not specified, it will be obtained from the
-passphrase cache or user.
-
-\(fn &optional CLEARTEXT START END PASSPHRASE)" t nil)
-
-(autoload 'pgg-verify-region "pgg" "\
-Verify the current region between START and END.
-If the optional 3rd argument SIGNATURE is non-nil, it is treated as
-the detached signature of the current region.
-
-If the optional 4th argument FETCH is non-nil, we attempt to fetch the
-signer's public key from `pgg-default-keyserver-address'.
-
-\(fn START END &optional SIGNATURE FETCH)" t nil)
-
-(autoload 'pgg-verify "pgg" "\
-Verify the current buffer.
-If the optional argument SIGNATURE is non-nil, it is treated as
-the detached signature of the current region.
-If the optional argument FETCH is non-nil, we attempt to fetch the
-signer's public key from `pgg-default-keyserver-address'.
-If optional arguments START and END are specified, only verify data
-within the region.
-
-\(fn &optional SIGNATURE FETCH START END)" t nil)
-
-(autoload 'pgg-insert-key "pgg" "\
-Insert the ASCII armored public key.
-
-\(fn)" t nil)
-
-(autoload 'pgg-snarf-keys-region "pgg" "\
-Import public keys in the current region between START and END.
-
-\(fn START END)" t nil)
-
-(autoload 'pgg-snarf-keys "pgg" "\
-Import public keys in the current buffer.
-
-\(fn)" t nil)
-
-;;;***
-
-;;;### (autoloads (pgg-gpg-symmetric-key-p) "pgg-gpg" "pgg-gpg.el"
-;;;;;; (19801 45655))
-;;; Generated autoloads from pgg-gpg.el
-
-(autoload 'pgg-gpg-symmetric-key-p "pgg-gpg" "\
-True if decoded armor MESSAGE-KEYS has symmetric encryption indicator.
-
-\(fn MESSAGE-KEYS)" nil nil)
-
-;;;***
-
;;;### (autoloads (picture-mode) "picture" "textmodes/picture.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from textmodes/picture.el
(autoload 'picture-mode "picture" "\
@@ -20798,7 +21480,7 @@ they are not defaultly assigned to keys.
;;;***
;;;### (autoloads (po-find-file-coding-system) "po" "textmodes/po.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from textmodes/po.el
(autoload 'po-find-file-coding-system "po" "\
@@ -20809,7 +21491,7 @@ Called through `file-coding-system-alist', before the file is visited for real.
;;;***
-;;;### (autoloads (pong) "pong" "play/pong.el" (19752 41642))
+;;;### (autoloads (pong) "pong" "play/pong.el" (19845 45374))
;;; Generated autoloads from play/pong.el
(autoload 'pong "pong" "\
@@ -20825,9 +21507,20 @@ pong-mode keybindings:\\<pong-mode-map>
;;;***
+;;;### (autoloads (pop3-movemail) "pop3" "gnus/pop3.el" (19845 45374))
+;;; 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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from emacs-lisp/pp.el
(autoload 'pp-to-string "pp" "\
@@ -20895,7 +21588,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from printing.el
(autoload 'pr-interface "printing" "\
@@ -21482,7 +22175,7 @@ are both set to t.
;;;***
-;;;### (autoloads (proced) "proced" "proced.el" (19752 41642))
+;;;### (autoloads (proced) "proced" "proced.el" (19886 45771))
;;; Generated autoloads from proced.el
(autoload 'proced "proced" "\
@@ -21497,13 +22190,21 @@ See `proced-mode' for a description of features available in Proced buffers.
;;;***
-;;;### (autoloads (switch-to-prolog prolog-mode) "prolog" "progmodes/prolog.el"
-;;;;;; (19752 41642))
+;;;### (autoloads (run-prolog mercury-mode prolog-mode) "prolog"
+;;;;;; "progmodes/prolog.el" (19890 42850))
;;; Generated autoloads from progmodes/prolog.el
(autoload 'prolog-mode "prolog" "\
-Major mode for editing Prolog code for Prologs.
-Blank lines and `%%...' separate paragraphs. `%'s start comments.
+Major mode for editing Prolog code.
+
+Blank lines and `%%...' separate paragraphs. `%'s starts a comment
+line and comments can also be enclosed in /* ... */.
+
+If an optional argument SYSTEM is non-nil, set up mode for the given system.
+
+To find out what version of Prolog mode you are running, enter
+`\\[prolog-mode-version]'.
+
Commands:
\\{prolog-mode-map}
Entry to this mode calls the value of `prolog-mode-hook'
@@ -21511,18 +22212,22 @@ if that value is non-nil.
\(fn)" t nil)
-(defalias 'run-prolog 'switch-to-prolog)
+(autoload 'mercury-mode "prolog" "\
+Major mode for editing Mercury programs.
+Actually this is just customized `prolog-mode'.
-(autoload 'switch-to-prolog "prolog" "\
+\(fn)" t nil)
+
+(autoload 'run-prolog "prolog" "\
Run an inferior Prolog process, input and output via buffer *prolog*.
-With prefix argument \\[universal-prefix], prompt for the program to use.
+With prefix argument ARG, restart the Prolog process if running before.
-\(fn &optional NAME)" t nil)
+\(fn ARG)" t nil)
;;;***
-;;;### (autoloads (bdf-directory-list) "ps-bdf" "ps-bdf.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (bdf-directory-list) "ps-bdf" "ps-bdf.el" (19845
+;;;;;; 45374))
;;; 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")) "\
@@ -21533,8 +22238,8 @@ The default value is '(\"/usr/local/share/emacs/fonts/bdf\").")
;;;***
-;;;### (autoloads (ps-mode) "ps-mode" "progmodes/ps-mode.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (ps-mode) "ps-mode" "progmodes/ps-mode.el" (19890
+;;;;;; 42850))
;;; Generated autoloads from progmodes/ps-mode.el
(autoload 'ps-mode "ps-mode" "\
@@ -21585,8 +22290,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" (19752
-;;;;;; 41899))
+;;;;;; ps-page-dimensions-database) "ps-print" "ps-print.el" (19886
+;;;;;; 45771))
;;; 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"))) "\
@@ -21782,8 +22487,8 @@ If EXTENSION is any other symbol, it is ignored.
;;;***
-;;;### (autoloads (python-shell jython-mode python-mode run-python)
-;;;;;; "python" "progmodes/python.el" (19752 41642))
+;;;### (autoloads (jython-mode python-mode run-python) "python" "progmodes/python.el"
+;;;;;; (19890 42850))
;;; Generated autoloads from progmodes/python.el
(add-to-list 'interpreter-mode-alist (cons (purecopy "jython") 'jython-mode))
@@ -21860,50 +22565,10 @@ Runs `jython-mode-hook' after `python-mode-hook'.
\(fn)" t nil)
-(autoload 'python-shell "python" "\
-Start an interactive Python interpreter in another window.
-This is like Shell mode, except that Python is running in the window
-instead of a shell. See the `Interactive Shell' and `Shell Mode'
-sections of the Emacs manual for details, especially for the key
-bindings active in the `*Python*' buffer.
-
-With optional \\[universal-argument], the user is prompted for the
-flags to pass to the Python interpreter. This has no effect when this
-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.
-
-Note: You can toggle between using the CPython interpreter and the
-JPython interpreter by hitting \\[python-toggle-shells]. This toggles
-buffer local variables which control whether all your subshell
-interactions happen to the `*JPython*' or `*Python*' buffers (the
-latter is the name used for the CPython buffer).
-
-Warning: Don't use an interactive Python if you change sys.ps1 or
-sys.ps2 from their default values, or if you're running code that
-prints `>>> ' or `... ' at the start of a line. `python-mode' can't
-distinguish your output from Python's output, and assumes that `>>> '
-at the start of a line is a prompt from Python. Similarly, the Emacs
-Shell mode code assumes that both `>>> ' and `... ' at the start of a
-line are Python prompts. Bad things can happen if you fool either
-mode.
-
-Warning: If you do any editing *in* the process buffer *while* the
-buffer is accepting output from Python, do NOT attempt to `undo' the
-changes. Some of the output (nowhere near the parts you changed!) may
-be lost if you do. This appears to be an Emacs bug, an unfortunate
-interaction between undo and process filters; the same problem exists in
-non-Python process buffers using the default (Emacs-supplied) process
-filter.
-
-\(fn &optional ARGPROMPT)" t nil)
-
;;;***
;;;### (autoloads (quoted-printable-decode-region) "qp" "gnus/qp.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from gnus/qp.el
(autoload 'quoted-printable-decode-region "qp" "\
@@ -21926,7 +22591,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" (19778 61528))
+;;;;;; "international/quail.el" (19845 45374))
;;; Generated autoloads from international/quail.el
(autoload 'quail-title "quail" "\
@@ -22157,8 +22822,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" (19752
-;;;;;; 41642))
+;;;;;; quickurl-ask quickurl) "quickurl" "net/quickurl.el" (19845
+;;;;;; 45374))
;;; 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 +22895,7 @@ Display `quickurl-list' as a formatted list using `quickurl-list-mode'.
;;;***
;;;### (autoloads (rcirc-track-minor-mode rcirc-connect rcirc) "rcirc"
-;;;;;; "net/rcirc.el" (19783 16707))
+;;;;;; "net/rcirc.el" (19898 36953))
;;; Generated autoloads from net/rcirc.el
(autoload 'rcirc "rcirc" "\
@@ -22245,7 +22910,7 @@ If ARG is non-nil, instead prompt for connection parameters.
(defalias 'irc 'rcirc)
(autoload 'rcirc-connect "rcirc" "\
-Not documented
+
\(fn SERVER &optional PORT NICK USER-NAME FULL-NAME STARTUP-CHANNELS PASSWORD)" nil nil)
@@ -22265,8 +22930,8 @@ Global minor mode for tracking activity in rcirc buffers.
;;;***
-;;;### (autoloads (remote-compile) "rcompile" "net/rcompile.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (remote-compile) "rcompile" "net/rcompile.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from net/rcompile.el
(autoload 'remote-compile "rcompile" "\
@@ -22278,7 +22943,7 @@ See \\[compile].
;;;***
;;;### (autoloads (re-builder) "re-builder" "emacs-lisp/re-builder.el"
-;;;;;; (19771 17123))
+;;;;;; (19865 50420))
;;; Generated autoloads from emacs-lisp/re-builder.el
(defalias 'regexp-builder 're-builder)
@@ -22290,7 +22955,7 @@ Construct a regexp interactively.
;;;***
-;;;### (autoloads (recentf-mode) "recentf" "recentf.el" (19752 41642))
+;;;### (autoloads (recentf-mode) "recentf" "recentf.el" (19886 45771))
;;; Generated autoloads from recentf.el
(defvar recentf-mode nil "\
@@ -22314,11 +22979,11 @@ 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" (19752
-;;;;;; 41642))
+;;;### (autoloads (rectangle-number-lines 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) "rect" "rect.el"
+;;;;;; (19886 45771))
;;; Generated autoloads from rect.el
(define-key ctl-x-r-map "c" 'clear-rectangle)
(define-key ctl-x-r-map "k" 'kill-rectangle)
@@ -22326,15 +22991,7 @@ that were operated on recently.
(define-key ctl-x-r-map "y" 'yank-rectangle)
(define-key ctl-x-r-map "o" 'open-rectangle)
(define-key ctl-x-r-map "t" 'string-rectangle)
-
-(autoload 'move-to-column-force "rect" "\
-If COLUMN is within a multi-column character, replace it by spaces and tab.
-As for `move-to-column', passing anything but nil or t in FLAG will move to
-the desired column only if the line is long enough.
-
-\(fn COLUMN &optional FLAG)" nil nil)
-
-(make-obsolete 'move-to-column-force 'move-to-column "21.2")
+ (define-key ctl-x-r-map "N" 'rectangle-number-lines)
(autoload 'delete-rectangle "rect" "\
Delete (don't save) text in the region-rectangle.
@@ -22450,10 +23107,20 @@ rectangle which were empty.
\(fn START END &optional FILL)" t nil)
+(autoload 'rectangle-number-lines "rect" "\
+Insert numbers in front of the region-rectangle.
+
+START-AT, if non-nil, should be a number from which to begin
+counting. FORMAT, if non-nil, should be a format string to pass
+to `format' along with the line count. When called interactively
+with a prefix argument, prompt for START-AT and FORMAT.
+
+\(fn START END START-AT &optional FORMAT)" t nil)
+
;;;***
-;;;### (autoloads (refill-mode) "refill" "textmodes/refill.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (refill-mode) "refill" "textmodes/refill.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from textmodes/refill.el
(autoload 'refill-mode "refill" "\
@@ -22469,7 +23136,7 @@ refilling if they would cause auto-filling.
;;;***
;;;### (autoloads (reftex-reset-scanning-information reftex-mode
-;;;;;; turn-on-reftex) "reftex" "textmodes/reftex.el" (19752 41642))
+;;;;;; turn-on-reftex) "reftex" "textmodes/reftex.el" (19845 45374))
;;; Generated autoloads from textmodes/reftex.el
(autoload 'turn-on-reftex "reftex" "\
@@ -22519,7 +23186,7 @@ This enforces rescanning the buffer on next use.
;;;***
;;;### (autoloads (reftex-citation) "reftex-cite" "textmodes/reftex-cite.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from textmodes/reftex-cite.el
(autoload 'reftex-citation "reftex-cite" "\
@@ -22549,7 +23216,7 @@ While entering the regexp, completion on knows citation keys is possible.
;;;***
;;;### (autoloads (reftex-isearch-minor-mode) "reftex-global" "textmodes/reftex-global.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from textmodes/reftex-global.el
(autoload 'reftex-isearch-minor-mode "reftex-global" "\
@@ -22566,7 +23233,7 @@ With no argument, this command toggles
;;;***
;;;### (autoloads (reftex-index-phrases-mode) "reftex-index" "textmodes/reftex-index.el"
-;;;;;; (19798 54314))
+;;;;;; (19845 45374))
;;; Generated autoloads from textmodes/reftex-index.el
(autoload 'reftex-index-phrases-mode "reftex-index" "\
@@ -22592,14 +23259,14 @@ For more information see the RefTeX User Manual.
Here are all local bindings.
-\\{reftex-index-phrases-map}
+\\{reftex-index-phrases-mode-map}
\(fn)" t nil)
;;;***
;;;### (autoloads (reftex-all-document-files) "reftex-parse" "textmodes/reftex-parse.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from textmodes/reftex-parse.el
(autoload 'reftex-all-document-files "reftex-parse" "\
@@ -22611,8 +23278,8 @@ of master file.
;;;***
-;;;### (autoloads nil "reftex-vars" "textmodes/reftex-vars.el" (19752
-;;;;;; 41642))
+;;;### (autoloads nil "reftex-vars" "textmodes/reftex-vars.el" (19845
+;;;;;; 45374))
;;; 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 +23289,7 @@ of master file.
;;;***
;;;### (autoloads (regexp-opt-depth regexp-opt) "regexp-opt" "emacs-lisp/regexp-opt.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from emacs-lisp/regexp-opt.el
(autoload 'regexp-opt "regexp-opt" "\
@@ -22637,6 +23304,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 +23320,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from textmodes/remember.el
(autoload 'remember "remember" "\
@@ -22682,7 +23351,7 @@ Extract diary entries from the region.
;;;***
-;;;### (autoloads (repeat) "repeat" "repeat.el" (19752 41642))
+;;;### (autoloads (repeat) "repeat" "repeat.el" (19845 45374))
;;; Generated autoloads from repeat.el
(autoload 'repeat "repeat" "\
@@ -22705,7 +23374,7 @@ recently executed command not bound to an input event\".
;;;***
;;;### (autoloads (reporter-submit-bug-report) "reporter" "mail/reporter.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from mail/reporter.el
(autoload 'reporter-submit-bug-report "reporter" "\
@@ -22737,7 +23406,7 @@ mail-sending package is used for editing and sending the message.
;;;***
;;;### (autoloads (reposition-window) "reposition" "reposition.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from reposition.el
(autoload 'reposition-window "reposition" "\
@@ -22764,7 +23433,7 @@ first comment line visible (if point is in a comment).
;;;***
;;;### (autoloads (global-reveal-mode reveal-mode) "reveal" "reveal.el"
-;;;;;; (19752 41642))
+;;;;;; (19863 8742))
;;; Generated autoloads from reveal.el
(autoload 'reveal-mode "reveal" "\
@@ -22799,7 +23468,7 @@ With zero or negative ARG turn mode off.
;;;***
;;;### (autoloads (make-ring ring-p) "ring" "emacs-lisp/ring.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from emacs-lisp/ring.el
(autoload 'ring-p "ring" "\
@@ -22814,7 +23483,7 @@ Make a ring that can contain SIZE elements.
;;;***
-;;;### (autoloads (rlogin) "rlogin" "net/rlogin.el" (19752 41642))
+;;;### (autoloads (rlogin) "rlogin" "net/rlogin.el" (19870 57559))
;;; Generated autoloads from net/rlogin.el
(add-hook 'same-window-regexps (purecopy "^\\*rlogin-.*\\*\\(\\|<[0-9]+>\\)"))
@@ -22863,9 +23532,8 @@ variable.
;;;;;; rmail rmail-show-message-hook rmail-secondary-file-regexp
;;;;;; 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" (19813
-;;;;;; 31420))
+;;;;;; rmail-user-mail-address-regexp rmail-movemail-variant-p)
+;;;;;; "rmail" "mail/rmail.el" (19845 45374))
;;; Generated autoloads from mail/rmail.el
(autoload 'rmail-movemail-variant-p "rmail" "\
@@ -22890,24 +23558,14 @@ Setting this variable has an effect only before reading a mail.")
(custom-autoload 'rmail-user-mail-address-regexp "rmail" t)
-(defvar rmail-dont-reply-to-names nil "\
-A regexp specifying addresses to prune from a reply message.
-If this is nil, it is set the first time you compose a reply, to
-a value which excludes your own email address, plus whatever is
-specified by `rmail-default-dont-reply-to-names'.
-
-Matching addresses are excluded from the CC field in replies, and
-also the To field, unless this would leave an empty To field.")
+(defvaralias 'rmail-dont-reply-to-names 'mail-dont-reply-to-names)
-(custom-autoload 'rmail-dont-reply-to-names "rmail" t)
+(defvar rmail-default-dont-reply-to-names nil "\
+Regexp specifying part of the default value of `mail-dont-reply-to-names'.
+This is used when the user does not set `mail-dont-reply-to-names'
+explicitly.")
-(defvar rmail-default-dont-reply-to-names (purecopy "\\`info-") "\
-Regexp specifying part of the default value of `rmail-dont-reply-to-names'.
-This is used when the user does not set `rmail-dont-reply-to-names'
-explicitly. (The other part of the default value is the user's
-email address and name.) It is useful to set this variable in
-the site customization file. The default value is conventionally
-used for large mailing lists to broadcast announcements.")
+(make-obsolete-variable 'rmail-default-dont-reply-to-names 'mail-dont-reply-to-names "24.1")
(defvar rmail-ignored-headers (purecopy (concat "^via:\\|^mail-from:\\|^origin:\\|^references:\\|^sender:" "\\|^status:\\|^received:\\|^x400-originator:\\|^x400-recipients:" "\\|^x400-received:\\|^x400-mts-identifier:\\|^x400-content-type:" "\\|^\\(resent-\\|\\)message-id:\\|^summary-line:\\|^resent-date:" "\\|^nntp-posting-host:\\|^path:\\|^x-char.*:\\|^x-face:\\|^face:" "\\|^x-mailer:\\|^delivered-to:\\|^lines:" "\\|^content-transfer-encoding:\\|^x-coding-system:" "\\|^return-path:\\|^errors-to:\\|^return-receipt-to:" "\\|^precedence:\\|^mime-version:" "\\|^list-owner:\\|^list-help:\\|^list-post:\\|^list-subscribe:" "\\|^list-id:\\|^list-unsubscribe:\\|^list-archive:" "\\|^content-length:\\|^nntp-posting-date:\\|^user-agent" "\\|^importance:\\|^envelope-to:\\|^delivery-date\\|^openpgp:" "\\|^mbox-line:\\|^cancel-lock:" "\\|^DomainKey-Signature:\\|^dkim-signature:" "\\|^resent-face:\\|^resent-x.*:\\|^resent-organization:\\|^resent-openpgp:" "\\|^x-.*:")) "\
Regexp to match header fields that Rmail should normally hide.
@@ -23059,7 +23717,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" (19752 41642))
+;;;;;; rmail-output) "rmailout" "mail/rmailout.el" (19845 45374))
;;; Generated autoloads from mail/rmailout.el
(put 'rmail-output-file-alist 'risky-local-variable t)
@@ -23124,7 +23782,7 @@ than appending to it. Deletes the message after writing if
;;;***
;;;### (autoloads (rng-c-load-schema) "rng-cmpct" "nxml/rng-cmpct.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from nxml/rng-cmpct.el
(autoload 'rng-c-load-schema "rng-cmpct" "\
@@ -23136,7 +23794,7 @@ Return a pattern.
;;;***
;;;### (autoloads (rng-nxml-mode-init) "rng-nxml" "nxml/rng-nxml.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from nxml/rng-nxml.el
(autoload 'rng-nxml-mode-init "rng-nxml" "\
@@ -23149,7 +23807,7 @@ Validation will be enabled if `rng-nxml-auto-validate-flag' is non-nil.
;;;***
;;;### (autoloads (rng-validate-mode) "rng-valid" "nxml/rng-valid.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from nxml/rng-valid.el
(autoload 'rng-validate-mode "rng-valid" "\
@@ -23179,8 +23837,8 @@ to use for finding the schema.
;;;***
-;;;### (autoloads (rng-xsd-compile) "rng-xsd" "nxml/rng-xsd.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (rng-xsd-compile) "rng-xsd" "nxml/rng-xsd.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from nxml/rng-xsd.el
(put 'http://www\.w3\.org/2001/XMLSchema-datatypes 'rng-dt-compile 'rng-xsd-compile)
@@ -23208,7 +23866,7 @@ must be equal.
;;;***
;;;### (autoloads (robin-use-package robin-modify-package robin-define-package)
-;;;;;; "robin" "international/robin.el" (19752 41642))
+;;;;;; "robin" "international/robin.el" (19845 45374))
;;; Generated autoloads from international/robin.el
(autoload 'robin-define-package "robin" "\
@@ -23241,7 +23899,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" (19752 41642))
+;;;;;; rot13-string rot13) "rot13" "rot13.el" (19845 45374))
;;; Generated autoloads from rot13.el
(autoload 'rot13 "rot13" "\
@@ -23279,7 +23937,7 @@ Toggle the use of ROT13 encoding for the current window.
;;;***
;;;### (autoloads (rst-minor-mode rst-mode) "rst" "textmodes/rst.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from textmodes/rst.el
(add-to-list 'auto-mode-alist (purecopy '("\\.re?st\\'" . rst-mode)))
@@ -23317,7 +23975,7 @@ for modes derived from Text mode, like Mail mode.
;;;***
;;;### (autoloads (ruby-mode) "ruby-mode" "progmodes/ruby-mode.el"
-;;;;;; (19771 32139))
+;;;;;; (19845 45374))
;;; Generated autoloads from progmodes/ruby-mode.el
(autoload 'ruby-mode "ruby-mode" "\
@@ -23338,19 +23996,24 @@ The variable `ruby-indent-level' controls the amount of indentation.
;;;***
-;;;### (autoloads (ruler-mode) "ruler-mode" "ruler-mode.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (ruler-mode) "ruler-mode" "ruler-mode.el" (19845
+;;;;;; 45374))
;;; 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" (19752
-;;;;;; 41642))
+;;;### (autoloads (rx rx-to-string) "rx" "emacs-lisp/rx.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from emacs-lisp/rx.el
(autoload 'rx-to-string "rx" "\
@@ -23656,14 +24319,16 @@ enclosed in `(and ...)'.
;;;***
-;;;### (autoloads (savehist-mode savehist-mode) "savehist" "savehist.el"
-;;;;;; (19752 41642))
+;;;### (autoloads (savehist-mode) "savehist" "savehist.el" (19886
+;;;;;; 45771))
;;; 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 +24343,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from progmodes/scheme.el
(autoload 'scheme-mode "scheme" "\
@@ -23725,7 +24390,7 @@ that variable's value is a string.
;;;***
;;;### (autoloads (gnus-score-mode) "score-mode" "gnus/score-mode.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from gnus/score-mode.el
(autoload 'gnus-score-mode "score-mode" "\
@@ -23739,7 +24404,7 @@ This mode is an extended emacs-lisp mode.
;;;***
;;;### (autoloads (scroll-all-mode) "scroll-all" "scroll-all.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from scroll-all.el
(defvar scroll-all-mode nil "\
@@ -23762,7 +24427,7 @@ apply to all visible windows in the same frame.
;;;***
;;;### (autoloads (scroll-lock-mode) "scroll-lock" "scroll-lock.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from scroll-lock.el
(autoload 'scroll-lock-mode "scroll-lock" "\
@@ -23776,8 +24441,15 @@ during scrolling.
;;;***
+;;;### (autoloads nil "secrets" "net/secrets.el" (19845 45374))
+;;; 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" (19752 41642))
+;;;;;; "cedet/semantic.el" (19845 45374))
;;; Generated autoloads from cedet/semantic.el
(defvar semantic-default-submodes '(global-semantic-idle-scheduler-mode global-semanticdb-minor-mode) "\
@@ -23822,14 +24494,13 @@ Semantic mode.
;;;***
;;;### (autoloads (mail-other-frame mail-other-window mail mail-mailing-lists
-;;;;;; mail-mode mail-send-nonascii mail-bury-selects-summary mail-default-headers
+;;;;;; mail-mode sendmail-user-agent-compose mail-default-headers
;;;;;; mail-default-directory mail-signature-file mail-signature
;;;;;; mail-citation-prefix-regexp mail-citation-hook mail-indentation-spaces
;;;;;; mail-yank-prefix mail-setup-hook mail-personal-alias-file
-;;;;;; 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" (19757 4673))
+;;;;;; 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" (19881 27850))
;;; Generated autoloads from mail/sendmail.el
(defvar mail-from-style 'default "\
@@ -23904,14 +24575,6 @@ when you first send mail.")
(custom-autoload 'mail-default-reply-to "sendmail" t)
-(defvar mail-alias-file nil "\
-If non-nil, the name of a file to use instead of `/usr/lib/aliases'.
-This file defines aliases to be expanded by the mailer; this is a different
-feature from that of defining aliases in `.mailrc' to be expanded in Emacs.
-This variable has no effect unless your system uses sendmail as its mailer.")
-
-(custom-autoload 'mail-alias-file "sendmail" t)
-
(defvar mail-personal-alias-file (purecopy "~/.mailrc") "\
If non-nil, the name of the user's personal mail alias file.
This file typically should be in same format as the `.mailrc' file used by
@@ -23958,7 +24621,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.
@@ -23998,24 +24661,12 @@ before you edit the message, so you can edit or delete the lines.")
(custom-autoload 'mail-default-headers "sendmail" t)
-(defvar mail-bury-selects-summary t "\
-If non-nil, try to show Rmail summary buffer after returning from mail.
-The functions \\[mail-send-on-exit] or \\[mail-dont-send] select
-the Rmail summary buffer before returning, if it exists and this variable
-is non-nil.")
+(define-mail-user-agent 'sendmail-user-agent 'sendmail-user-agent-compose 'mail-send-and-exit)
-(custom-autoload 'mail-bury-selects-summary "sendmail" t)
+(autoload 'sendmail-user-agent-compose "sendmail" "\
-(defvar mail-send-nonascii 'mime "\
-Specify whether to allow sending non-ASCII characters in mail.
-If t, that means do allow it. nil means don't allow it.
-`query' means ask the user each time.
-`mime' means add an appropriate MIME header if none already present.
-The default is `mime'.
-Including non-ASCII characters in a mail message can be problematical
-for the recipient, who may not know how to decode them properly.")
-(custom-autoload 'mail-send-nonascii "sendmail" t)
+\(fn &optional TO SUBJECT OTHER-HEADERS CONTINUE SWITCH-FUNCTION YANK-ACTION SEND-ACTIONS RETURN-ACTION &rest IGNORED)" nil nil)
(autoload 'mail-mode "sendmail" "\
Major mode for editing mail to be sent.
@@ -24034,7 +24685,6 @@ Here are commands that move to a header field (and create it if there isn't):
\\[mail-signature] mail-signature (insert `mail-signature-file' file).
\\[mail-yank-original] mail-yank-original (insert current message, in Rmail).
\\[mail-fill-yanked-message] mail-fill-yanked-message (fill what was yanked).
-\\[mail-sent-via] mail-sent-via (add a sent-via field for each To or CC).
Turning on Mail mode runs the normal hooks `text-mode-hook' and
`mail-mode-hook' (in that order).
@@ -24064,6 +24714,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).
@@ -24113,7 +24764,7 @@ 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'.
-\(fn &optional NOERASE TO SUBJECT IN-REPLY-TO CC REPLYBUFFER ACTIONS)" t nil)
+\(fn &optional NOERASE TO SUBJECT IN-REPLY-TO CC REPLYBUFFER ACTIONS RETURN-ACTION)" t nil)
(autoload 'mail-other-window "sendmail" "\
Like `mail' command, but display mail buffer in another window.
@@ -24128,10 +24779,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" (19752
-;;;;;; 41642))
+;;;;;; server-force-delete server-start) "server" "server.el" (19863
+;;;;;; 8742))
;;; 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 +24843,7 @@ only these files will be asked to be saved.
;;;***
-;;;### (autoloads (ses-mode) "ses" "ses.el" (19752 41642))
+;;;### (autoloads (ses-mode) "ses" "ses.el" (19845 45374))
;;; Generated autoloads from ses.el
(autoload 'ses-mode "ses" "\
@@ -24205,7 +24862,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from textmodes/sgml-mode.el
(autoload 'sgml-mode "sgml-mode" "\
@@ -24271,7 +24928,7 @@ To work around that, do:
;;;***
;;;### (autoloads (sh-mode) "sh-script" "progmodes/sh-script.el"
-;;;;;; (19752 41642))
+;;;;;; (19890 42850))
;;; Generated autoloads from progmodes/sh-script.el
(put 'sh-shell 'safe-local-variable 'symbolp)
@@ -24335,7 +24992,7 @@ with your script for an edit-interpret-debug cycle.
;;;***
-;;;### (autoloads (sha1) "sha1" "sha1.el" (19752 41642))
+;;;### (autoloads (sha1) "sha1" "sha1.el" (19845 45374))
;;; Generated autoloads from sha1.el
(autoload 'sha1 "sha1" "\
@@ -24350,7 +25007,7 @@ If BINARY is non-nil, return a string in binary form.
;;;***
;;;### (autoloads (list-load-path-shadows) "shadow" "emacs-lisp/shadow.el"
-;;;;;; (19780 34298))
+;;;;;; (19845 45374))
;;; Generated autoloads from emacs-lisp/shadow.el
(autoload 'list-load-path-shadows "shadow" "\
@@ -24400,8 +25057,8 @@ function, `load-path-shadows-find'.
;;;***
;;;### (autoloads (shadow-initialize shadow-define-regexp-group shadow-define-literal-group
-;;;;;; shadow-define-cluster) "shadowfile" "shadowfile.el" (19752
-;;;;;; 41642))
+;;;;;; shadow-define-cluster) "shadowfile" "shadowfile.el" (19886
+;;;;;; 45771))
;;; Generated autoloads from shadowfile.el
(autoload 'shadow-define-cluster "shadowfile" "\
@@ -24440,7 +25097,7 @@ Set up file shadowing.
;;;***
;;;### (autoloads (shell shell-dumb-shell-regexp) "shell" "shell.el"
-;;;;;; (19752 41642))
+;;;;;; (19888 1100))
;;; Generated autoloads from shell.el
(defvar shell-dumb-shell-regexp (purecopy "cmd\\(proxy\\)?\\.exe") "\
@@ -24489,29 +25146,40 @@ Otherwise, one argument `-i' is passed to the shell.
;;;***
+;;;### (autoloads (shr-insert-document) "shr" "gnus/shr.el" (19899
+;;;;;; 57784))
+;;; Generated autoloads from gnus/shr.el
+
+(autoload 'shr-insert-document "shr" "\
+
+
+\(fn DOM)" nil nil)
+
+;;;***
+
;;;### (autoloads (sieve-upload-and-bury sieve-upload sieve-manage)
-;;;;;; "sieve" "gnus/sieve.el" (19752 41642))
+;;;;;; "sieve" "gnus/sieve.el" (19845 45374))
;;; Generated autoloads from gnus/sieve.el
(autoload 'sieve-manage "sieve" "\
-Not documented
+
\(fn SERVER &optional PORT)" t nil)
(autoload 'sieve-upload "sieve" "\
-Not documented
+
\(fn &optional NAME)" t nil)
(autoload 'sieve-upload-and-bury "sieve" "\
-Not documented
+
\(fn &optional NAME)" t nil)
;;;***
;;;### (autoloads (sieve-mode) "sieve-mode" "gnus/sieve-mode.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from gnus/sieve-mode.el
(autoload 'sieve-mode "sieve-mode" "\
@@ -24526,8 +25194,8 @@ Turning on Sieve mode runs `sieve-mode-hook'.
;;;***
-;;;### (autoloads (simula-mode) "simula" "progmodes/simula.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (simula-mode) "simula" "progmodes/simula.el" (19890
+;;;;;; 42850))
;;; Generated autoloads from progmodes/simula.el
(autoload 'simula-mode "simula" "\
@@ -24576,7 +25244,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" (19752 41642))
+;;;;;; define-skeleton) "skeleton" "skeleton.el" (19845 45374))
;;; Generated autoloads from skeleton.el
(defvar skeleton-filter-function 'identity "\
@@ -24686,8 +25354,8 @@ symmetrical ones, and the same character twice for the others.
;;;***
;;;### (autoloads (smerge-start-session smerge-mode smerge-ediff)
-;;;;;; "smerge-mode" "smerge-mode.el" (19752 41642))
-;;; Generated autoloads from smerge-mode.el
+;;;;;; "smerge-mode" "vc/smerge-mode.el" (19863 8742))
+;;; Generated autoloads from vc/smerge-mode.el
(autoload 'smerge-ediff "smerge-mode" "\
Invoke ediff to resolve the conflicts.
@@ -24711,7 +25379,7 @@ If no conflict maker is found, turn off `smerge-mode'.
;;;***
;;;### (autoloads (smiley-buffer smiley-region) "smiley" "gnus/smiley.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from gnus/smiley.el
(autoload 'smiley-region "smiley" "\
@@ -24729,11 +25397,11 @@ interactively. If there's no argument, do it at the current buffer.
;;;***
;;;### (autoloads (smtpmail-send-queued-mail smtpmail-send-it) "smtpmail"
-;;;;;; "mail/smtpmail.el" (19752 41642))
+;;;;;; "mail/smtpmail.el" (19845 45374))
;;; Generated autoloads from mail/smtpmail.el
(autoload 'smtpmail-send-it "smtpmail" "\
-Not documented
+
\(fn)" nil nil)
@@ -24744,7 +25412,7 @@ Send mail that was queued as a result of setting `smtpmail-queue-mail'.
;;;***
-;;;### (autoloads (snake) "snake" "play/snake.el" (19752 41642))
+;;;### (autoloads (snake) "snake" "play/snake.el" (19845 45374))
;;; Generated autoloads from play/snake.el
(autoload 'snake "snake" "\
@@ -24768,7 +25436,7 @@ Snake mode keybindings:
;;;***
;;;### (autoloads (snmpv2-mode snmp-mode) "snmp-mode" "net/snmp-mode.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from net/snmp-mode.el
(autoload 'snmp-mode "snmp-mode" "\
@@ -24797,8 +25465,8 @@ then `snmpv2-mode-hook'.
;;;***
-;;;### (autoloads (sunrise-sunset) "solar" "calendar/solar.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (sunrise-sunset) "solar" "calendar/solar.el" (19886
+;;;;;; 45771))
;;; Generated autoloads from calendar/solar.el
(autoload 'sunrise-sunset "solar" "\
@@ -24813,8 +25481,8 @@ This function is suitable for execution in a .emacs file.
;;;***
-;;;### (autoloads (solitaire) "solitaire" "play/solitaire.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (solitaire) "solitaire" "play/solitaire.el" (19889
+;;;;;; 21967))
;;; Generated autoloads from play/solitaire.el
(autoload 'solitaire "solitaire" "\
@@ -24891,7 +25559,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" (19752 41642))
+;;;;;; sort-lines sort-subr) "sort" "sort.el" (19845 45374))
;;; Generated autoloads from sort.el
(put 'sort-fold-case 'safe-local-variable 'booleanp)
@@ -25035,8 +25703,8 @@ From a program takes two point or marker arguments, BEG and END.
;;;***
-;;;### (autoloads (spam-initialize) "spam" "gnus/spam.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (spam-initialize) "spam" "gnus/spam.el" (19867
+;;;;;; 52471))
;;; Generated autoloads from gnus/spam.el
(autoload 'spam-initialize "spam" "\
@@ -25052,7 +25720,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" (19752 41642))
+;;;;;; "gnus/spam-report.el" (19845 45374))
;;; Generated autoloads from gnus/spam-report.el
(autoload 'spam-report-process-queue "spam-report" "\
@@ -25095,7 +25763,7 @@ Spam reports will be queued with the method used when
;;;***
;;;### (autoloads (speedbar-get-focus speedbar-frame-mode) "speedbar"
-;;;;;; "speedbar.el" (19752 41642))
+;;;;;; "speedbar.el" (19886 45771))
;;; Generated autoloads from speedbar.el
(defalias 'speedbar 'speedbar-frame-mode)
@@ -25119,53 +25787,8 @@ 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" (19752 41642))
-;;; Generated autoloads from textmodes/spell.el
-
-(put 'spell-filter 'risky-local-variable t)
-
-(autoload 'spell-buffer "spell" "\
-Check spelling of every word in the buffer.
-For each incorrect word, you are asked for the correct spelling
-and then put into a query-replace to fix some or all occurrences.
-If you do not want to change a word, just give the same word
-as its \"correct\" spelling; then the query replace is skipped.
-
-\(fn)" t nil)
-
-(make-obsolete 'spell-buffer 'ispell-buffer "23.1")
-
-(autoload 'spell-word "spell" "\
-Check spelling of word at or before point.
-If it is not correct, ask user for the correct spelling
-and `query-replace' the entire buffer to substitute it.
-
-\(fn)" t nil)
-
-(make-obsolete 'spell-word 'ispell-word "23.1")
-
-(autoload 'spell-region "spell" "\
-Like `spell-buffer' but applies only to region.
-Used in a program, applies from START to END.
-DESCRIPTION is an optional string naming the unit being checked:
-for example, \"word\".
-
-\(fn START END &optional DESCRIPTION)" t nil)
-
-(make-obsolete 'spell-region 'ispell-region "23.1")
-
-(autoload 'spell-string "spell" "\
-Check spelling of string supplied as argument.
-
-\(fn STRING)" t nil)
-
-(make-obsolete 'spell-string "The `spell' package is obsolete - use `ispell'." "23.1")
-
-;;;***
-
-;;;### (autoloads (snarf-spooks spook) "spook" "play/spook.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (snarf-spooks spook) "spook" "play/spook.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from play/spook.el
(autoload 'spook "spook" "\
@@ -25182,15 +25805,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" (19752
-;;;;;; 41642))
+;;;;;; sql-sybase sql-oracle sql-product-interactive sql-connect
+;;;;;; sql-mode sql-help sql-add-product-keywords) "sql" "progmodes/sql.el"
+;;;;;; (19890 42850))
;;; 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 +25839,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 +25896,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 +25937,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 +25951,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 +25968,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 +25982,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 +25997,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 +26011,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 +26030,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 +26044,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 +26063,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 +26077,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 +26093,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 +26107,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 +26122,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 +26136,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 +26153,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 +26167,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 +26184,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 +26203,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 +26219,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 +26233,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 +26253,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 +26267,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 +26279,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 +26291,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from cedet/srecode/srt-mode.el
(autoload 'srecode-template-mode "srecode/srt-mode" "\
@@ -25623,12 +26315,36 @@ Major-mode for writing SRecode macros.
;;;***
+;;;### (autoloads (starttls-open-stream) "starttls" "gnus/starttls.el"
+;;;;;; (19845 45374))
+;;; 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" (19752
-;;;;;; 41642))
+;;;;;; strokes-global-set-stroke) "strokes" "strokes.el" (19886
+;;;;;; 45771))
;;; Generated autoloads from strokes.el
(autoload 'strokes-global-set-stroke "strokes" "\
@@ -25738,7 +26454,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" (19845 45374))
;;; Generated autoloads from play/studly.el
(autoload 'studlify-region "studly" "\
@@ -25759,7 +26475,7 @@ Studlify-case the current buffer.
;;;***
;;;### (autoloads (global-subword-mode subword-mode) "subword" "progmodes/subword.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from progmodes/subword.el
(autoload 'subword-mode "subword" "\
@@ -25807,7 +26523,7 @@ See `subword-mode' for more information on Subword mode.
;;;***
;;;### (autoloads (sc-cite-original) "supercite" "mail/supercite.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from mail/supercite.el
(autoload 'sc-cite-original "supercite" "\
@@ -25839,8 +26555,8 @@ and `sc-post-hook' is run after the guts of this function.
;;;***
-;;;### (autoloads (gpm-mouse-mode) "t-mouse" "t-mouse.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (gpm-mouse-mode) "t-mouse" "t-mouse.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from t-mouse.el
(define-obsolete-function-alias 't-mouse-mode 'gpm-mouse-mode "23.1")
@@ -25867,7 +26583,7 @@ It relies on the `gpm' daemon being activated.
;;;***
-;;;### (autoloads (tabify untabify) "tabify" "tabify.el" (19752 41642))
+;;;### (autoloads (tabify untabify) "tabify" "tabify.el" (19845 45374))
;;; Generated autoloads from tabify.el
(autoload 'untabify "tabify" "\
@@ -25902,27 +26618,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" (19752 41642))
+;;;;;; "table" "textmodes/table.el" (19845 45374))
;;; 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)
@@ -26083,7 +26799,7 @@ all the table specific features.
\(fn &optional ARG)" t nil)
(autoload 'table-unrecognize "table" "\
-Not documented
+
\(fn)" t nil)
@@ -26097,7 +26813,7 @@ specific features.
\(fn BEG END &optional ARG)" t nil)
(autoload 'table-unrecognize-region "table" "\
-Not documented
+
\(fn BEG END)" t nil)
@@ -26110,7 +26826,7 @@ the table specific features.
\(fn &optional ARG)" t nil)
(autoload 'table-unrecognize-table "table" "\
-Not documented
+
\(fn)" t nil)
@@ -26125,7 +26841,7 @@ plain text and loses all the table specific features.
\(fn &optional FORCE NO-COPY ARG)" t nil)
(autoload 'table-unrecognize-cell "table" "\
-Not documented
+
\(fn)" t nil)
@@ -26490,7 +27206,50 @@ converts a table into plain text without frames. It is a companion to
;;;***
-;;;### (autoloads (talk talk-connect) "talk" "talk.el" (19752 41642))
+;;;### (autoloads (tabulated-list-mode) "tabulated-list" "emacs-lisp/tabulated-list.el"
+;;;;;; (19885 24894))
+;;; Generated autoloads from emacs-lisp/tabulated-list.el
+
+(autoload 'tabulated-list-mode "tabulated-list" "\
+Generic major mode for browsing a list of items.
+This mode is usually not used directly; instead, other major
+modes are derived from it, using `define-derived-mode'.
+
+In this major mode, the buffer is divided into multiple columns,
+which are labelled using the header line. Each non-empty line
+belongs to one \"entry\", and the entries can be sorted according
+to their column values.
+
+An inheriting mode should usually do the following in their body:
+
+ - Set `tabulated-list-format', specifying the column format.
+ - Set `tabulated-list-revert-hook', if the buffer contents need
+ to be specially recomputed prior to `revert-buffer'.
+ - Maybe set a `tabulated-list-entries' function (see below).
+ - Maybe set `tabulated-list-printer' (see below).
+ - Maybe set `tabulated-list-padding'.
+ - Call `tabulated-list-init-header' to initialize `header-line-format'
+ according to `tabulated-list-format'.
+
+An inheriting mode is usually accompanied by a \"list-FOO\"
+command (e.g. `list-packages', `list-processes'). This command
+creates or switches to a buffer and enables the major mode in
+that buffer. If `tabulated-list-entries' is not a function, the
+command should initialize it to a list of entries for displaying.
+Finally, it should call `tabulated-list-print'.
+
+`tabulated-list-print' calls the printer function specified by
+`tabulated-list-printer', once for each entry. The default
+printer is `tabulated-list-print-entry', but a mode that keeps
+data in an ewoc may instead specify a printer function (e.g., one
+that calls `ewoc-enter-last'), with `tabulated-list-print-entry'
+as the ewoc pretty-printer.
+
+\(fn)" t nil)
+
+;;;***
+
+;;;### (autoloads (talk talk-connect) "talk" "talk.el" (19886 45771))
;;; Generated autoloads from talk.el
(autoload 'talk-connect "talk" "\
@@ -26505,7 +27264,7 @@ Connect to the Emacs talk group from the current X display or tty frame.
;;;***
-;;;### (autoloads (tar-mode) "tar-mode" "tar-mode.el" (19752 41642))
+;;;### (autoloads (tar-mode) "tar-mode" "tar-mode.el" (19886 45771))
;;; Generated autoloads from tar-mode.el
(autoload 'tar-mode "tar-mode" "\
@@ -26529,7 +27288,7 @@ See also: variables `tar-update-datestamp' and `tar-anal-blocksize'.
;;;***
;;;### (autoloads (tcl-help-on-word inferior-tcl tcl-mode) "tcl"
-;;;;;; "progmodes/tcl.el" (19752 41642))
+;;;;;; "progmodes/tcl.el" (19890 42850))
;;; Generated autoloads from progmodes/tcl.el
(autoload 'tcl-mode "tcl" "\
@@ -26560,9 +27319,6 @@ Turning on Tcl mode runs `tcl-mode-hook'. Read the documentation for
`tcl-mode-hook' to see what kinds of interesting hook functions
already exist.
-Commands:
-\\{tcl-mode-map}
-
\(fn)" t nil)
(autoload 'inferior-tcl "tcl" "\
@@ -26580,7 +27336,7 @@ Prefix argument means invert sense of `tcl-use-smart-word-finder'.
;;;***
-;;;### (autoloads (rsh telnet) "telnet" "net/telnet.el" (19752 41642))
+;;;### (autoloads (rsh telnet) "telnet" "net/telnet.el" (19845 45374))
;;; Generated autoloads from net/telnet.el
(add-hook 'same-window-regexps (purecopy "\\*telnet-.*\\*\\(\\|<[0-9]+>\\)"))
@@ -26608,7 +27364,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from term.el
(autoload 'make-term "term" "\
@@ -26650,8 +27406,8 @@ use in that buffer.
;;;***
-;;;### (autoloads (terminal-emulator) "terminal" "terminal.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (terminal-emulator) "terminal" "terminal.el" (19886
+;;;;;; 45771))
;;; Generated autoloads from terminal.el
(autoload 'terminal-emulator "terminal" "\
@@ -26688,7 +27444,7 @@ subprocess started.
;;;***
;;;### (autoloads (testcover-this-defun) "testcover" "emacs-lisp/testcover.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from emacs-lisp/testcover.el
(autoload 'testcover-this-defun "testcover" "\
@@ -26698,7 +27454,7 @@ Start coverage on function under point.
;;;***
-;;;### (autoloads (tetris) "tetris" "play/tetris.el" (19752 41642))
+;;;### (autoloads (tetris) "tetris" "play/tetris.el" (19889 21967))
;;; Generated autoloads from play/tetris.el
(autoload 'tetris "tetris" "\
@@ -26729,16 +27485,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; 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 +27510,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 +27551,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 +27595,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 +27605,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 +27619,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)
@@ -27019,7 +27775,7 @@ Entering SliTeX mode runs the hook `text-mode-hook', then the hook
\(fn)" t nil)
(autoload 'tex-start-shell "tex-mode" "\
-Not documented
+
\(fn)" nil nil)
@@ -27031,7 +27787,7 @@ Major mode to edit DocTeX files.
;;;***
;;;### (autoloads (texi2info texinfo-format-region texinfo-format-buffer)
-;;;;;; "texinfmt" "textmodes/texinfmt.el" (19752 41642))
+;;;;;; "texinfmt" "textmodes/texinfmt.el" (19845 45374))
;;; Generated autoloads from textmodes/texinfmt.el
(autoload 'texinfo-format-buffer "texinfmt" "\
@@ -27071,7 +27827,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" (19752 41642))
+;;;;;; "texinfo" "textmodes/texinfo.el" (19845 45374))
;;; Generated autoloads from textmodes/texinfo.el
(defvar texinfo-open-quote (purecopy "``") "\
@@ -27157,7 +27913,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from language/thai-util.el
(autoload 'thai-compose-region "thai-util" "\
@@ -27178,7 +27934,7 @@ Compose Thai characters in the current buffer.
\(fn)" t nil)
(autoload 'thai-composition-function "thai-util" "\
-Not documented
+
\(fn GSTRING)" nil nil)
@@ -27186,7 +27942,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" (19752 41642))
+;;;;;; "thingatpt" "thingatpt.el" (19852 16697))
;;; Generated autoloads from thingatpt.el
(autoload 'forward-thing "thingatpt" "\
@@ -27243,7 +27999,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from thumbs.el
(autoload 'thumbs-find-thumb "thumbs" "\
@@ -27281,8 +28037,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" (19752
-;;;;;; 41642))
+;;;;;; tibetan-char-p) "tibet-util" "language/tibet-util.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from language/tibet-util.el
(autoload 'tibetan-char-p "tibet-util" "\
@@ -27339,24 +28095,24 @@ See also docstring of the function tibetan-compose-region.
\(fn)" t nil)
(autoload 'tibetan-post-read-conversion "tibet-util" "\
-Not documented
+
\(fn LEN)" nil nil)
(autoload 'tibetan-pre-write-conversion "tibet-util" "\
-Not documented
+
\(fn FROM TO)" nil nil)
(autoload 'tibetan-pre-write-canonicalize-for-unicode "tibet-util" "\
-Not documented
+
\(fn FROM TO)" nil nil)
;;;***
;;;### (autoloads (tildify-buffer tildify-region) "tildify" "textmodes/tildify.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from textmodes/tildify.el
(autoload 'tildify-region "tildify" "\
@@ -27381,7 +28137,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" (19752 41642))
+;;;;;; "time" "time.el" (19886 45771))
;;; Generated autoloads from time.el
(defvar display-time-day-and-date nil "\
@@ -27446,7 +28202,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"
-;;;;;; (19752 41642))
+;;;;;; (19885 24894))
;;; Generated autoloads from calendar/time-date.el
(autoload 'date-to-time "time-date" "\
@@ -27454,8 +28210,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"))
@@ -27467,7 +28224,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)
@@ -27559,7 +28316,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" (19752 41642))
+;;;;;; "time-stamp.el" (19886 45771))
;;; 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)
@@ -27603,7 +28360,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from calendar/timeclock.el
(autoload 'timeclock-modeline-display "timeclock" "\
@@ -27703,7 +28460,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" (19752 41642))
+;;;;;; "international/titdic-cnv.el" (19845 45374))
;;; Generated autoloads from international/titdic-cnv.el
(autoload 'titdic-convert "titdic-cnv" "\
@@ -27726,7 +28483,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\".
;;;***
;;;### (autoloads (tmm-prompt tmm-menubar-mouse tmm-menubar) "tmm"
-;;;;;; "tmm.el" (19757 3579))
+;;;;;; "tmm.el" (19845 45374))
;;; Generated autoloads from tmm.el
(define-key global-map "\M-`" 'tmm-menubar)
(define-key global-map [menu-bar mouse-1] 'tmm-menubar-mouse)
@@ -27766,7 +28523,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" (19752 41642))
+;;;;;; "todo-mode" "calendar/todo-mode.el" (19845 45374))
;;; Generated autoloads from calendar/todo-mode.el
(autoload 'todo-add-category "todo-mode" "\
@@ -27810,8 +28567,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" "\
@@ -27828,7 +28583,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" (19752 41642))
+;;;;;; "tool-bar" "tool-bar.el" (19886 45771))
;;; Generated autoloads from tool-bar.el
(autoload 'toggle-tool-bar-mode-from-frame "tool-bar" "\
@@ -27837,8 +28592,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
@@ -27901,7 +28654,7 @@ holds a keymap.
;;;***
;;;### (autoloads (tpu-edt-on tpu-edt-mode) "tpu-edt" "emulation/tpu-edt.el"
-;;;;;; (19752 41899))
+;;;;;; (19845 45374))
;;; Generated autoloads from emulation/tpu-edt.el
(defvar tpu-edt-mode nil "\
@@ -27928,7 +28681,7 @@ Turn on TPU/edt emulation.
;;;***
;;;### (autoloads (tpu-mapper) "tpu-mapper" "emulation/tpu-mapper.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from emulation/tpu-mapper.el
(autoload 'tpu-mapper "tpu-mapper" "\
@@ -27962,7 +28715,7 @@ your local X guru can try to figure out why the key is being ignored.
;;;***
-;;;### (autoloads (tq-create) "tq" "emacs-lisp/tq.el" (19752 41642))
+;;;### (autoloads (tq-create) "tq" "emacs-lisp/tq.el" (19845 45374))
;;; Generated autoloads from emacs-lisp/tq.el
(autoload 'tq-create "tq" "\
@@ -27976,7 +28729,7 @@ to a tcp server on another machine.
;;;***
;;;### (autoloads (trace-function-background trace-function trace-buffer)
-;;;;;; "trace" "emacs-lisp/trace.el" (19752 41642))
+;;;;;; "trace" "emacs-lisp/trace.el" (19845 45374))
;;; Generated autoloads from emacs-lisp/trace.el
(defvar trace-buffer (purecopy "*trace-output*") "\
@@ -28013,7 +28766,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" (19757 3579))
+;;;;;; "net/tramp.el" (19894 39890))
;;; Generated autoloads from net/tramp.el
(defvar tramp-mode t "\
@@ -28099,9 +28852,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.
@@ -28125,10 +28878,11 @@ 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" "\
-Not documented
+
\(fn)" nil nil)
@@ -28150,18 +28904,18 @@ Discard Tramp from loading remote files.
;;;***
;;;### (autoloads (tramp-ftp-enable-ange-ftp) "tramp-ftp" "net/tramp-ftp.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from net/tramp-ftp.el
(autoload 'tramp-ftp-enable-ange-ftp "tramp-ftp" "\
-Not documented
+
\(fn)" nil nil)
;;;***
-;;;### (autoloads (help-with-tutorial) "tutorial" "tutorial.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (help-with-tutorial) "tutorial" "tutorial.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from tutorial.el
(autoload 'help-with-tutorial "tutorial" "\
@@ -28186,18 +28940,18 @@ resumed later.
;;;***
;;;### (autoloads (tai-viet-composition-function) "tv-util" "language/tv-util.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from language/tv-util.el
(autoload 'tai-viet-composition-function "tv-util" "\
-Not documented
+
\(fn FROM TO FONT-OBJECT STRING)" nil nil)
;;;***
;;;### (autoloads (2C-split 2C-associate-buffer 2C-two-columns) "two-column"
-;;;;;; "textmodes/two-column.el" (19752 41642))
+;;;;;; "textmodes/two-column.el" (19845 45374))
;;; Generated autoloads from textmodes/two-column.el
(autoload '2C-command "two-column" () t 'keymap)
(global-set-key "\C-x6" '2C-command)
@@ -28248,7 +29002,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"
-;;;;;; (19752 41642))
+;;;;;; (19886 45771))
;;; Generated autoloads from type-break.el
(defvar type-break-mode nil "\
@@ -28430,7 +29184,7 @@ FRAC should be the inverse of the fractional value; for example, a value of
;;;***
-;;;### (autoloads (uce-reply-to-uce) "uce" "mail/uce.el" (19752 41642))
+;;;### (autoloads (uce-reply-to-uce) "uce" "mail/uce.el" (19845 45374))
;;; Generated autoloads from mail/uce.el
(autoload 'uce-reply-to-uce "uce" "\
@@ -28448,7 +29202,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" (19813 31420))
+;;;;;; "international/ucs-normalize.el" (19845 45374))
;;; Generated autoloads from international/ucs-normalize.el
(autoload 'ucs-normalize-NFD-region "ucs-normalize" "\
@@ -28514,7 +29268,7 @@ Normalize the string STR by the Unicode NFC and Mac OS's HFS Plus.
;;;***
;;;### (autoloads (ununderline-region underline-region) "underline"
-;;;;;; "textmodes/underline.el" (19752 41642))
+;;;;;; "textmodes/underline.el" (19845 45374))
;;; Generated autoloads from textmodes/underline.el
(autoload 'underline-region "underline" "\
@@ -28535,7 +29289,7 @@ which specify the range to operate on.
;;;***
;;;### (autoloads (unrmail batch-unrmail) "unrmail" "mail/unrmail.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from mail/unrmail.el
(autoload 'batch-unrmail "unrmail" "\
@@ -28554,8 +29308,8 @@ Convert old-style Rmail Babyl file FILE to system inbox format file TO-FILE.
;;;***
-;;;### (autoloads (unsafep) "unsafep" "emacs-lisp/unsafep.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (unsafep) "unsafep" "emacs-lisp/unsafep.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from emacs-lisp/unsafep.el
(autoload 'unsafep "unsafep" "\
@@ -28568,7 +29322,7 @@ UNSAFEP-VARS is a list of symbols with local bindings.
;;;***
;;;### (autoloads (url-retrieve-synchronously url-retrieve) "url"
-;;;;;; "url/url.el" (19752 41642))
+;;;;;; "url/url.el" (19845 45374))
;;; Generated autoloads from url/url.el
(autoload 'url-retrieve "url" "\
@@ -28595,7 +29349,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.
@@ -28608,7 +29364,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" (19752 41642))
+;;;;;; "url-auth" "url/url-auth.el" (19845 45374))
;;; Generated autoloads from url/url-auth.el
(autoload 'url-get-authentication "url-auth" "\
@@ -28649,9 +29405,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" (19752
-;;;;;; 41642))
+;;;### (autoloads (url-cache-extract url-is-cached url-store-in-cache)
+;;;;;; "url-cache" "url/url-cache.el" (19845 45374))
;;; Generated autoloads from url/url-cache.el
(autoload 'url-store-in-cache "url-cache" "\
@@ -28670,41 +29425,36 @@ 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" (19752 41642))
+;;;### (autoloads (url-cid) "url-cid" "url/url-cid.el" (19845 45374))
;;; Generated autoloads from url/url-cid.el
(autoload 'url-cid "url-cid" "\
-Not documented
+
\(fn URL)" nil nil)
;;;***
;;;### (autoloads (url-dav-vc-registered url-dav-supported-p) "url-dav"
-;;;;;; "url/url-dav.el" (19752 41642))
+;;;;;; "url/url-dav.el" (19845 45374))
;;; Generated autoloads from url/url-dav.el
(autoload 'url-dav-supported-p "url-dav" "\
-Not documented
+
\(fn URL)" nil nil)
(autoload 'url-dav-vc-registered "url-dav" "\
-Not documented
+
\(fn URL)" nil nil)
;;;***
-;;;### (autoloads (url-file) "url-file" "url/url-file.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (url-file) "url-file" "url/url-file.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from url/url-file.el
(autoload 'url-file "url-file" "\
@@ -28715,7 +29465,7 @@ Handle file: and ftp: URLs.
;;;***
;;;### (autoloads (url-open-stream url-gateway-nslookup-host) "url-gw"
-;;;;;; "url/url-gw.el" (19752 41642))
+;;;;;; "url/url-gw.el" (19864 29553))
;;; Generated autoloads from url/url-gw.el
(autoload 'url-gateway-nslookup-host "url-gw" "\
@@ -28735,7 +29485,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from url/url-handlers.el
(defvar url-handler-mode nil "\
@@ -28780,14 +29530,14 @@ accessible.
\(fn URL &rest IGNORED)" nil nil)
(autoload 'url-insert-file-contents "url-handlers" "\
-Not documented
+
\(fn URL &optional VISIT BEG END REPLACE)" nil nil)
;;;***
;;;### (autoloads (url-http-options url-http-file-attributes url-http-file-exists-p
-;;;;;; url-http) "url-http" "url/url-http.el" (19752 41642))
+;;;;;; url-http) "url-http" "url/url-http.el" (19882 48702))
;;; Generated autoloads from url/url-http.el
(autoload 'url-http "url-http" "\
@@ -28799,14 +29549,14 @@ CBARGS as the arguments.
\(fn URL CALLBACK CBARGS)" nil nil)
(autoload 'url-http-file-exists-p "url-http" "\
-Not documented
+
\(fn URL)" nil nil)
(defalias 'url-http-file-readable-p 'url-http-file-exists-p)
(autoload 'url-http-file-attributes "url-http" "\
-Not documented
+
\(fn URL &optional ID-FORMAT)" nil nil)
@@ -28853,18 +29603,18 @@ HTTPS retrievals are asynchronous.")
;;;***
-;;;### (autoloads (url-irc) "url-irc" "url/url-irc.el" (19752 41642))
+;;;### (autoloads (url-irc) "url-irc" "url/url-irc.el" (19845 45374))
;;; Generated autoloads from url/url-irc.el
(autoload 'url-irc "url-irc" "\
-Not documented
+
\(fn URL)" nil nil)
;;;***
-;;;### (autoloads (url-ldap) "url-ldap" "url/url-ldap.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (url-ldap) "url-ldap" "url/url-ldap.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from url/url-ldap.el
(autoload 'url-ldap "url-ldap" "\
@@ -28878,11 +29628,11 @@ 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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from url/url-mailto.el
(autoload 'url-mail "url-mailto" "\
-Not documented
+
\(fn &rest ARGS)" t nil)
@@ -28894,7 +29644,7 @@ Handle the mailto: URL syntax.
;;;***
;;;### (autoloads (url-data url-generic-emulator-loader url-info
-;;;;;; url-man) "url-misc" "url/url-misc.el" (19752 41642))
+;;;;;; url-man) "url-misc" "url/url-misc.el" (19845 45374))
;;; Generated autoloads from url/url-misc.el
(autoload 'url-man "url-misc" "\
@@ -28908,7 +29658,7 @@ Fetch a GNU Info URL.
\(fn URL)" nil nil)
(autoload 'url-generic-emulator-loader "url-misc" "\
-Not documented
+
\(fn URL)" nil nil)
@@ -28926,16 +29676,16 @@ Fetch a data URL (RFC 2397).
;;;***
;;;### (autoloads (url-snews url-news) "url-news" "url/url-news.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from url/url-news.el
(autoload 'url-news "url-news" "\
-Not documented
+
\(fn URL)" nil nil)
(autoload 'url-snews "url-news" "\
-Not documented
+
\(fn URL)" nil nil)
@@ -28943,48 +29693,48 @@ Not documented
;;;### (autoloads (url-ns-user-pref url-ns-prefs isInNet isResolvable
;;;;;; dnsResolve dnsDomainIs isPlainHostName) "url-ns" "url/url-ns.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from url/url-ns.el
(autoload 'isPlainHostName "url-ns" "\
-Not documented
+
\(fn HOST)" nil nil)
(autoload 'dnsDomainIs "url-ns" "\
-Not documented
+
\(fn HOST DOM)" nil nil)
(autoload 'dnsResolve "url-ns" "\
-Not documented
+
\(fn HOST)" nil nil)
(autoload 'isResolvable "url-ns" "\
-Not documented
+
\(fn HOST)" nil nil)
(autoload 'isInNet "url-ns" "\
-Not documented
+
\(fn IP NET MASK)" nil nil)
(autoload 'url-ns-prefs "url-ns" "\
-Not documented
+
\(fn &optional FILE)" nil nil)
(autoload 'url-ns-user-pref "url-ns" "\
-Not documented
+
\(fn KEY &optional DEFAULT)" nil nil)
;;;***
;;;### (autoloads (url-generic-parse-url url-recreate-url) "url-parse"
-;;;;;; "url/url-parse.el" (19752 41642))
+;;;;;; "url/url-parse.el" (19845 45374))
;;; Generated autoloads from url/url-parse.el
(autoload 'url-recreate-url "url-parse" "\
@@ -29002,7 +29752,7 @@ TYPE USER PASSWORD HOST PORTSPEC FILENAME TARGET ATTRIBUTES FULLNESS.
;;;***
;;;### (autoloads (url-setup-privacy-info) "url-privacy" "url/url-privacy.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from url/url-privacy.el
(autoload 'url-setup-privacy-info "url-privacy" "\
@@ -29018,11 +29768,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" (19752 41642))
+;;;;;; "url-util" "url/url-util.el" (19867 59212))
;;; 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.
@@ -29032,12 +29782,12 @@ If a list, it is a list of the types of messages to be logged.")
(custom-autoload 'url-debug "url-util" t)
(autoload 'url-debug "url-util" "\
-Not documented
+
\(fn TAG &rest ARGS)" nil nil)
(autoload 'url-parse-args "url-util" "\
-Not documented
+
\(fn STR &optional NODOWNCASE)" nil nil)
@@ -29081,17 +29831,17 @@ Remove spaces at the front of a string.
\(fn X)" nil nil)
(autoload 'url-pretty-length "url-util" "\
-Not documented
+
\(fn N)" nil nil)
(autoload 'url-display-percentage "url-util" "\
-Not documented
+
\(fn FMT PERC &rest ARGS)" nil nil)
(autoload 'url-percentage "url-util" "\
-Not documented
+
\(fn X Y)" nil nil)
@@ -29108,7 +29858,7 @@ Return the nondirectory part of FILE, for a URL.
\(fn FILE)" nil nil)
(autoload 'url-parse-query-string "url-util" "\
-Not documented
+
\(fn QUERY &optional DOWNCASE ALLOW-NEWLINES)" nil nil)
@@ -29154,7 +29904,7 @@ This uses `url-current-object', set locally to the buffer.
;;;***
;;;### (autoloads (ask-user-about-supersession-threat ask-user-about-lock)
-;;;;;; "userlock" "userlock.el" (19752 41642))
+;;;;;; "userlock" "userlock.el" (19845 45374))
;;; Generated autoloads from userlock.el
(autoload 'ask-user-about-lock "userlock" "\
@@ -29184,34 +29934,44 @@ 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" (19752 41642))
+;;;;;; "utf-7" "international/utf-7.el" (19845 45374))
;;; Generated autoloads from international/utf-7.el
(autoload 'utf-7-post-read-conversion "utf-7" "\
-Not documented
+
\(fn LEN)" nil nil)
(autoload 'utf-7-imap-post-read-conversion "utf-7" "\
-Not documented
+
\(fn LEN)" nil nil)
(autoload 'utf-7-pre-write-conversion "utf-7" "\
-Not documented
+
\(fn FROM TO)" nil nil)
(autoload 'utf-7-imap-pre-write-conversion "utf-7" "\
-Not documented
+
\(fn FROM TO)" nil nil)
;;;***
+;;;### (autoloads (utf7-encode) "utf7" "gnus/utf7.el" (19845 45374))
+;;; 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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from mail/uudecode.el
(autoload 'uudecode-decode-region-external "uudecode" "\
@@ -29236,13 +29996,14 @@ If FILE-NAME is non-nil, save the result to FILE-NAME.
;;;***
;;;### (autoloads (vc-branch-part vc-update-change-log vc-rename-file
-;;;;;; vc-delete-file vc-transfer-file vc-switch-backend vc-update
+;;;;;; vc-delete-file vc-transfer-file vc-switch-backend vc-pull
;;;;;; vc-rollback vc-revert vc-log-outgoing vc-log-incoming vc-print-root-log
;;;;;; 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" (19752 41642))
-;;; Generated autoloads from vc.el
+;;;;;; vc-revision-other-window vc-root-diff vc-ediff vc-version-ediff
+;;;;;; vc-diff vc-version-diff vc-register vc-next-action vc-before-checkin-hook
+;;;;;; vc-checkin-hook vc-checkout-hook) "vc" "vc/vc.el" (19888
+;;;;;; 1100))
+;;; Generated autoloads from vc/vc.el
(defvar vc-checkout-hook nil "\
Normal hook (list of functions) run after checking out a file.
@@ -29327,6 +30088,23 @@ saving the buffer.
\(fn HISTORIC &optional NOT-URGENT)" t nil)
+(autoload 'vc-version-ediff "vc" "\
+Show differences between revisions of the fileset in the
+repository history using ediff.
+
+\(fn FILES REV1 REV2)" t nil)
+
+(autoload 'vc-ediff "vc" "\
+Display diffs between file revisions using ediff.
+Normally this compares the currently selected fileset with their
+working revisions. With a prefix argument HISTORIC, it reads two revision
+designators specifying which revisions to compare.
+
+The optional argument NOT-URGENT non-nil means it is ok to say no to
+saving the buffer.
+
+\(fn HISTORIC &optional NOT-URGENT)" t nil)
+
(autoload 'vc-root-diff "vc" "\
Display diffs between VC-controlled whole tree revisions.
Normally, this compares the tree corresponding to the current
@@ -29354,13 +30132,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)
@@ -29431,14 +30213,21 @@ 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.
+(autoload 'vc-pull "vc" "\
+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-update 'vc-pull)
(autoload 'vc-switch-backend "vc" "\
Make BACKEND the current version control system for FILE.
@@ -29495,9 +30284,9 @@ Return the branch part of a revision number REV.
;;;***
-;;;### (autoloads (vc-annotate) "vc-annotate" "vc-annotate.el" (19752
-;;;;;; 41642))
-;;; Generated autoloads from vc-annotate.el
+;;;### (autoloads (vc-annotate) "vc-annotate" "vc/vc-annotate.el"
+;;;;;; (19893 19022))
+;;; Generated autoloads from vc/vc-annotate.el
(autoload 'vc-annotate "vc-annotate" "\
Display the edit history of the current FILE using colors.
@@ -29533,8 +30322,8 @@ mode-specific menu. `vc-annotate-color-map' and
;;;***
-;;;### (autoloads nil "vc-arch" "vc-arch.el" (19752 41642))
-;;; Generated autoloads from vc-arch.el
+;;;### (autoloads nil "vc-arch" "vc/vc-arch.el" (19845 45374))
+;;; Generated autoloads from vc/vc-arch.el
(defun vc-arch-registered (file)
(if (vc-find-root file "{arch}/=tagging-method")
(progn
@@ -29543,8 +30332,8 @@ mode-specific menu. `vc-annotate-color-map' and
;;;***
-;;;### (autoloads nil "vc-bzr" "vc-bzr.el" (19752 41642))
-;;; Generated autoloads from vc-bzr.el
+;;;### (autoloads nil "vc-bzr" "vc/vc-bzr.el" (19845 45374))
+;;; Generated autoloads from vc/vc-bzr.el
(defconst vc-bzr-admin-dirname ".bzr" "\
Name of the directory containing Bzr repository status files.")
@@ -29558,8 +30347,8 @@ Name of the directory containing Bzr repository status files.")
;;;***
-;;;### (autoloads nil "vc-cvs" "vc-cvs.el" (19752 41642))
-;;; Generated autoloads from vc-cvs.el
+;;;### (autoloads nil "vc-cvs" "vc/vc-cvs.el" (19845 45374))
+;;; 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)))
@@ -29568,8 +30357,8 @@ Name of the directory containing Bzr repository status files.")
;;;***
-;;;### (autoloads (vc-dir) "vc-dir" "vc-dir.el" (19752 41642))
-;;; Generated autoloads from vc-dir.el
+;;;### (autoloads (vc-dir) "vc-dir" "vc/vc-dir.el" (19845 45374))
+;;; Generated autoloads from vc/vc-dir.el
(autoload 'vc-dir "vc-dir" "\
Show the VC status for \"interesting\" files in and below DIR.
@@ -29592,9 +30381,9 @@ These are the commands available for use in the file status buffer:
;;;***
-;;;### (autoloads (vc-do-command) "vc-dispatcher" "vc-dispatcher.el"
-;;;;;; (19752 41642))
-;;; Generated autoloads from vc-dispatcher.el
+;;;### (autoloads (vc-do-command) "vc-dispatcher" "vc/vc-dispatcher.el"
+;;;;;; (19845 45374))
+;;; Generated autoloads from vc/vc-dispatcher.el
(autoload 'vc-do-command "vc-dispatcher" "\
Execute a slave command, notifying user and checking for errors.
@@ -29616,8 +30405,8 @@ case, and the process object in the asynchronous case.
;;;***
-;;;### (autoloads nil "vc-git" "vc-git.el" (19752 41642))
-;;; Generated autoloads from vc-git.el
+;;;### (autoloads nil "vc-git" "vc/vc-git.el" (19845 45374))
+;;; 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.
@@ -29627,8 +30416,8 @@ case, and the process object in the asynchronous case.
;;;***
-;;;### (autoloads nil "vc-hg" "vc-hg.el" (19752 41642))
-;;; Generated autoloads from vc-hg.el
+;;;### (autoloads nil "vc-hg" "vc/vc-hg.el" (19845 45374))
+;;; 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
@@ -29638,8 +30427,8 @@ case, and the process object in the asynchronous case.
;;;***
-;;;### (autoloads nil "vc-mtn" "vc-mtn.el" (19752 41642))
-;;; Generated autoloads from vc-mtn.el
+;;;### (autoloads nil "vc-mtn" "vc/vc-mtn.el" (19845 45374))
+;;; Generated autoloads from vc/vc-mtn.el
(defconst vc-mtn-admin-dir "_MTN")
@@ -29652,9 +30441,9 @@ case, and the process object in the asynchronous case.
;;;***
-;;;### (autoloads (vc-rcs-master-templates) "vc-rcs" "vc-rcs.el"
-;;;;;; (19752 41642))
-;;; Generated autoloads from vc-rcs.el
+;;;### (autoloads (vc-rcs-master-templates) "vc-rcs" "vc/vc-rcs.el"
+;;;;;; (19845 45374))
+;;; 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.
@@ -29666,9 +30455,9 @@ For a description of possible values, see `vc-check-master-templates'.")
;;;***
-;;;### (autoloads (vc-sccs-master-templates) "vc-sccs" "vc-sccs.el"
-;;;;;; (19752 41642))
-;;; Generated autoloads from vc-sccs.el
+;;;### (autoloads (vc-sccs-master-templates) "vc-sccs" "vc/vc-sccs.el"
+;;;;;; (19845 45374))
+;;; 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.
@@ -29684,23 +30473,21 @@ find any project directory." (let ((project-dir (getenv "PROJECTDIR")) dirs dir)
;;;***
-;;;### (autoloads nil "vc-svn" "vc-svn.el" (19752 41642))
-;;; Generated autoloads from vc-svn.el
+;;;### (autoloads nil "vc-svn" "vc/vc-svn.el" (19845 45374))
+;;; 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"))
"_svn")
(t ".svn"))))
- (when (file-readable-p (expand-file-name
- (concat admin-dir "/entries")
- (file-name-directory f)))
+ (when (vc-find-root f admin-dir)
(load "vc-svn")
(vc-svn-registered f))))
;;;***
;;;### (autoloads (vera-mode) "vera-mode" "progmodes/vera-mode.el"
-;;;;;; (19752 41642))
+;;;;;; (19890 42850))
;;; Generated autoloads from progmodes/vera-mode.el
(add-to-list 'auto-mode-alist (cons (purecopy "\\.vr[hi]?\\'") 'vera-mode))
@@ -29758,7 +30545,7 @@ Key bindings:
;;;***
;;;### (autoloads (verilog-mode) "verilog-mode" "progmodes/verilog-mode.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from progmodes/verilog-mode.el
(autoload 'verilog-mode "verilog-mode" "\
@@ -29895,7 +30682,7 @@ Key bindings specific to `verilog-mode-map' are:
;;;***
;;;### (autoloads (vhdl-mode) "vhdl-mode" "progmodes/vhdl-mode.el"
-;;;;;; (19813 16320))
+;;;;;; (19845 45374))
;;; Generated autoloads from progmodes/vhdl-mode.el
(autoload 'vhdl-mode "vhdl-mode" "\
@@ -30436,7 +31223,7 @@ Key bindings:
;;;***
-;;;### (autoloads (vi-mode) "vi" "emulation/vi.el" (19636 58496))
+;;;### (autoloads (vi-mode) "vi" "emulation/vi.el" (19845 45374))
;;; Generated autoloads from emulation/vi.el
(autoload 'vi-mode "vi" "\
@@ -30491,7 +31278,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" (19752 41642))
+;;;;;; "language/viet-util.el" (19845 45374))
;;; Generated autoloads from language/viet-util.el
(autoload 'viet-encode-viscii-char "viet-util" "\
@@ -30524,12 +31311,12 @@ Convert Vietnamese characters of the current buffer to `VIQR' mnemonics.
\(fn)" t nil)
(autoload 'viqr-post-read-conversion "viet-util" "\
-Not documented
+
\(fn LEN)" nil nil)
(autoload 'viqr-pre-write-conversion "viet-util" "\
-Not documented
+
\(fn FROM TO)" nil nil)
@@ -30539,7 +31326,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" (19752 41642))
+;;;;;; "view" "view.el" (19886 45771))
;;; Generated autoloads from view.el
(defvar view-remove-frame-by-deleting t "\
@@ -30785,8 +31572,8 @@ Exit View mode and make the current buffer editable.
;;;***
-;;;### (autoloads (vip-mode vip-setup) "vip" "emulation/vip.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (vip-mode vip-setup) "vip" "emulation/vip.el" (19845
+;;;;;; 45374))
;;; Generated autoloads from emulation/vip.el
(autoload 'vip-setup "vip" "\
@@ -30802,7 +31589,7 @@ Turn on VIP emulation of VI.
;;;***
;;;### (autoloads (viper-mode toggle-viper-mode) "viper" "emulation/viper.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from emulation/viper.el
(autoload 'toggle-viper-mode "viper" "\
@@ -30819,7 +31606,7 @@ Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Top'.
;;;***
;;;### (autoloads (warn lwarn display-warning) "warnings" "emacs-lisp/warnings.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from emacs-lisp/warnings.el
(defvar warning-prefix-function nil "\
@@ -30909,7 +31696,7 @@ this is equivalent to `display-warning', using
;;;***
;;;### (autoloads (wdired-change-to-wdired-mode) "wdired" "wdired.el"
-;;;;;; (19752 41642))
+;;;;;; (19886 45771))
;;; Generated autoloads from wdired.el
(autoload 'wdired-change-to-wdired-mode "wdired" "\
@@ -30925,7 +31712,7 @@ See `wdired-mode'.
;;;***
-;;;### (autoloads (webjump) "webjump" "net/webjump.el" (19752 41642))
+;;;### (autoloads (webjump) "webjump" "net/webjump.el" (19845 45374))
;;; Generated autoloads from net/webjump.el
(autoload 'webjump "webjump" "\
@@ -30942,7 +31729,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from progmodes/which-func.el
(put 'which-func-format 'risky-local-variable t)
(put 'which-func-current 'risky-local-variable t)
@@ -30973,7 +31760,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" (19757 3579))
+;;;;;; whitespace-mode) "whitespace" "whitespace.el" (19901 13134))
;;; Generated autoloads from whitespace.el
(autoload 'whitespace-mode "whitespace" "\
@@ -31376,7 +32163,7 @@ cleaning up these problems.
;;;***
;;;### (autoloads (widget-minor-mode widget-browse-other-window widget-browse
-;;;;;; widget-browse-at) "wid-browse" "wid-browse.el" (19752 41642))
+;;;;;; widget-browse-at) "wid-browse" "wid-browse.el" (19886 45771))
;;; Generated autoloads from wid-browse.el
(autoload 'widget-browse-at "wid-browse" "\
@@ -31403,8 +32190,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" (19752
-;;;;;; 41642))
+;;;;;; widget-prompt-value widgetp) "wid-edit" "wid-edit.el" (19886
+;;;;;; 45771))
;;; Generated autoloads from wid-edit.el
(autoload 'widgetp "wid-edit" "\
@@ -31447,8 +32234,8 @@ Setup current buffer so editing string widgets works.
;;;***
;;;### (autoloads (windmove-default-keybindings windmove-down windmove-right
-;;;;;; windmove-up windmove-left) "windmove" "windmove.el" (19752
-;;;;;; 41642))
+;;;;;; windmove-up windmove-left) "windmove" "windmove.el" (19886
+;;;;;; 45771))
;;; Generated autoloads from windmove.el
(autoload 'windmove-left "windmove" "\
@@ -31501,7 +32288,7 @@ Default MODIFIER is 'shift.
;;;***
;;;### (autoloads (winner-mode winner-mode) "winner" "winner.el"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from winner.el
(defvar winner-mode nil "\
@@ -31519,8 +32306,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" (19752 41642))
+;;;### (autoloads (woman-bookmark-jump woman-find-file woman-dired-find-file
+;;;;;; woman woman-locale) "woman" "woman.el" (19886 45771))
;;; Generated autoloads from woman.el
(defvar woman-locale nil "\
@@ -31561,10 +32348,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"
-;;;;;; (19752 41642))
+;;;;;; (19845 45374))
;;; Generated autoloads from emulation/ws-mode.el
(autoload 'wordstar-mode "ws-mode" "\
@@ -31676,7 +32468,7 @@ The key bindings are:
;;;***
-;;;### (autoloads (xesam-search) "xesam" "net/xesam.el" (19752 41642))
+;;;### (autoloads (xesam-search) "xesam" "net/xesam.el" (19845 45374))
;;; Generated autoloads from net/xesam.el
(autoload 'xesam-search "xesam" "\
@@ -31696,7 +32488,7 @@ Example:
;;;***
;;;### (autoloads (xml-parse-region xml-parse-file) "xml" "xml.el"
-;;;;;; (19752 41642))
+;;;;;; (19886 45771))
;;; Generated autoloads from xml.el
(autoload 'xml-parse-file "xml" "\
@@ -31722,7 +32514,7 @@ If PARSE-NS is non-nil, then QNAMES are expanded.
;;;***
;;;### (autoloads (xmltok-get-declared-encoding-position) "xmltok"
-;;;;;; "nxml/xmltok.el" (19752 41642))
+;;;;;; "nxml/xmltok.el" (19845 45374))
;;; Generated autoloads from nxml/xmltok.el
(autoload 'xmltok-get-declared-encoding-position "xmltok" "\
@@ -31740,8 +32532,8 @@ If LIMIT is non-nil, then do not consider characters beyond LIMIT.
;;;***
-;;;### (autoloads (xterm-mouse-mode) "xt-mouse" "xt-mouse.el" (19752
-;;;;;; 41642))
+;;;### (autoloads (xterm-mouse-mode) "xt-mouse" "xt-mouse.el" (19886
+;;;;;; 45771))
;;; Generated autoloads from xt-mouse.el
(defvar xterm-mouse-mode nil "\
@@ -31770,7 +32562,7 @@ down the SHIFT key while pressing the mouse button.
;;;***
;;;### (autoloads (yenc-extract-filename yenc-decode-region) "yenc"
-;;;;;; "gnus/yenc.el" (19752 41642))
+;;;;;; "gnus/yenc.el" (19845 45374))
;;; Generated autoloads from gnus/yenc.el
(autoload 'yenc-decode-region "yenc" "\
@@ -31786,7 +32578,7 @@ Extract file name from an yenc header.
;;;***
;;;### (autoloads (psychoanalyze-pinhead apropos-zippy insert-zippyism
-;;;;;; yow) "yow" "play/yow.el" (19752 41642))
+;;;;;; yow) "yow" "play/yow.el" (19845 45374))
;;; Generated autoloads from play/yow.el
(autoload 'yow "yow" "\
@@ -31812,7 +32604,7 @@ Zippy goes to the analyst.
;;;***
-;;;### (autoloads (zone) "zone" "play/zone.el" (19752 41642))
+;;;### (autoloads (zone) "zone" "play/zone.el" (19889 21967))
;;; Generated autoloads from play/zone.el
(autoload 'zone "zone" "\
@@ -31833,42 +32625,41 @@ Zone out, completely.
;;;;;; "calc/calc-mtx.el" "calc/calc-nlfit.el" "calc/calc-poly.el"
;;;;;; "calc/calc-prog.el" "calc/calc-rewr.el" "calc/calc-rules.el"
;;;;;; "calc/calc-sel.el" "calc/calc-stat.el" "calc/calc-store.el"
-;;;;;; "calc/calc-stuff.el" "calc/calc-trail.el" "calc/calc-undo.el"
-;;;;;; "calc/calc-units.el" "calc/calc-vec.el" "calc/calc-yank.el"
-;;;;;; "calc/calcalg2.el" "calc/calcalg3.el" "calc/calccomp.el"
-;;;;;; "calc/calcsel2.el" "calendar/cal-bahai.el" "calendar/cal-coptic.el"
-;;;;;; "calendar/cal-french.el" "calendar/cal-html.el" "calendar/cal-islam.el"
-;;;;;; "calendar/cal-iso.el" "calendar/cal-julian.el" "calendar/cal-loaddefs.el"
-;;;;;; "calendar/cal-mayan.el" "calendar/cal-menu.el" "calendar/cal-move.el"
-;;;;;; "calendar/cal-persia.el" "calendar/cal-tex.el" "calendar/cal-x.el"
-;;;;;; "calendar/diary-loaddefs.el" "calendar/hol-loaddefs.el" "cdl.el"
-;;;;;; "cedet/cedet-cscope.el" "cedet/cedet-files.el" "cedet/cedet-global.el"
-;;;;;; "cedet/cedet-idutils.el" "cedet/cedet.el" "cedet/ede/auto.el"
-;;;;;; "cedet/ede/autoconf-edit.el" "cedet/ede/base.el" "cedet/ede/cpp-root.el"
-;;;;;; "cedet/ede/custom.el" "cedet/ede/dired.el" "cedet/ede/emacs.el"
-;;;;;; "cedet/ede/files.el" "cedet/ede/generic.el" "cedet/ede/linux.el"
-;;;;;; "cedet/ede/locate.el" "cedet/ede/make.el" "cedet/ede/makefile-edit.el"
-;;;;;; "cedet/ede/pconf.el" "cedet/ede/pmake.el" "cedet/ede/proj-archive.el"
-;;;;;; "cedet/ede/proj-aux.el" "cedet/ede/proj-comp.el" "cedet/ede/proj-elisp.el"
-;;;;;; "cedet/ede/proj-info.el" "cedet/ede/proj-misc.el" "cedet/ede/proj-obj.el"
-;;;;;; "cedet/ede/proj-prog.el" "cedet/ede/proj-scheme.el" "cedet/ede/proj-shared.el"
-;;;;;; "cedet/ede/proj.el" "cedet/ede/project-am.el" "cedet/ede/shell.el"
-;;;;;; "cedet/ede/simple.el" "cedet/ede/source.el" "cedet/ede/speedbar.el"
-;;;;;; "cedet/ede/srecode.el" "cedet/ede/system.el" "cedet/ede/util.el"
-;;;;;; "cedet/inversion.el" "cedet/mode-local.el" "cedet/pulse.el"
-;;;;;; "cedet/semantic/analyze.el" "cedet/semantic/analyze/complete.el"
-;;;;;; "cedet/semantic/analyze/debug.el" "cedet/semantic/analyze/fcn.el"
-;;;;;; "cedet/semantic/analyze/refs.el" "cedet/semantic/bovine.el"
-;;;;;; "cedet/semantic/bovine/c-by.el" "cedet/semantic/bovine/c.el"
-;;;;;; "cedet/semantic/bovine/debug.el" "cedet/semantic/bovine/el.el"
-;;;;;; "cedet/semantic/bovine/gcc.el" "cedet/semantic/bovine/make-by.el"
-;;;;;; "cedet/semantic/bovine/make.el" "cedet/semantic/bovine/scm-by.el"
-;;;;;; "cedet/semantic/bovine/scm.el" "cedet/semantic/chart.el"
-;;;;;; "cedet/semantic/complete.el" "cedet/semantic/ctxt.el" "cedet/semantic/db-debug.el"
-;;;;;; "cedet/semantic/db-ebrowse.el" "cedet/semantic/db-el.el"
-;;;;;; "cedet/semantic/db-file.el" "cedet/semantic/db-find.el" "cedet/semantic/db-global.el"
-;;;;;; "cedet/semantic/db-javascript.el" "cedet/semantic/db-mode.el"
-;;;;;; "cedet/semantic/db-ref.el" "cedet/semantic/db-typecache.el"
+;;;;;; "calc/calc-stuff.el" "calc/calc-trail.el" "calc/calc-units.el"
+;;;;;; "calc/calc-vec.el" "calc/calc-yank.el" "calc/calcalg2.el"
+;;;;;; "calc/calcalg3.el" "calc/calccomp.el" "calc/calcsel2.el"
+;;;;;; "calendar/cal-bahai.el" "calendar/cal-coptic.el" "calendar/cal-french.el"
+;;;;;; "calendar/cal-html.el" "calendar/cal-islam.el" "calendar/cal-iso.el"
+;;;;;; "calendar/cal-julian.el" "calendar/cal-loaddefs.el" "calendar/cal-mayan.el"
+;;;;;; "calendar/cal-menu.el" "calendar/cal-move.el" "calendar/cal-persia.el"
+;;;;;; "calendar/cal-tex.el" "calendar/cal-x.el" "calendar/diary-loaddefs.el"
+;;;;;; "calendar/hol-loaddefs.el" "cdl.el" "cedet/cedet-cscope.el"
+;;;;;; "cedet/cedet-files.el" "cedet/cedet-global.el" "cedet/cedet-idutils.el"
+;;;;;; "cedet/cedet.el" "cedet/ede/auto.el" "cedet/ede/autoconf-edit.el"
+;;;;;; "cedet/ede/base.el" "cedet/ede/cpp-root.el" "cedet/ede/custom.el"
+;;;;;; "cedet/ede/dired.el" "cedet/ede/emacs.el" "cedet/ede/files.el"
+;;;;;; "cedet/ede/generic.el" "cedet/ede/linux.el" "cedet/ede/locate.el"
+;;;;;; "cedet/ede/make.el" "cedet/ede/makefile-edit.el" "cedet/ede/pconf.el"
+;;;;;; "cedet/ede/pmake.el" "cedet/ede/proj-archive.el" "cedet/ede/proj-aux.el"
+;;;;;; "cedet/ede/proj-comp.el" "cedet/ede/proj-elisp.el" "cedet/ede/proj-info.el"
+;;;;;; "cedet/ede/proj-misc.el" "cedet/ede/proj-obj.el" "cedet/ede/proj-prog.el"
+;;;;;; "cedet/ede/proj-scheme.el" "cedet/ede/proj-shared.el" "cedet/ede/proj.el"
+;;;;;; "cedet/ede/project-am.el" "cedet/ede/shell.el" "cedet/ede/simple.el"
+;;;;;; "cedet/ede/source.el" "cedet/ede/speedbar.el" "cedet/ede/srecode.el"
+;;;;;; "cedet/ede/system.el" "cedet/ede/util.el" "cedet/inversion.el"
+;;;;;; "cedet/mode-local.el" "cedet/pulse.el" "cedet/semantic/analyze.el"
+;;;;;; "cedet/semantic/analyze/complete.el" "cedet/semantic/analyze/debug.el"
+;;;;;; "cedet/semantic/analyze/fcn.el" "cedet/semantic/analyze/refs.el"
+;;;;;; "cedet/semantic/bovine.el" "cedet/semantic/bovine/c-by.el"
+;;;;;; "cedet/semantic/bovine/c.el" "cedet/semantic/bovine/debug.el"
+;;;;;; "cedet/semantic/bovine/el.el" "cedet/semantic/bovine/gcc.el"
+;;;;;; "cedet/semantic/bovine/make-by.el" "cedet/semantic/bovine/make.el"
+;;;;;; "cedet/semantic/bovine/scm-by.el" "cedet/semantic/bovine/scm.el"
+;;;;;; "cedet/semantic/chart.el" "cedet/semantic/complete.el" "cedet/semantic/ctxt.el"
+;;;;;; "cedet/semantic/db-debug.el" "cedet/semantic/db-ebrowse.el"
+;;;;;; "cedet/semantic/db-el.el" "cedet/semantic/db-file.el" "cedet/semantic/db-find.el"
+;;;;;; "cedet/semantic/db-global.el" "cedet/semantic/db-javascript.el"
+;;;;;; "cedet/semantic/db-mode.el" "cedet/semantic/db-ref.el" "cedet/semantic/db-typecache.el"
;;;;;; "cedet/semantic/db.el" "cedet/semantic/debug.el" "cedet/semantic/decorate.el"
;;;;;; "cedet/semantic/decorate/include.el" "cedet/semantic/decorate/mode.el"
;;;;;; "cedet/semantic/dep.el" "cedet/semantic/doc.el" "cedet/semantic/ede-grammar.el"
@@ -31898,17 +32689,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"
+;;;;;; "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-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"
-;;;;;; "emacs-lisp/smie.el" "emacs-lisp/sregex.el" "emacs-lisp/tcover-ses.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/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"
;;;;;; "emulation/edt-pc.el" "emulation/edt-vt100.el" "emulation/tpu-extras.el"
@@ -31924,98 +32713,108 @@ 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"
+;;;;;; "ezimage.el" "foldout.el" "format-spec.el" "forms-d2.el"
+;;;;;; "forms-pass.el" "fringe.el" "generic-x.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/gnus-uu.el" "gnus/gnus-vm.el" "gnus/gssapi.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"
-;;;;;; "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"
-;;;;;; "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"
-;;;;;; "json.el" "kermit.el" "language/hanja-util.el" "language/thai-word.el"
-;;;;;; "ldefs-boot.el" "mail/blessmail.el" "mail/mailheader.el"
-;;;;;; "mail/mailpost.el" "mail/mspools.el" "mail/rfc2368.el" "mail/rfc822.el"
-;;;;;; "mail/rmail-spam-filter.el" "mail/rmailedit.el" "mail/rmailkwd.el"
-;;;;;; "mail/rmailmm.el" "mail/rmailmsc.el" "mail/rmailsort.el"
-;;;;;; "mail/rmailsum.el" "mail/undigest.el" "md4.el" "mh-e/mh-acros.el"
-;;;;;; "mh-e/mh-alias.el" "mh-e/mh-buffers.el" "mh-e/mh-compat.el"
-;;;;;; "mh-e/mh-funcs.el" "mh-e/mh-gnus.el" "mh-e/mh-identity.el"
-;;;;;; "mh-e/mh-inc.el" "mh-e/mh-junk.el" "mh-e/mh-letter.el" "mh-e/mh-limit.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/registry.el" "gnus/rfc1843.el" "gnus/rfc2045.el" "gnus/rfc2047.el"
+;;;;;; "gnus/rfc2104.el" "gnus/rfc2231.el" "gnus/rtree.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" "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" "json.el" "kermit.el" "language/hanja-util.el"
+;;;;;; "language/thai-word.el" "ldefs-boot.el" "mail/blessmail.el"
+;;;;;; "mail/mailheader.el" "mail/mailpost.el" "mail/mspools.el"
+;;;;;; "mail/rfc2368.el" "mail/rfc822.el" "mail/rmail-spam-filter.el"
+;;;;;; "mail/rmailedit.el" "mail/rmailkwd.el" "mail/rmailmm.el"
+;;;;;; "mail/rmailmsc.el" "mail/rmailsort.el" "mail/rmailsum.el"
+;;;;;; "mail/undigest.el" "md4.el" "mh-e/mh-acros.el" "mh-e/mh-alias.el"
+;;;;;; "mh-e/mh-buffers.el" "mh-e/mh-compat.el" "mh-e/mh-funcs.el"
+;;;;;; "mh-e/mh-gnus.el" "mh-e/mh-identity.el" "mh-e/mh-inc.el"
+;;;;;; "mh-e/mh-junk.el" "mh-e/mh-letter.el" "mh-e/mh-limit.el"
;;;;;; "mh-e/mh-loaddefs.el" "mh-e/mh-mime.el" "mh-e/mh-print.el"
;;;;;; "mh-e/mh-scan.el" "mh-e/mh-search.el" "mh-e/mh-seq.el" "mh-e/mh-show.el"
;;;;;; "mh-e/mh-speed.el" "mh-e/mh-thread.el" "mh-e/mh-tool-bar.el"
;;;;;; "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/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"
+;;;;;; "net/gnutls.el" "net/hmac-def.el" "net/hmac-md5.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/soap-client.el" "net/soap-inspect.el"
+;;;;;; "net/socks.el" "net/tls.el" "net/tramp-cache.el" "net/tramp-cmds.el"
+;;;;;; "net/tramp-compat.el" "net/tramp-gvfs.el" "net/tramp-gw.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-datetree.el" "org/org-exp-blocks.el"
+;;;;;; "org/org-complete.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-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"
-;;;;;; "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"
-;;;;;; "progmodes/cc-defs.el" "progmodes/cc-fonts.el" "progmodes/cc-langs.el"
-;;;;;; "progmodes/cc-menus.el" "progmodes/ebnf-abn.el" "progmodes/ebnf-bnf.el"
-;;;;;; "progmodes/ebnf-dtd.el" "progmodes/ebnf-ebx.el" "progmodes/ebnf-iso.el"
-;;;;;; "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"
-;;;;;; "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"
-;;;;;; "textmodes/texnfo-upd.el" "timezone.el" "tooltip.el" "tree-widget.el"
-;;;;;; "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") (19820
-;;;;;; 23317 611837))
+;;;;;; "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" "patcomp.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" "progmodes/cc-defs.el" "progmodes/cc-fonts.el"
+;;;;;; "progmodes/cc-langs.el" "progmodes/cc-menus.el" "progmodes/ebnf-abn.el"
+;;;;;; "progmodes/ebnf-bnf.el" "progmodes/ebnf-dtd.el" "progmodes/ebnf-ebx.el"
+;;;;;; "progmodes/ebnf-iso.el" "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" "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" "textmodes/texnfo-upd.el" "timezone.el"
+;;;;;; "tooltip.el" "tree-widget.el" "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/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") (19901
+;;;;;; 13383 538856))
;;;***
diff --git a/lisp/ledit.el b/lisp/ledit.el
index 034f61317fa..09fe5001161 100644
--- a/lisp/ledit.el
+++ b/lisp/ledit.el
@@ -1,7 +1,6 @@
;;; ledit.el --- Emacs side of ledit interface
-;; Copyright (C) 1985, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: languages
@@ -154,5 +153,4 @@ do (setq lisp-mode-hook 'ledit-from-lisp-mode)"
(provide 'ledit)
-;; arch-tag: f0f1ca13-8d31-478c-ae1b-b448c55a8faf
;;; ledit.el ends here
diff --git a/lisp/linum.el b/lisp/linum.el
index b7e69e2a7c6..db6e4c49977 100644
--- a/lisp/linum.el
+++ b/lisp/linum.el
@@ -1,10 +1,11 @@
-;;; linum.el --- display line numbers in the left margin
+;;; linum.el --- display line numbers in the left margin -*- lexical-binding: t -*-
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Markus Triska <markus.triska@gmx.at>
;; Maintainer: FSF
;; Keywords: convenience
+;; Version: 0.9x
;; This file is part of GNU Emacs.
@@ -173,14 +174,14 @@ and you have to scroll or press \\[recenter-top-bottom] to update the numbers."
(setq line (1+ line)))
(set-window-margins win width (cdr (window-margins win)))))
-(defun linum-after-change (beg end len)
+(defun linum-after-change (beg end _len)
;; update overlays on deletions, and after newlines are inserted
(when (or (= beg end)
(= end (point-max))
(string-match-p "\n" (buffer-substring-no-properties beg end)))
(linum-update-current)))
-(defun linum-after-scroll (win start)
+(defun linum-after-scroll (win _start)
(linum-update (window-buffer win)))
;; (defun linum-after-size (frame)
@@ -201,5 +202,4 @@ and you have to scroll or press \\[recenter-top-bottom] to update the numbers."
(provide 'linum)
-;; arch-tag: dea45631-ed3c-4867-8b49-1c41c80aec6a
;;; linum.el ends here
diff --git a/lisp/loadhist.el b/lisp/loadhist.el
index 17f4035bf2a..3395c41d2ff 100644
--- a/lisp/loadhist.el
+++ b/lisp/loadhist.el
@@ -1,7 +1,6 @@
;;; loadhist.el --- lisp functions for working with feature groups
-;; Copyright (C) 1995, 1998, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 1998, 2000-2011 Free Software Foundation, Inc.
;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
;; Maintainer: FSF
@@ -267,5 +266,4 @@ something strange, such as redefining an Emacs function."
(provide 'loadhist)
-;; arch-tag: 70bb846a-c413-4f01-bf88-78dba4ac0798
;;; loadhist.el ends here
diff --git a/lisp/loadup.el b/lisp/loadup.el
index b6e49fdfa2a..d348456ae32 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -1,10 +1,11 @@
;;; loadup.el --- load up standardly loaded Lisp files for Emacs
-;; Copyright (C) 1985, 1986, 1992, 1994, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1986, 1992, 1994, 2001-2011
+;; Free Software Foundation, Inc.
;; 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"))
@@ -101,7 +106,6 @@
(load "cus-face")
(load "faces") ; after here, `defface' may be used.
-(load "minibuffer")
(load "button")
(load "startup")
@@ -112,6 +116,7 @@
;; In case loaddefs hasn't been generated yet.
(file-error (load "ldefs-boot.el")))
+(load "minibuffer")
(load "abbrev") ;lisp-mode.el and simple.el use define-abbrev-table.
(load "simple")
@@ -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
@@ -259,7 +263,7 @@
(let* ((base (concat "emacs-" emacs-version "."))
(files (file-name-all-completions base default-directory))
(versions (mapcar (function (lambda (name)
- (string-to-int (substring name (length base)))))
+ (string-to-number (substring name (length base)))))
files)))
;; `emacs-version' is a constant, so we shouldn't change it with `setq'.
(defconst emacs-version
@@ -288,46 +292,16 @@
(error nil)))
(message "Finding pointers to doc strings...done")
-;;;Note: You can cause additional libraries to be preloaded
-;;;by writing a site-init.el that loads them.
-;;;See also "site-load" above.
+;; Note: You can cause additional libraries to be preloaded
+;; by writing a site-init.el that loads them.
+;; See also "site-load" above.
(load "site-init" t)
(setq current-load-list nil)
-;; Write the value of load-history into fns-VERSION.el,
-;; then clear out load-history.
-;; (if (or (equal (nth 3 command-line-args) "dump")
-;; (equal (nth 4 command-line-args) "dump"))
-;; (let ((buffer-undo-list t))
-;; (princ "(setq load-history\n" (current-buffer))
-;; (princ " (nconc load-history\n" (current-buffer))
-;; (princ " '(" (current-buffer))
-;; (let ((tem load-history))
-;; (while tem
-;; (prin1 (car tem) (current-buffer))
-;; (terpri (current-buffer))
-;; (if (cdr tem)
-;; (princ " " (current-buffer)))
-;; (setq tem (cdr tem))))
-;; (princ ")))\n" (current-buffer))
-;; (write-region (point-min) (point-max)
-;; (expand-file-name
-;; (cond
-;; ((eq system-type 'ms-dos)
-;; "../lib-src/fns.el")
-;; ((eq system-type 'windows-nt)
-;; (format "../../../lib-src/fns-%s.el" emacs-version))
-;; (t
-;; (format "../lib-src/fns-%s.el" emacs-version)))
-;; invocation-directory))
-;; (erase-buffer)
-;; (setq load-history nil))
-;; (setq symbol-file-load-history-loaded t))
-;; We don't use this fns-*.el file. Instead we keep the data in PURE space.
+;; We keep the load-history data in PURE space.
;; Make sure that the spine of the list is not in pure space because it can
;; be destructively mutated in lread.c:build_load_history.
(setq load-history (mapcar 'purecopy load-history))
-(setq symbol-file-load-history-loaded t)
(set-buffer-modified-p nil)
@@ -345,6 +319,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))
@@ -364,7 +342,7 @@
(dump-emacs "emacs" "temacs")
(message "%d pure bytes used" pure-bytes-used)
;; Recompute NAME now, so that it isn't set when we dump.
- (if (not (or (memq system-type '(ms-dos windows-nt cygwin))
+ (if (not (or (memq system-type '(ms-dos windows-nt))
;; Don't bother adding another name if we're just
;; building bootstrap-emacs.
(equal (nth 3 command-line-args) "bootstrap")
@@ -378,9 +356,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 +372,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 9ace0e84c33..2ac2d30f41d 100644
--- a/lisp/locate.el
+++ b/lisp/locate.el
@@ -1,7 +1,6 @@
;;; locate.el --- interface to the locate command
-;; Copyright (C) 1996, 1998, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1998, 2001-2011 Free Software Foundation, Inc.
;; Author: Peter Breton <pbreton@cs.umb.edu>
;; Keywords: unix files
@@ -97,7 +96,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 +334,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.
@@ -589,7 +588,7 @@ do not work in subdirectories.
(message "This command only works inside main listing.")))
;; From Stephen Eglen <stephen@cns.ed.ac.uk>
-(defun locate-update (ignore1 ignore2)
+(defun locate-update (_ignore1 _ignore2)
"Revert the *Locate* buffer.
If `locate-update-when-revert' is non-nil, offer to update the
locate database using the shell command in `locate-update-command'."
diff --git a/lisp/longlines.el b/lisp/longlines.el
index e00e666b242..387ce394f50 100644
--- a/lisp/longlines.el
+++ b/lisp/longlines.el
@@ -1,6 +1,6 @@
;;; longlines.el --- automatically wrap long lines -*- coding:utf-8 -*-
-;; Copyright (C) 2000, 2001, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2001, 2004-2011 Free Software Foundation, Inc.
;; Authors: Kai Grossjohann <Kai.Grossjohann@CS.Uni-Dortmund.DE>
;; Alex Schroeder <alex@gnu.org>
@@ -370,7 +370,7 @@ If BEG and END are nil, the point and mark are used."
"Turn all newlines in the buffer into hard newlines."
(longlines-decode-region (point-min) (point-max)))
-(defun longlines-encode-region (beg end &optional buffer)
+(defun longlines-encode-region (beg end &optional _buffer)
"Replace each soft newline between BEG and END with exactly one space.
Hard newlines are left intact. The optional argument BUFFER exists for
compatibility with `format-alist', and is ignored."
@@ -413,7 +413,7 @@ If automatic line wrapping is turned on, wrap the entire buffer."
(setq longlines-auto-wrap nil)
(message "Auto wrap disabled.")))
-(defun longlines-after-change-function (beg end len)
+(defun longlines-after-change-function (beg end _len)
"Update `longlines-wrap-beg' and `longlines-wrap-end'.
This is called by `after-change-functions' to keep track of the region
that has changed."
@@ -503,5 +503,4 @@ This is called by `window-configuration-change-hook'."
(provide 'longlines)
-;; arch-tag: 3489d225-5506-47b9-8659-d8807b77c624
;;; longlines.el ends here
diff --git a/lisp/lpr.el b/lisp/lpr.el
index 466bab58b74..76c69f3308c 100644
--- a/lisp/lpr.el
+++ b/lisp/lpr.el
@@ -1,7 +1,7 @@
;;; lpr.el --- print Emacs buffer on line printer
-;; Copyright (C) 1985, 1988, 1992, 1994, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1988, 1992, 1994, 2001-2011
+;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: unix
@@ -29,6 +29,8 @@
;;; Code:
+(eval-when-compile (require 'cl))
+
;;;###autoload
(defvar lpr-windows-system
(memq system-type '(ms-dos windows-nt)))
@@ -258,21 +260,30 @@ for further customization of the printer command."
lpr-page-header-switches)))
(setq start (point-min)
end (point-max))))
- (apply (or print-region-function 'call-process-region)
- (nconc (list start end lpr-command
- nil nil nil)
- (and lpr-add-switches
- (list "-J" name))
- ;; These belong in pr if we are using that.
- (and lpr-add-switches lpr-headers-switches
- (list "-T" title))
- (and (stringp printer-name)
- (list (concat lpr-printer-switch
- printer-name)))
- nswitches))
- (if (markerp end)
- (set-marker end nil))
- (message "Spooling%s...done" switch-string))))
+ (let ((buf (current-buffer)))
+ (with-temp-buffer
+ (let ((tempbuf (current-buffer)))
+ (with-current-buffer buf
+ (apply (or print-region-function 'call-process-region)
+ (nconc (list start end lpr-command
+ nil tempbuf nil)
+ (and lpr-add-switches
+ (list "-J" name))
+ ;; These belong in pr if we are using that.
+ (and lpr-add-switches lpr-headers-switches
+ (list "-T" title))
+ (and (stringp printer-name)
+ (list (concat lpr-printer-switch
+ printer-name)))
+ nswitches))))
+ (if (markerp end)
+ (set-marker end nil))
+ (message "Spooling%s...done%s%s" switch-string
+ (case (count-lines (point-min) (point-max))
+ (0 "")
+ (1 ": ")
+ (t ":\n"))
+ (buffer-string)))))))
;; This function copies the text between start and end
;; into a new buffer, makes that buffer current.
@@ -301,7 +312,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))))))))
@@ -337,5 +348,4 @@ The characters tab, linefeed, space, return and formfeed are not affected."
(provide 'lpr)
-;; arch-tag: 21c3f821-ebec-4ca9-ac67-a81e4b75c62a
;;; lpr.el ends here
diff --git a/lisp/ls-lisp.el b/lisp/ls-lisp.el
index ed7b5640e20..14a8cabf1a7 100644
--- a/lisp/ls-lisp.el
+++ b/lisp/ls-lisp.el
@@ -1,12 +1,12 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 1994, 2000-2011 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.
@@ -62,28 +62,42 @@
;;; Code:
-(eval-when-compile (require 'cl))
-
(defgroup ls-lisp nil
"Emulate the ls program completely in Emacs Lisp."
: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 +111,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 +119,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 +135,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 +179,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 +190,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,13 +324,12 @@ 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)
(max-file-size 0)
;; do all bindings here for speed
- total-line files elt short file-size fil attr
+ total-line files elt short file-size attr
fuid fgid uid-len gid-len)
(cond ((memq ?A switches)
(setq file-alist
@@ -378,7 +394,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 +433,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 +507,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 +606,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 +667,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 +685,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.
@@ -723,15 +724,8 @@ All ls time options, namely c, t and u, are handled."
ls-lisp-filesize-f-fmt
ls-lisp-filesize-d-fmt)
file-size)
- (if (< file-size 1024)
- (format " %4d" file-size)
- (do ((file-size (/ file-size 1024.0) (/ file-size 1024.0))
- ;; kilo, mega, giga, tera, peta, exa
- (post-fixes (list "k" "M" "G" "T" "P" "E") (cdr post-fixes)))
- ((< file-size 1024)
- (format " %3.0f%s" file-size (car post-fixes)))))))
+ (format " %7s" (file-size-human-readable file-size))))
(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 5c62cdb59ea..554f89a8a60 100644
--- a/lisp/macros.el
+++ b/lisp/macros.el
@@ -1,10 +1,11 @@
;;; macros.el --- non-primitive commands for keyboard macros
-;; Copyright (C) 1985, 1986, 1987, 1992, 1994, 1995, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1987, 1992, 1994-1995, 2001-2011
+;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: abbrev
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -126,7 +127,7 @@ use this command, and then save the file."
(delete-region (point) (1+ (point)))
(insert "\\M-\\C-?"))))))
(if (vectorp definition)
- (let ((len (length definition)) (i 0) char mods)
+ (let ((len (length definition)) (i 0) char)
(while (< i len)
(insert (if (zerop i) ?\[ ?\s))
(setq char (aref definition i)
@@ -282,5 +283,4 @@ and then select the region of un-tablified names and use
(provide 'macros)
-;; arch-tag: 346ed1a5-1220-4bc8-b533-961ee704361f
;;; macros.el ends here
diff --git a/lisp/mail/binhex.el b/lisp/mail/binhex.el
index 13738f0c0a9..5332c0f14ba 100644
--- a/lisp/mail/binhex.el
+++ b/lisp/mail/binhex.el
@@ -1,7 +1,6 @@
;;; binhex.el --- decode BinHex-encoded text
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
;; Keywords: binhex news
@@ -226,7 +225,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
@@ -332,5 +332,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 3e58205d47d..b614fffb69d 100644
--- a/lisp/mail/blessmail.el
+++ b/lisp/mail/blessmail.el
@@ -1,10 +1,10 @@
;;; blessmail.el --- decide whether movemail needs special privileges -*- no-byte-compile: t -*-
-;; Copyright (C) 1994, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -65,5 +65,4 @@
(write-region (point-min) (point-max) "blessmail")
(kill-emacs)
-;; arch-tag: c3329fe2-f945-41a9-8b00-b4b038ff182f
;;; blessmail.el ends here
diff --git a/lisp/mail/emacsbug.el b/lisp/mail/emacsbug.el
index 926d3e91af5..9aac041e8bd 100644
--- a/lisp/mail/emacsbug.el
+++ b/lisp/mail/emacsbug.el
@@ -1,12 +1,12 @@
;;; emacsbug.el --- command to report Emacs bugs to appropriate mailing list
-;; Copyright (C) 1985, 1994, 1997, 1998, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
+;; Copyright (C) 1985, 1994, 1997-1998, 2000-2011
;; Free Software Foundation, Inc.
;; Author: K. Shane Hartman
;; Maintainer: FSF
;; Keywords: maint mail
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -32,22 +32,21 @@
;;; Code:
+(require 'url-util)
+
(defgroup emacsbug nil
"Sending Emacs bug reports."
: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 +59,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 +77,63 @@
(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-osx-open ()
+ "Check if OSX open can be used to insert bug report into mailer"
+ (and (featurep 'ns)
+ (equal (executable-find "open") "/usr/bin/open")
+ (memq system-type '(darwin))))
+
+(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)
+ (if (report-emacs-bug-can-use-osx-open)
+ (start-process "/usr/bin/open" nil "open"
+ (concat "mailto:" to
+ "?subject=" (url-hexify-string subject)
+ "&body=" (url-hexify-string 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 +148,27 @@ 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-insert-mail (or (report-emacs-bug-can-use-xdg-email)
+ (report-emacs-bug-can-use-osx-open)))
+ 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 +177,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 +189,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,16 +289,14 @@ 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)
- ;; 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"
- report-emacs-bug-send-hook 'message-send-hook))
- ((eq mail-user-agent 'sendmail-user-agent)
- (setq report-emacs-bug-send-command "mail-send-and-exit"
- report-emacs-bug-send-hook 'mail-send-hook))
- ((eq mail-user-agent 'mh-e-user-agent)
- (setq report-emacs-bug-send-command "mh-send-letter"
- report-emacs-bug-send-hook 'mh-before-send-letter-hook)))
+ (if can-insert-mail
+ (define-key (current-local-map) "\C-cm"
+ 'report-emacs-bug-insert-to-mailer))
+ (setq report-emacs-bug-send-command (get mail-user-agent 'sendfunc)
+ report-emacs-bug-send-hook (get mail-user-agent 'hookvar))
+ (if report-emacs-bug-send-command
+ (setq report-emacs-bug-send-command
+ (symbol-name report-emacs-bug-send-command)))
(unless report-emacs-bug-no-explanations
(with-output-to-temp-buffer "*Bug Help*"
(princ "While in the mail buffer:\n\n")
@@ -259,6 +306,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-insert-mail
+ (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
@@ -290,18 +340,6 @@ usually do not have translators to read other languages for them.\n\n")
(string-equal (buffer-substring-no-properties (point-min) (point))
report-emacs-bug-orig-text)
(error "No text entered in bug report"))
- ;; Check the buffer contents and reject non-English letters.
- ;; FIXME message-mode probably does this anyway.
- (goto-char (point-min))
- (skip-chars-forward "\0-\177")
- (unless (eobp)
- (if (or report-emacs-bug-no-confirmation
- (y-or-n-p "Convert non-ASCII letters to hexadecimal? "))
- (while (progn (skip-chars-forward "\0-\177")
- (not (eobp)))
- (let ((ch (following-char)))
- (delete-char 1)
- (insert (format "=%02x" ch))))))
;; The last warning for novice users.
(unless (or report-emacs-bug-no-confirmation
@@ -335,6 +373,90 @@ and send the mail again%s."
'field 'emacsbug-prompt))
(delete-region pos (field-end (1+ pos)))))))
+
+;; Querying the bug database
+
+(defvar report-emacs-bug-bug-alist nil)
+(make-variable-buffer-local 'report-emacs-bug-bug-alist)
+(defvar report-emacs-bug-choice-widget nil)
+(make-variable-buffer-local 'report-emacs-bug-choice-widget)
+
+(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)
+ (setq report-emacs-bug-bug-alist bugs)
+ (widget-insert (propertize (concat "Already known bugs ("
+ keywords "):\n\n")
+ 'face 'bold))
+ (if bugs
+ (setq report-emacs-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 (nth 2 bug))
+ ": " (cadr bug) "\n %[%v%]\n")
+ ;; FIXME: Why is only the link of the
+ ;; active item clickable?
+ (car 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 report-emacs-bug-choice-widget)))
+ ;; TODO: Do something!
+ (message "Appending to bug %s!"
+ (nth 2 (assoc val report-emacs-bug-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..597344fb88a 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)
@@ -2662,5 +2662,4 @@ been weeded out."
(provide 'feedmail)
-;; arch-tag: ec27b380-11c0-4dfd-8436-f636cf2bb992
;;; feedmail.el ends here
diff --git a/lisp/mail/footnote.el b/lisp/mail/footnote.el
index 82928642f3f..8dac3be0e5f 100644
--- a/lisp/mail/footnote.el
+++ b/lisp/mail/footnote.el
@@ -1,7 +1,6 @@
-;;; footnote.el --- footnote support for message mode -*- coding: iso-latin-1;-*-
+;;; footnote.el --- footnote support for message mode -*- coding: utf-8;-*-
-;; Copyright (C) 1997, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2000-2011 Free Software Foundation, Inc.
;; Author: Steven L Baur <steve@xemacs.org>
;; Keywords: mail, news
@@ -279,7 +278,7 @@ Wrapping around the alphabet implies successive repetitions of letters."
;; Latin-1
-(defconst footnote-latin-string ""
+(defconst footnote-latin-string "¹²³ºª§¶"
"String of Latin-1 footnoting characters.")
;; Note not [...]+, because this style cycles.
@@ -292,6 +291,25 @@ Use a range of Latin-1 non-ASCII characters for footnoting."
(string (aref footnote-latin-string
(mod (1- n) (length footnote-latin-string)))))
+;; Unicode
+
+(defconst footnote-unicode-string "⁰¹²³⁴⁵⁶⁷⁸⁹"
+ "String of unicode footnoting characters.")
+
+(defconst footnote-unicode-regexp (concat "[" footnote-unicode-string "]+")
+ "Regexp for unicode footnoting characters.")
+
+(defun Footnote-unicode (n)
+ "Unicode footnote style.
+Use unicode characters for footnoting."
+ (let (modulus result done)
+ (while (not done)
+ (setq modulus (mod n 10)
+ n (truncate n 10))
+ (and (zerop n) (setq done t))
+ (push (aref footnote-unicode-string modulus) result))
+ (apply #'string result)))
+
;;; list of all footnote styles
(defvar footnote-style-alist
`((numeric Footnote-numeric ,footnote-numeric-regexp)
@@ -299,7 +317,8 @@ Use a range of Latin-1 non-ASCII characters for footnoting."
(english-upper Footnote-english-upper ,footnote-english-upper-regexp)
(roman-lower Footnote-roman-lower ,footnote-roman-lower-regexp)
(roman-upper Footnote-roman-upper ,footnote-roman-upper-regexp)
- (latin Footnote-latin ,footnote-latin-regexp))
+ (latin Footnote-latin ,footnote-latin-regexp)
+ (unicode Footnote-unicode ,footnote-unicode-regexp))
"Styles of footnote tags available.
By default only boring Arabic numbers, English letters and Roman Numerals
are available.
@@ -313,9 +332,13 @@ english-lower == a, b, c, ...
english-upper == A, B, C, ...
roman-lower == i, ii, iii, iv, v, ...
roman-upper == I, II, III, IV, V, ...
-latin ==
+latin == ¹ ² ³ º ª § ¶
+unicode == ¹, ², ³, ...
See also variables `footnote-start-tag' and `footnote-end-tag'.
+Note: some characters in the unicode style may not show up
+properly if the default font does not contain those characters.
+
Customizing this variable has no effect on buffers already
displaying footnotes. To change the style of footnotes in such a
buffer use the command `Footnote-set-style'."
@@ -797,5 +820,4 @@ started, play around with the following keys:
(provide 'footnote)
-;; arch-tag: 9bcfb6d7-2161-4caf-8793-700f62400398
;;; footnote.el ends here
diff --git a/lisp/mail/hashcash.el b/lisp/mail/hashcash.el
index e6902d88ccf..8343cd086b1 100644
--- a/lisp/mail/hashcash.el
+++ b/lisp/mail/hashcash.el
@@ -1,6 +1,6 @@
;;; hashcash.el --- Add hashcash payments to email
-;; Copyright (C) 2003, 2004, 2005, 2007, 2008, 2009, 2010, 2011 Free Software Foundation
+;; Copyright (C) 2003-2005, 2007-2011 Free Software Foundation, Inc.
;; Written by: Paul Foley <mycroft@actrix.gen.nz> (1997-2002)
;; Maintainer: Paul Foley <mycroft@actrix.gen.nz>
@@ -47,6 +47,7 @@
;;; Code:
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
@@ -115,8 +116,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 +130,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 +276,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 +286,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 +375,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 18bbb60e3a0..c3a7da41823 100644
--- a/lisp/mail/mail-extr.el
+++ b/lisp/mail/mail-extr.el
@@ -1,11 +1,11 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1991-1994, 1997, 2001-2011 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 +690,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 +761,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 +796,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 +994,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 +1228,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 +1472,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 +1617,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 +1627,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 +2173,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 fc7e041d179..d824c282805 100644
--- a/lisp/mail/mail-hist.el
+++ b/lisp/mail/mail-hist.el
@@ -1,11 +1,11 @@
;;; mail-hist.el --- headers and message body history for outgoing mail
-;; Copyright (C) 1994, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 2001-2011 Free Software Foundation, Inc.
;; Author: Karl Fogel <kfogel@red-bean.com>
;; Created: March, 1994
;; Keywords: mail, history
+;; Package: mail-utils
;; This file is part of GNU Emacs.
@@ -292,5 +292,4 @@ received mail."
(provide 'mail-hist)
-;; arch-tag: 9ff9a07c-9dca-482d-ba87-54f42778559d
;;; mail-hist.el ends here
diff --git a/lisp/mail/mail-utils.el b/lisp/mail/mail-utils.el
index bbc94256fb7..328a5d50d34 100644
--- a/lisp/mail/mail-utils.el
+++ b/lisp/mail/mail-utils.el
@@ -1,7 +1,6 @@
;;; mail-utils.el --- utility functions used both by rmail and rnews
-;; Copyright (C) 1985, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: mail, news
@@ -28,10 +27,6 @@
;;; Code:
-;;; We require lisp-mode to make sure that lisp-mode-syntax-table has
-;;; been initialized.
-(require 'lisp-mode)
-
;;;###autoload
(defcustom mail-use-rfc822 nil
"If non-nil, use a full, hairy RFC822 parser on mail addresses.
@@ -40,6 +35,17 @@ often correct parser."
:type 'boolean
:group 'mail)
+;;;###autoload
+(defcustom mail-dont-reply-to-names nil
+ "Regexp specifying addresses to prune from a reply message.
+If this is nil, it is set the first time you compose a reply, to
+a value which excludes your own email address.
+
+Matching addresses are excluded from the CC field in replies, and
+also the To field, unless this would leave an empty To field."
+ :type '(choice regexp (const :tag "Your Name" nil))
+ :group 'mail)
+
;; Returns t if file FILE is an Rmail file.
;;;###autoload
(defun mail-file-babyl-p (file)
@@ -186,87 +192,63 @@ Return a modified address list."
(mapconcat 'identity (rfc822-addresses address) ", "))
(let (pos)
- ;; Detect nested comments.
- (if (string-match "[ \t]*(\\([^)\\]\\|\\\\.\\|\\\\\n\\)*(" address)
- ;; Strip nested comments.
- (with-temp-buffer
- (insert address)
- (set-syntax-table lisp-mode-syntax-table)
- (goto-char 1)
- (while (search-forward "(" nil t)
- (forward-char -1)
- (skip-chars-backward " \t")
- (delete-region (point)
- (save-excursion
- (condition-case ()
- (forward-sexp 1)
- (error (goto-char (point-max))))
- (point))))
- (setq address (buffer-string)))
- ;; Strip non-nested comments an easier way.
- (while (setq pos (string-match
- ;; This doesn't hack rfc822 nested comments
- ;; `(xyzzy (foo) whinge)' properly. Big deal.
- "[ \t]*(\\([^)\\]\\|\\\\.\\|\\\\\n\\)*)"
- address))
- (setq address (replace-match "" nil nil address 0))))
-
- ;; strip surrounding whitespace
- (string-match "\\`[ \t\n]*" address)
- (setq address (substring address
- (match-end 0)
- (string-match "[ \t\n]*\\'" address
- (match-end 0))))
-
- ;; strip `quoted' names (This is supposed to hack `"Foo Bar" <bar@host>')
- (setq pos 0)
- (while (setq pos (string-match
+ ;; Strip comments.
+ (while (setq pos (string-match
+ "[ \t]*(\\([^()\\]\\|\\\\.\\|\\\\\n\\)*)"
+ address))
+ (setq address (replace-match "" nil nil address 0)))
+
+ ;; strip surrounding whitespace
+ (string-match "\\`[ \t\n]*" address)
+ (setq address (substring address
+ (match-end 0)
+ (string-match "[ \t\n]*\\'" address
+ (match-end 0))))
+
+ ;; strip `quoted' names (This is supposed to hack `"Foo Bar" <bar@host>')
+ (setq pos 0)
+ (while (setq pos (string-match
"\\([ \t]?\\)\\([ \t]*\"\\([^\"\\]\\|\\\\.\\|\\\\\n\\)*\"[ \t\n]*\\)"
address pos))
- ;; If the next thing is "@", we have "foo bar"@host. Leave it.
- (if (and (> (length address) (match-end 0))
- (= (aref address (match-end 0)) ?@))
- (setq pos (match-end 0))
- ;; Otherwise discard the "..." part.
- (setq address (replace-match "" nil nil address 2))))
- ;; If this address contains <...>, replace it with just
- ;; the part between the <...>.
- (while (setq pos (string-match "\\(,\\s-*\\|\\`\\)\\([^,]*<\\([^>,:]*\\)>[^,]*\\)\\(\\s-*,\\|\\'\\)"
- address))
- (setq address (replace-match (match-string 3 address)
- nil 'literal address 2)))
- address))))
-
-;; The following piece of ugliness is legacy code. The name was an
-;; unfortunate choice --- a flagrant violation of the Emacs Lisp
-;; coding conventions. `mail-dont-reply-to' would have been
-;; infinitely better. Also, `rmail-dont-reply-to-names' might have
-;; been better named `mail-dont-reply-to-names' and sourced from this
-;; file instead of in rmail.el. Yuck. -pmr
-(defun rmail-dont-reply-to (destinations)
+ ;; If the next thing is "@", we have "foo bar"@host. Leave it.
+ (if (and (> (length address) (match-end 0))
+ (= (aref address (match-end 0)) ?@))
+ (setq pos (match-end 0))
+ ;; Otherwise discard the "..." part.
+ (setq address (replace-match "" nil nil address 2))))
+ ;; If this address contains <...>, replace it with just
+ ;; the part between the <...>.
+ (while (setq pos (string-match "\\(,\\s-*\\|\\`\\)\\([^,]*<\\([^>,:]*\\)>[^,]*\\)\\(\\s-*,\\|\\'\\)"
+ address))
+ (setq address (replace-match (match-string 3 address)
+ nil 'literal address 2)))
+ address))))
+
+(defun mail-dont-reply-to (destinations)
"Prune addresses from DESTINATIONS, a list of recipient addresses.
-All addresses matching `rmail-dont-reply-to-names' are removed from
-the comma-separated list. The pruned list is returned."
+Remove all addresses matching `mail-dont-reply-to-names' from the
+comma-separated list, and return the pruned list."
;; FIXME this (setting a user option the first time a command is used)
;; is somewhat strange. Normally one would never set the option,
;; but instead fall back to the default so long as it was nil.
;; Or just set the default directly in the defcustom.
- (if (null rmail-dont-reply-to-names)
- (setq rmail-dont-reply-to-names
- (concat (if rmail-default-dont-reply-to-names
- (concat rmail-default-dont-reply-to-names "\\|")
- "")
- (if (and user-mail-address
- (not (equal user-mail-address user-login-name)))
- ;; Anchor the login name and email address so
- ;; that we don't match substrings: if the
- ;; login name is "foo", we shouldn't match
- ;; "barfoo@baz.com".
- (concat "\\`"
- (regexp-quote user-mail-address)
- "\\'\\|")
- "")
- (concat "\\`" (regexp-quote user-login-name) "@"))))
+ (if (null mail-dont-reply-to-names)
+ (setq mail-dont-reply-to-names
+ (concat
+ ;; `rmail-default-dont-reply-to-names' is obsolete.
+ (if rmail-default-dont-reply-to-names
+ (concat rmail-default-dont-reply-to-names "\\|")
+ "")
+ (if (and user-mail-address
+ (not (equal user-mail-address user-login-name)))
+ ;; Anchor the login name and email address so that we
+ ;; don't match substrings: if the login name is
+ ;; "foo", we shouldn't match "barfoo@baz.com".
+ (concat "\\`"
+ (regexp-quote user-mail-address)
+ "\\'\\|")
+ "")
+ (concat "\\`" (regexp-quote user-login-name) "@"))))
;; Split up DESTINATIONS and match each element separately.
(let ((start-pos 0) (cur-pos 0)
(case-fold-search t))
@@ -286,7 +268,7 @@ the comma-separated list. The pruned list is returned."
(setq cur-pos start-pos)))
(let* ((address (substring destinations start-pos cur-pos))
(naked-address (mail-strip-quoted-names address)))
- (if (string-match rmail-dont-reply-to-names naked-address)
+ (if (string-match mail-dont-reply-to-names naked-address)
(setq destinations (concat (substring destinations 0 start-pos)
(and cur-pos (substring destinations
(1+ cur-pos))))
@@ -302,6 +284,9 @@ the comma-separated list. The pruned list is returned."
(substring destinations (match-end 0))
destinations))
+;; Legacy name
+(define-obsolete-function-alias 'rmail-dont-reply-to 'mail-dont-reply-to "24.1")
+
;;;###autoload
(defun mail-fetch-field (field-name &optional last all list)
diff --git a/lisp/mail/mailabbrev.el b/lisp/mail/mailabbrev.el
index 0ec8f6dee2c..b4827cf10ba 100644
--- a/lisp/mail/mailabbrev.el
+++ b/lisp/mail/mailabbrev.el
@@ -1,7 +1,6 @@
;;; mailabbrev.el --- abbrev-expansion of mail aliases
-;; Copyright (C) 1985, 1986, 1987, 1992, 1993, 1996, 1997, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+;; Copyright (C) 1985-1987, 1992-1993, 1996-1997, 2000-2011
;; Free Software Foundation, Inc.
;; Author: Jamie Zawinski <jwz@lucid.com; now jwz@jwz.org>
@@ -609,5 +608,4 @@ In other respects, this behaves like `end-of-buffer', which see."
(provide 'mailabbrev)
-;; arch-tag: 5aa2d901-73f8-4ad7-b73c-4802282ad2ff
;;; mailabbrev.el ends here
diff --git a/lisp/mail/mailalias.el b/lisp/mail/mailalias.el
index 56d5c5cd4ba..fc8a07acd47 100644
--- a/lisp/mail/mailalias.el
+++ b/lisp/mail/mailalias.el
@@ -1,7 +1,7 @@
-;;; mailalias.el --- expand and complete mailing address aliases
+;;; mailalias.el --- expand and complete mailing address aliases -*- lexical-binding: t -*-
-;; Copyright (C) 1985, 1987, 1995, 1996, 1997, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1987, 1995-1997, 2001-2011
+;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: mail
@@ -52,20 +52,20 @@ When t this still needs to be initialized.")
(defvar mail-address-field-regexp
"^\\(Resent-\\)?\\(To\\|From\\|CC\\|BCC\\|Reply-to\\):")
+(defvar pattern)
+
(defcustom mail-complete-alist
- ;; Don't use backquote here; we don't want backquote to get loaded
- ;; just because of loading this file.
;; Don't refer to mail-address-field-regexp here;
;; that confuses some things such as cus-dep.el.
- (cons '("^\\(Resent-\\)?\\(To\\|From\\|CC\\|BCC\\|Reply-to\\):"
- . (mail-get-names pattern))
- '(("Newsgroups:" . (if (boundp 'gnus-active-hashtb)
- gnus-active-hashtb
- (if (boundp news-group-article-assoc)
- news-group-article-assoc)))
- ("Followup-To:" . (mail-sentto-newsgroups))
- ;;("Distribution:" ???)
- ))
+ '(("^\\(Resent-\\)?\\(To\\|From\\|CC\\|BCC\\|Reply-to\\):"
+ . (mail-get-names pattern))
+ ("Newsgroups:" . (if (boundp 'gnus-active-hashtb)
+ gnus-active-hashtb
+ (if (boundp news-group-article-assoc)
+ news-group-article-assoc)))
+ ("Followup-To:" . (mail-sentto-newsgroups))
+ ;;("Distribution:" ???)
+ )
"Alist of header field and expression to return alist for completion.
The expression may reference the variable `pattern'
which will hold the string being completed.
@@ -90,6 +90,8 @@ If `angles', they look like:
"Function to call when completing outside `mail-complete-alist'-header."
:type '(choice function (const nil))
:group 'mailalias)
+(make-obsolete-variable 'mail-complete-function
+ 'completion-at-point-functions "24.1")
(defcustom mail-directory-function nil
"Function to get completions from directory service or nil for none.
@@ -240,6 +242,11 @@ removed from alias expansions."
(defun build-mail-aliases (&optional file)
"Read mail aliases from personal aliases file and set `mail-aliases'.
By default, this is the file specified by `mail-personal-alias-file'."
+ (interactive
+ (list
+ (read-file-name (format "Read mail alias file (default %s): "
+ mail-personal-alias-file)
+ nil mail-personal-alias-file t)))
(setq file (expand-file-name (or file mail-personal-alias-file)))
;; In case mail-aliases is t, make sure define-mail-alias
;; does not recursively call build-mail-aliases.
@@ -385,11 +392,9 @@ if it is quoted with double-quotes."
mail-names t))))
;;;###autoload
-(defun mail-complete (arg)
- "Perform completion on header field or word preceding point.
-Completable headers are according to `mail-complete-alist'. If none matches
-current header, calls `mail-complete-function' and passes prefix arg if any."
- (interactive "P")
+(defun mail-completion-at-point-function ()
+ "Compute completion data for mail aliases.
+For use on `completion-at-point-functions'."
;; Read the defaults first, if we have not done so.
(sendmail-sync-aliases)
(if (eq mail-aliases t)
@@ -397,52 +402,70 @@ current header, calls `mail-complete-function' and passes prefix arg if any."
(setq mail-aliases nil)
(if (file-exists-p mail-personal-alias-file)
(build-mail-aliases))))
- (let ((list mail-complete-alist))
+ (let ((list mail-complete-alist)
+ (list-exp nil))
(if (and (< 0 (mail-header-end))
(save-excursion
- (if (re-search-backward "^[^\t]" nil t)
+ (if (re-search-backward "^[^\t ]" nil t)
(while list
(if (looking-at (car (car list)))
- (setq arg (cdr (car list))
+ (setq list-exp (cdr (car list))
list ())
(setq list (cdr list)))))
- arg))
+ list-exp))
(let* ((end (point))
(beg (save-excursion
(skip-chars-backward "^ \t<,:")
(point)))
- (pattern (buffer-substring beg end))
- completion)
- (setq list (eval arg)
- completion (try-completion pattern list))
- (cond ((eq completion t))
- ((null completion)
- (message "Can't find completion for \"%s\"" pattern)
- (ding))
- ((not (string= pattern completion))
- (delete-region beg end)
- (let ((alist-elt (assoc completion mail-names)))
- (if (cdr alist-elt)
- (cond ((eq mail-complete-style 'parens)
- (insert completion " (" (cdr alist-elt) ")"))
- ((eq mail-complete-style 'angles)
- (insert (cdr alist-elt) " <" completion ">"))
- (t
- (insert completion)))
- (insert completion))))
- (t
- (message "Making completion list...")
- (with-output-to-temp-buffer "*Completions*"
- (display-completion-list
- (all-completions pattern list)))
- (message "Making completion list...%s" "done"))))
- (funcall mail-complete-function arg))))
+ (table (completion-table-dynamic
+ (lambda (prefix)
+ (let ((pattern prefix)) (eval list-exp))))))
+ (list beg end table)))))
-(defun mail-get-names (pattern)
+;;;###autoload
+(defun mail-complete (arg)
+ "Perform completion on header field or word preceding point.
+Completable headers are according to `mail-complete-alist'. If none matches
+current header, calls `mail-complete-function' and passes prefix ARG if any."
+ (interactive "P")
+ ;; Read the defaults first, if we have not done so.
+ (sendmail-sync-aliases)
+ (if (eq mail-aliases t)
+ (progn
+ (setq mail-aliases nil)
+ (if (file-exists-p mail-personal-alias-file)
+ (build-mail-aliases))))
+ (let ((data (mail-completion-at-point-function)))
+ (if data
+ (apply #'completion-in-region data)
+ (funcall mail-complete-function arg))))
+(make-obsolete 'mail-complete 'mail-completion-at-point-function "24.1")
+
+(defun mail-completion-expand (table)
+ "Build new completion table that expands aliases.
+Completes like TABLE except that if the completion is a valid alias,
+it expands it to its full `mail-complete-style' form."
+ (lambda (string pred action)
+ (cond
+ ((eq action nil)
+ (let* ((comp (try-completion string table pred))
+ (name (and (listp table) comp
+ (assoc (if (stringp comp) comp string) table))))
+ (cond
+ ((null name) comp)
+ ((eq mail-complete-style 'parens)
+ (concat (car name) " (" (cdr name) ")"))
+ ((eq mail-complete-style 'angles)
+ (concat (cdr name) " <" (car name) ">"))
+ (t comp))))
+ (t
+ (complete-with-action action table string pred)))))
+
+(defun mail-get-names (prefix)
"Fetch local users and global mail addresses for completion.
Consults `/etc/passwd' and a directory service if one is set up via
`mail-directory-function'.
-PATTERN is the string we want to complete."
+PREFIX is the string we want to complete."
(if (eq mail-local-names t)
(with-current-buffer (generate-new-buffer " passwd")
(let ((files mail-passwd-files))
@@ -475,7 +498,7 @@ PATTERN is the string we want to complete."
(and mail-directory-function
(eq mail-directory-names t)
(setq directory
- (mail-directory (if mail-directory-requery pattern))))
+ (mail-directory (if mail-directory-requery prefix))))
(or mail-directory-requery
(setq mail-directory-names directory))
(if (or directory
@@ -491,58 +514,59 @@ PATTERN is the string we want to complete."
(when (consp mail-directory-names)
mail-directory-names)))
(lambda (a b)
- ;; should cache downcased strings
+ ;; Should cache downcased strings.
(string< (downcase (car a))
(downcase (car b)))))))))
- mail-names)
+ (mail-completion-expand mail-names))
-(defun mail-directory (pattern)
- "Use mail-directory facility to get user names matching PATTERN.
-If PATTERN is nil, get all the defined user names.
+(defun mail-directory (prefix)
+ "Use mail-directory facility to get user names matching PREFIX.
+If PREFIX is nil, get all the defined user names.
This function calls `mail-directory-function' to query the directory,
then uses `mail-directory-parser' to parse the output it returns."
(message "Querying directory...")
(with-current-buffer (generate-new-buffer " *mail-directory*")
- (funcall mail-directory-function pattern)
+ (funcall mail-directory-function prefix)
(goto-char (point-min))
(let (directory)
(if (stringp mail-directory-parser)
(while (re-search-forward mail-directory-parser nil t)
- (setq directory
- (cons (match-string 1) directory)))
+ (push (match-string 1) directory))
(if mail-directory-parser
(setq directory (funcall mail-directory-parser))
(while (not (eobp))
- (setq directory
- (cons (buffer-substring (point)
- (progn
- (forward-line)
- (if (bolp)
- (1- (point))
- (point))))
- directory)))))
+ (push (buffer-substring (point)
+ (progn
+ (forward-line)
+ (if (bolp)
+ (1- (point))
+ (point))))
+ directory))))
(kill-buffer (current-buffer))
(message "Querying directory...done")
directory)))
+(defvar mailalias-done)
-(defun mail-directory-process (pattern)
+(defun mail-directory-process (prefix)
"Run a shell command to output names in directory.
See `mail-directory-process'."
(when (consp mail-directory-process)
- (apply 'call-process (eval (car mail-directory-process)) nil t nil
- (mapcar 'eval (cdr mail-directory-process)))))
+ (let ((pattern prefix)) ;Dynbind!
+ (apply 'call-process (eval (car mail-directory-process)) nil t nil
+ (mapcar 'eval (cdr mail-directory-process))))))
;; This should handle a dialog. Currently expects port to spit out names.
-(defun mail-directory-stream (pattern)
+(defun mail-directory-stream (prefix)
"Open a stream to retrieve names in directory.
See `mail-directory-stream'."
- (let (mailalias-done)
+ (let ((mailalias-done nil)
+ (pattern prefix)) ;Dynbind!
(set-process-sentinel
(apply 'open-network-stream "mailalias" (current-buffer)
mail-directory-stream)
- (lambda (x y)
+ (lambda (_x _y)
(setq mailalias-done t)))
(while (not mailalias-done)
(sit-for .1))))
@@ -562,5 +586,4 @@ See `mail-directory-stream'."
(provide 'mailalias)
-;; arch-tag: 1d6a0f87-eb34-4d45-8816-60c1b952cf46
;;; mailalias.el ends here
diff --git a/lisp/mail/mailclient.el b/lisp/mail/mailclient.el
index 1b3eef50015..b957d9f36c6 100644
--- a/lisp/mail/mailclient.el
+++ b/lisp/mail/mailclient.el
@@ -1,6 +1,6 @@
-;;; mailclient.el --- mail sending via system's mail client. -*- byte-compile-dynamic: t -*-
+;;; mailclient.el --- mail sending via system's mail client.
-;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation
+;; Copyright (C) 2005-2011 Free Software Foundation
;; Author: David Reitter <david.reitter@gmail.com>
;; Keywords: mail
@@ -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
@@ -170,5 +174,4 @@ The mail client is taken to be the handler of mailto URLs."
(provide 'mailclient)
-;; arch-tag: 35d10fc8-a1bc-4f29-a4e6-c288e53578ef
;;; mailclient.el ends here
diff --git a/lisp/mail/mailheader.el b/lisp/mail/mailheader.el
index e7b7a34fe6e..1277d1d4109 100644
--- a/lisp/mail/mailheader.el
+++ b/lisp/mail/mailheader.el
@@ -1,10 +1,10 @@
;;; mailheader.el --- mail header parsing, merging, formatting
-;; Copyright (C) 1996, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 2001-2011 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 +48,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 +101,9 @@ value."
(cons (cdr header) (funcall (cdr rule) (cdr header))))))))
headers)
+;; Advertised 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 +190,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/mailpost.el b/lisp/mail/mailpost.el
index 0790375388d..7c4bea830d8 100644
--- a/lisp/mail/mailpost.el
+++ b/lisp/mail/mailpost.el
@@ -102,5 +102,4 @@ site-init."
(provide 'mailpost)
-;; arch-tag: 1f8ca085-60a6-4eac-8efb-69ffec2fa124
;;; mailpost.el ends here
diff --git a/lisp/mail/metamail.el b/lisp/mail/metamail.el
index dbc3743e478..9269a24c4cb 100644
--- a/lisp/mail/metamail.el
+++ b/lisp/mail/metamail.el
@@ -1,7 +1,6 @@
;;; metamail.el --- Metamail interface for GNU Emacs
-;; Copyright (C) 1993, 1996, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1996, 2001-2011 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp>
;; Keywords: mail, news, mime, multimedia
@@ -40,7 +39,6 @@
(defgroup metamail nil
"Metamail interface for Emacs."
:group 'mail
- :group 'hypermedia
:group 'processes)
(defcustom metamail-program-name "metamail"
@@ -201,5 +199,4 @@ redisplayed as output is inserted."
(provide 'metamail)
-;; arch-tag: 52c0cb6f-d800-4776-9789-f0275cb5490e
;;; metamail.el ends here
diff --git a/lisp/mail/mspools.el b/lisp/mail/mspools.el
index dc81a7f3cc3..862cb2a1eee 100644
--- a/lisp/mail/mspools.el
+++ b/lisp/mail/mspools.el
@@ -1,7 +1,6 @@
;;; mspools.el --- show mail spools waiting to be read
-;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Stephen Eglen <stephen@gnu.org>
;; Maintainer: Stephen Eglen <stephen@gnu.org>
@@ -172,7 +171,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 +279,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 +319,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 +403,4 @@ nil."
(provide 'mspools)
-;; arch-tag: 8990b3ee-68c8-4892-98f1-51a735c8bac6
;;; mspools.el ends here
diff --git a/lisp/mail/reporter.el b/lisp/mail/reporter.el
index ba5c8e337c5..45700d4d60d 100644
--- a/lisp/mail/reporter.el
+++ b/lisp/mail/reporter.el
@@ -1,7 +1,6 @@
;;; reporter.el --- customizable bug reporting of lisp programs
-;; Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1998, 2001-2011 Free Software Foundation, Inc.
;; Author: 1993-1998 Barry A. Warsaw
;; Maintainer: FSF
@@ -407,5 +406,4 @@ mail-sending package is used for editing and sending the message."
(provide 'reporter)
-;; arch-tag: 33612ff4-fbbc-4be2-b183-560ce9e0199b
;;; reporter.el ends here
diff --git a/lisp/mail/rfc2368.el b/lisp/mail/rfc2368.el
index 151e6f68037..d3f824fe50f 100644
--- a/lisp/mail/rfc2368.el
+++ b/lisp/mail/rfc2368.el
@@ -1,7 +1,6 @@
;;; rfc2368.el --- support for rfc2368
-;; Copyright (C) 1998, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 2000-2011 Free Software Foundation, Inc.
;; Author: Sen Nagata <sen@eccosys.com>
;; Keywords: mail
@@ -92,13 +91,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 +128,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/rfc822.el b/lisp/mail/rfc822.el
index ddaf7625981..9e4e60e6806 100644
--- a/lisp/mail/rfc822.el
+++ b/lisp/mail/rfc822.el
@@ -1,7 +1,6 @@
;;; rfc822.el --- hairy rfc822 parser for mail and news and suchlike
-;; Copyright (C) 1986, 1987, 1990, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1986-1987, 1990, 2001-2011 Free Software Foundation, Inc.
;; Author: Richard Mlynarik <mly@eddie.mit.edu>
;; Maintainer: FSF
@@ -324,5 +323,4 @@
(provide 'rfc822)
-;; arch-tag: 5d388a24-e173-40fb-9b8e-85269de44b37
;;; rfc822.el ends here
diff --git a/lisp/mail/rmail-spam-filter.el b/lisp/mail/rmail-spam-filter.el
index a81cc3cbf14..70226b26965 100644
--- a/lisp/mail/rmail-spam-filter.el
+++ b/lisp/mail/rmail-spam-filter.el
@@ -1,9 +1,9 @@
;;; rmail-spam-filter.el --- spam filter for Rmail, the Emacs mail reader
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 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.
@@ -554,5 +554,4 @@ checks to see if the old format is used, and updates it if necessary."
(provide 'rmail-spam-filter)
-;; arch-tag: 03e1d45d-b72f-4dd7-8f04-e7fd78249746
;;; rmail-spam-fitler ends here
diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el
index e2bda8fb764..200aadda651 100644
--- a/lisp/mail/rmail.el
+++ b/lisp/mail/rmail.el
@@ -1,7 +1,6 @@
;;; rmail.el --- main code of "RMAIL" mail reader for Emacs
-;; Copyright (C) 1985, 1986, 1987, 1988, 1993, 1994, 1995, 1996, 1997, 1998,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+;; Copyright (C) 1985-1988, 1993-1998, 2000-2011
;; Free Software Foundation, Inc.
;; Maintainer: FSF
@@ -192,7 +191,7 @@ please report it with \\[report-emacs-bug].")
:group 'rmail-retrieve
:type '(repeat (directory)))
-(declare-function rmail-dont-reply-to "mail-utils" (destinations))
+(declare-function mail-dont-reply-to "mail-utils" (destinations))
(declare-function rmail-update-summary "rmailsum" (&rest ignore))
(defun rmail-probe (prog)
@@ -284,26 +283,16 @@ Setting this variable has an effect only before reading a mail."
:version "21.1")
;;;###autoload
-(defcustom rmail-dont-reply-to-names nil
- "A regexp specifying addresses to prune from a reply message.
-If this is nil, it is set the first time you compose a reply, to
-a value which excludes your own email address, plus whatever is
-specified by `rmail-default-dont-reply-to-names'.
-
-Matching addresses are excluded from the CC field in replies, and
-also the To field, unless this would leave an empty To field."
- :type '(choice regexp (const :tag "Your Name" nil))
- :group 'rmail-reply)
+(defvaralias 'rmail-dont-reply-to-names 'mail-dont-reply-to-names)
;;;###autoload
-(defvar rmail-default-dont-reply-to-names (purecopy "\\`info-")
- "Regexp specifying part of the default value of `rmail-dont-reply-to-names'.
-This is used when the user does not set `rmail-dont-reply-to-names'
-explicitly. (The other part of the default value is the user's
-email address and name.) It is useful to set this variable in
-the site customization file. The default value is conventionally
-used for large mailing lists to broadcast announcements.")
-;; Is it really useful to set this site-wide?
+(defvar rmail-default-dont-reply-to-names nil
+ "Regexp specifying part of the default value of `mail-dont-reply-to-names'.
+This is used when the user does not set `mail-dont-reply-to-names'
+explicitly.")
+;;;###autoload
+(make-obsolete-variable 'rmail-default-dont-reply-to-names
+ 'mail-dont-reply-to-names "24.1")
;;;###autoload
(defcustom rmail-ignored-headers
@@ -2317,11 +2306,11 @@ change; nil means current message."
;;;; *** Rmail Message Selection And Support ***
(defun rmail-msgend (n)
- "Return the start position for message number N."
+ "Return the end position for message number N."
(marker-position (aref rmail-message-vector (1+ n))))
(defun rmail-msgbeg (n)
- "Return the end position for message number N."
+ "Return the start position for message number N."
(marker-position (aref rmail-message-vector n)))
(defun rmail-apply-in-message (msgnum function &rest args)
@@ -3441,40 +3430,72 @@ does not pop any summary buffer."
;;;; *** Rmail Mailing Commands ***
(defun rmail-start-mail (&optional noerase to subject in-reply-to cc
- replybuffer sendactions same-window others)
- (let (yank-action)
+ replybuffer sendactions same-window
+ other-headers)
+ (let ((switch-function
+ (cond (same-window nil)
+ (rmail-mail-new-frame 'switch-to-buffer-other-frame)
+ (t 'switch-to-buffer-other-window)))
+ yank-action)
(if replybuffer
;; The function used here must behave like insert-buffer wrt
;; point and mark (see doc of sc-cite-original).
(setq yank-action (list 'insert-buffer replybuffer)))
- (setq others (cons (cons "cc" cc) others))
- (setq others (cons (cons "in-reply-to" in-reply-to) others))
- (setq others
+ (push (cons "cc" cc) other-headers)
+ (push (cons "in-reply-to" in-reply-to) other-headers)
+ (setq other-headers
(mapcar #'(lambda (elt)
(cons (car elt) (if (stringp (cdr elt))
(rfc2047-decode-string (cdr elt)))))
- others))
+ other-headers))
(if (stringp to) (setq to (rfc2047-decode-string to)))
(if (stringp in-reply-to)
(setq in-reply-to (rfc2047-decode-string in-reply-to)))
(if (stringp cc) (setq cc (rfc2047-decode-string cc)))
(if (stringp subject) (setq subject (rfc2047-decode-string subject)))
- (if same-window
- (compose-mail to subject others
- noerase nil
- yank-action sendactions)
- (if rmail-mail-new-frame
- (prog1
- (compose-mail to subject others
- noerase 'switch-to-buffer-other-frame
- yank-action sendactions)
- ;; This is not a standard frame parameter;
- ;; nothing except sendmail.el looks at it.
+ (prog1
+ (compose-mail to subject other-headers noerase
+ switch-function yank-action sendactions
+ '(rmail-mail-return))
+ (if (eq switch-function 'switch-to-buffer-other-frame)
+ ;; This is not a standard frame parameter; nothing except
+ ;; sendmail.el looks at it.
(modify-frame-parameters (selected-frame)
- '((mail-dedicated-frame . t))))
- (compose-mail to subject others
- noerase 'switch-to-buffer-other-window
- yank-action sendactions)))))
+ '((mail-dedicated-frame . t)))))))
+
+(defun rmail-mail-return ()
+ (cond
+ ;; If there is only one visible frame with no special handling,
+ ;; consider deleting the mail window to return to Rmail.
+ ((or (null (delq (selected-frame) (visible-frame-list)))
+ (not (or (window-dedicated-p (frame-selected-window))
+ (and pop-up-frames (one-window-p))
+ (cdr (assq 'mail-dedicated-frame
+ (frame-parameters))))))
+ (let (rmail-flag summary-buffer)
+ (and (not (one-window-p))
+ (with-current-buffer
+ (window-buffer (next-window (selected-window) 'not))
+ (setq rmail-flag (eq major-mode 'rmail-mode))
+ (setq summary-buffer
+ (and (boundp 'mail-bury-selects-summary)
+ mail-bury-selects-summary
+ (boundp 'rmail-summary-buffer)
+ rmail-summary-buffer
+ (buffer-name rmail-summary-buffer)
+ (not (get-buffer-window rmail-summary-buffer))
+ rmail-summary-buffer))))
+ (if rmail-flag
+ ;; If the Rmail buffer has a summary, show that.
+ (if summary-buffer (switch-to-buffer summary-buffer)
+ (delete-window)))))
+ ;; If the frame was probably made for this buffer, the user
+ ;; probably wants to delete it now.
+ ((display-multi-frame-p)
+ (delete-frame (selected-frame)))
+ ;; The previous frame is where normally they have the Rmail buffer
+ ;; displayed.
+ (t (other-frame -1))))
(defun rmail-mail ()
"Send mail in another window.
@@ -3557,15 +3578,14 @@ use \\[mail-yank-original] to yank the original message into it."
;; Remove unwanted names from reply-to, since Mail-Followup-To
;; header causes all the names in it to wind up in reply-to, not
;; in cc. But if what's left is an empty list, use the original.
- (let* ((reply-to-list (rmail-dont-reply-to reply-to)))
+ (let* ((reply-to-list (mail-dont-reply-to reply-to)))
(if (string= reply-to-list "") reply-to reply-to-list))
subject
(rmail-make-in-reply-to-field from date message-id)
(if just-sender
nil
- ;; mail-strip-quoted-names is NOT necessary for rmail-dont-reply-to
- ;; to do its job.
- (let* ((cc-list (rmail-dont-reply-to
+ ;; `mail-dont-reply-to' doesn't need `mail-strip-quoted-names'.
+ (let* ((cc-list (mail-dont-reply-to
(mail-strip-quoted-names
(if (null cc) to (concat to ", " cc))))))
(if (string= cc-list "") nil cc-list)))
@@ -3841,9 +3861,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.
@@ -3929,18 +3947,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"))
@@ -4242,7 +4261,7 @@ encoded string (and the same mask) will decode the string."
;;; Start of automatically extracted autoloads.
;;;### (autoloads (rmail-edit-current-message) "rmailedit" "rmailedit.el"
-;;;;;; "ecd28d8d92983488673388eced6fbf50")
+;;;;;; "090ad9432c3bf9a6098bb9c3d7c71baf")
;;; Generated autoloads from rmailedit.el
(autoload 'rmail-edit-current-message "rmailedit" "\
@@ -4254,7 +4273,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" "bc72ffe3652be6f4c72048ae8f226fce")
+;;;;;; "rmailkwd.el" "08c288c88cfe7be50830122c064e3884")
;;; Generated autoloads from rmailkwd.el
(autoload 'rmail-add-label "rmailkwd" "\
@@ -4297,7 +4316,7 @@ With prefix argument N moves forward N messages with these labels.
;;;***
-;;;### (autoloads (rmail-mime) "rmailmm" "rmailmm.el" "736579c1ea88e1f0e1ec21b8a50bc2a2")
+;;;### (autoloads (rmail-mime) "rmailmm" "rmailmm.el" "c530622b53038152ca84f2ec9313bd7a")
;;; Generated autoloads from rmailmm.el
(autoload 'rmail-mime "rmailmm" "\
@@ -4323,7 +4342,7 @@ attachments as specfied by `rmail-mime-attachment-dirs-alist'.
;;;***
;;;### (autoloads (set-rmail-inbox-list) "rmailmsc" "rmailmsc.el"
-;;;;;; "9319e5b606ad5786c0c5994a307a38e8")
+;;;;;; "ca19b2f8a3e8aa01aa75ca7413f8a5ef")
;;; Generated autoloads from rmailmsc.el
(autoload 'set-rmail-inbox-list "rmailmsc" "\
@@ -4339,7 +4358,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" "16144a77fdc880034875fd624e4d73e6")
+;;;;;; rmail-sort-by-date) "rmailsort" "rmailsort.el" "ad1c98fe868c0e5804cf945d6c980d0b")
;;; Generated autoloads from rmailsort.el
(autoload 'rmail-sort-by-date "rmailsort" "\
@@ -4373,7 +4392,7 @@ If prefix argument REVERSE is non-nil, sorts in reverse order.
Sort messages of current Rmail buffer by other correspondent.
This uses either the \"From\", \"Sender\", \"To\", or
\"Apparently-To\" header, downcased. Uses the first header not
-excluded by `rmail-dont-reply-to-names'. If prefix argument
+excluded by `mail-dont-reply-to-names'. If prefix argument
REVERSE is non-nil, sorts in reverse order.
\(fn REVERSE)" t nil)
@@ -4398,7 +4417,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" "6bcfd5937a56902944a929b89b33adaa")
+;;;;;; rmail-summary) "rmailsum" "rmailsum.el" "3817e21639db697abe5832d3223ecfc2")
;;; Generated autoloads from rmailsum.el
(autoload 'rmail-summary "rmailsum" "\
@@ -4446,7 +4465,7 @@ SENDERS is a string of regexps separated by commas.
;;;***
;;;### (autoloads (unforward-rmail-message undigestify-rmail-message)
-;;;;;; "undigest" "undigest.el" "2869c38a0051d0acab1a5968627fa57d")
+;;;;;; "undigest" "undigest.el" "41e6a48ea63224385c447a944528feb6")
;;; Generated autoloads from undigest.el
(autoload 'undigestify-rmail-message "undigest" "\
@@ -4469,5 +4488,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 59c4e9a6804..868ca15923f 100644
--- a/lisp/mail/rmailedit.el
+++ b/lisp/mail/rmailedit.el
@@ -1,10 +1,10 @@
;;; rmailedit.el --- "RMAIL edit mode" Edit the current message
-;; Copyright (C) 1985, 1994, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1994, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: mail
+;; Package: rmail
;; This file is part of GNU Emacs.
@@ -398,5 +398,4 @@ HEADER-DIFF should be a return value from `rmail-edit-diff-headers'."
;; generated-autoload-file: "rmail.el"
;; End:
-;; arch-tag: 9524f335-12cc-4e95-9e9b-3208dc30550b
;;; rmailedit.el ends here
diff --git a/lisp/mail/rmailkwd.el b/lisp/mail/rmailkwd.el
index 2b5e856bdff..73542578bf6 100644
--- a/lisp/mail/rmailkwd.el
+++ b/lisp/mail/rmailkwd.el
@@ -1,10 +1,10 @@
;;; rmailkwd.el --- part of the "RMAIL" mail reader for Emacs
-;; Copyright (C) 1985, 1988, 1994, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1988, 1994, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: mail
+;; Package: rmail
;; This file is part of GNU Emacs.
@@ -193,5 +193,4 @@ With prefix argument N moves forward N messages with these labels."
;; generated-autoload-file: "rmail.el"
;; End:
-;; arch-tag: 1149979c-8e47-4333-9629-cf3dc887a6a7
;;; rmailkwd.el ends here
diff --git a/lisp/mail/rmailmm.el b/lisp/mail/rmailmm.el
index 4aa3e81132f..96132739b20 100644
--- a/lisp/mail/rmailmm.el
+++ b/lisp/mail/rmailmm.el
@@ -1,11 +1,12 @@
;;; rmailmm.el --- MIME decoding and display stuff for RMAIL
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
;; Author: Alexander Pohoyda
;; Alex Schroeder
;; Maintainer: FSF
;; Keywords: mail
+;; Package: rmail
;; This file is part of GNU Emacs.
@@ -52,7 +53,7 @@
;;
;; rmail-mime
;; +- rmail-mime-show <----------------------------------+
-;; +- rmail-mime-process |
+;; +- rmail-mime-process |
;; +- rmail-mime-handle |
;; +- rmail-mime-text-handler |
;; +- rmail-mime-bulk-handler |
@@ -159,7 +160,7 @@ A MIME-entity is a vector of 9 elements:
[TYPE DISPOSITION TRANSFER-ENCODING DISPLAY HEADER TAGLINE BODY
CHILDREN HANDLER]
-
+
TYPE and DISPOSITION correspond to MIME headers Content-Type and
Cotent-Disposition respectively, and has this format:
@@ -326,7 +327,7 @@ The value is a vector [ INDEX HEADER TAGLINE BODY END], where
(aset new 2 (aref (rmail-mime-entity-body entity) 2)))
(dolist (child (rmail-mime-entity-children entity))
(rmail-mime-shown-mode child)))
-
+
(defun rmail-mime-hidden-mode (entity)
"Make MIME-entity ENTITY displayed in the hidden mode."
(let ((new (aref (rmail-mime-entity-display entity) 1)))
@@ -423,7 +424,7 @@ to the tag line."
(insert item)
(apply 'insert-button item))))
(insert "]\n"))
-
+
(defun rmail-mime-update-tagline (entity)
"Update the current tag line for MIME-entity ENTITY."
(let ((inhibit-read-only t)
@@ -1148,7 +1149,7 @@ modified."
;; Hide headers and handle the part.
(put-text-property (point-min) (point-max) 'rmail-mime-entity
- (rmail-mime-entity
+ (rmail-mime-entity
content-type content-disposition
content-transfer-encoding
(vector (vector 'raw nil 'raw) (vector 'raw nil 'raw))
@@ -1364,7 +1365,7 @@ attachments as specfied by `rmail-mime-attachment-dirs-alist'."
(re-search-forward "^$" nil 'move) (point)))
(body-end (point-max))
(entity (rmail-mime-parse)))
- (or
+ (or
;; At first, just search the headers.
(with-temp-buffer
(insert-buffer-substring rmail-mime-mbox-buffer nil header-end)
@@ -1375,7 +1376,7 @@ attachments as specfied by `rmail-mime-attachment-dirs-alist'."
(if (and entity
(let* ((content-type (rmail-mime-entity-type entity))
(charset (cdr (assq 'charset (cdr content-type)))))
- (or (not (string-match "text/.*" (car content-type)))
+ (or (not (string-match "text/.*" (car content-type)))
(and charset
(not (string= (downcase charset) "us-ascii"))))))
;; Search the decoded MIME message.
@@ -1395,5 +1396,4 @@ attachments as specfied by `rmail-mime-attachment-dirs-alist'."
;; generated-autoload-file: "rmail.el"
;; End:
-;; arch-tag: 3f2c5e5d-1aef-4512-bc20-fd737c9d5dd9
;;; rmailmm.el ends here
diff --git a/lisp/mail/rmailmsc.el b/lisp/mail/rmailmsc.el
index de6c9018024..4519ab1505f 100644
--- a/lisp/mail/rmailmsc.el
+++ b/lisp/mail/rmailmsc.el
@@ -1,10 +1,10 @@
;;; rmailmsc.el --- miscellaneous support functions for the RMAIL mail reader
-;; Copyright (C) 1985, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: mail
+;; Package: rmail
;; This file is part of GNU Emacs.
@@ -58,5 +58,4 @@ This applies only to the current session."
;; generated-autoload-file: "rmail.el"
;; End:
-;; arch-tag: 94614a62-2a0a-4e25-bac9-06f461ed4c60
;;; rmailmsc.el ends here
diff --git a/lisp/mail/rmailout.el b/lisp/mail/rmailout.el
index 1688fb73897..3926b426a67 100644
--- a/lisp/mail/rmailout.el
+++ b/lisp/mail/rmailout.el
@@ -1,10 +1,11 @@
;;; rmailout.el --- "RMAIL" mail reader for Emacs: output message to a file
-;; Copyright (C) 1985, 1987, 1993, 1994, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1987, 1993-1994, 2001-2011
+;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: mail
+;; Package: rmail
;; This file is part of GNU Emacs.
@@ -602,5 +603,4 @@ than appending to it. Deletes the message after writing if
(if rmail-delete-after-output
(rmail-delete-forward)))
-;; arch-tag: 4059abf0-f249-4be4-8e0d-602d370d01d1
;;; rmailout.el ends here
diff --git a/lisp/mail/rmailsort.el b/lisp/mail/rmailsort.el
index caa82cfd5d1..d8b85ad688a 100644
--- a/lisp/mail/rmailsort.el
+++ b/lisp/mail/rmailsort.el
@@ -1,11 +1,11 @@
;;; rmailsort.el --- Rmail: sort messages
-;; Copyright (C) 1990, 1993, 1994, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990, 1993-1994, 2001-2011 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp>
;; Maintainer: FSF
;; Keywords: mail
+;; Package: rmail
;; This file is part of GNU Emacs.
@@ -87,7 +87,7 @@ If prefix argument REVERSE is non-nil, sorts in reverse order."
"Sort messages of current Rmail buffer by other correspondent.
This uses either the \"From\", \"Sender\", \"To\", or
\"Apparently-To\" header, downcased. Uses the first header not
-excluded by `rmail-dont-reply-to-names'. If prefix argument
+excluded by `mail-dont-reply-to-names'. If prefix argument
REVERSE is non-nil, sorts in reverse order."
(interactive "P")
(rmail-sort-messages reverse
@@ -98,13 +98,12 @@ REVERSE is non-nil, sorts in reverse order."
'("From" "Sender" "To" "Apparently-To"))))))
(defun rmail-select-correspondent (msg fields)
- "Find the first header not excluded by `rmail-dont-reply-to-names'.
+ "Find the first header not excluded by `mail-dont-reply-to-names'.
MSG is a message number. FIELDS is a list of header names."
(let ((ans ""))
(while (and fields (string= ans ""))
(setq ans
- ;; NB despite the name, this lives in mail-utils.el.
- (rmail-dont-reply-to
+ (mail-dont-reply-to
(mail-strip-quoted-names
(or (rmail-get-header (car fields) msg) ""))))
(setq fields (cdr fields)))
@@ -254,5 +253,4 @@ Numeric keys are sorted numerically, all others as strings."
;; generated-autoload-file: "rmail.el"
;; End:
-;; arch-tag: 665da245-f6a7-4115-ad8c-ba19216988d5
;;; rmailsort.el ends here
diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el
index 61dfc9e1c0b..8e28201e31f 100644
--- a/lisp/mail/rmailsum.el
+++ b/lisp/mail/rmailsum.el
@@ -1,10 +1,10 @@
;;; rmailsum.el --- make summary buffers for the mail reader
-;; Copyright (C) 1985, 1993, 1994, 1995, 1996, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1993-1996, 2000-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: mail
+;; Package: rmail
;; This file is part of GNU Emacs.
@@ -64,7 +64,196 @@ Setting this option to nil might speed up the generation of summaries."
"Overlay used to highlight the current message in the Rmail summary.")
(put 'rmail-summary-overlay 'permanent-local t)
-(defvar rmail-summary-mode-map nil
+(defvar rmail-summary-mode-map
+ (let ((map (make-keymap)))
+ (suppress-keymap map)
+ (define-key map [mouse-2] 'rmail-summary-mouse-goto-message)
+ (define-key map "a" 'rmail-summary-add-label)
+ (define-key map "b" 'rmail-summary-bury)
+ (define-key map "c" 'rmail-summary-continue)
+ (define-key map "d" 'rmail-summary-delete-forward)
+ (define-key map "\C-d" 'rmail-summary-delete-backward)
+ (define-key map "e" 'rmail-summary-edit-current-message)
+ (define-key map "f" 'rmail-summary-forward)
+ (define-key map "g" 'rmail-summary-get-new-mail)
+ (define-key map "h" 'rmail-summary)
+ (define-key map "i" 'rmail-summary-input)
+ (define-key map "j" 'rmail-summary-goto-msg)
+ (define-key map "\C-m" 'rmail-summary-goto-msg)
+ (define-key map "k" 'rmail-summary-kill-label)
+ (define-key map "l" 'rmail-summary-by-labels)
+ (define-key map "\e\C-h" 'rmail-summary)
+ (define-key map "\e\C-l" 'rmail-summary-by-labels)
+ (define-key map "\e\C-r" 'rmail-summary-by-recipients)
+ (define-key map "\e\C-s" 'rmail-summary-by-regexp)
+ ;; `f' for "from".
+ (define-key map "\e\C-f" 'rmail-summary-by-senders)
+ (define-key map "\e\C-t" 'rmail-summary-by-topic)
+ (define-key map "m" 'rmail-summary-mail)
+ (define-key map "\M-m" 'rmail-summary-retry-failure)
+ (define-key map "n" 'rmail-summary-next-msg)
+ (define-key map "\en" 'rmail-summary-next-all)
+ (define-key map "\e\C-n" 'rmail-summary-next-labeled-message)
+ (define-key map "o" 'rmail-summary-output)
+ (define-key map "\C-o" 'rmail-summary-output-as-seen)
+ (define-key map "p" 'rmail-summary-previous-msg)
+ (define-key map "\ep" 'rmail-summary-previous-all)
+ (define-key map "\e\C-p" 'rmail-summary-previous-labeled-message)
+ (define-key map "q" 'rmail-summary-quit)
+ (define-key map "Q" 'rmail-summary-wipe)
+ (define-key map "r" 'rmail-summary-reply)
+ (define-key map "s" 'rmail-summary-expunge-and-save)
+ ;; See rms's comment in rmail.el
+ ;; (define-key map "\er" 'rmail-summary-search-backward)
+ (define-key map "\es" 'rmail-summary-search)
+ (define-key map "t" 'rmail-summary-toggle-header)
+ (define-key map "u" 'rmail-summary-undelete)
+ (define-key map "\M-u" 'rmail-summary-undelete-many)
+ (define-key map "x" 'rmail-summary-expunge)
+ (define-key map "w" 'rmail-summary-output-body)
+ (define-key map "v" 'rmail-mime)
+ (define-key map "." 'rmail-summary-beginning-of-message)
+ (define-key map "/" 'rmail-summary-end-of-message)
+ (define-key map "<" 'rmail-summary-first-message)
+ (define-key map ">" 'rmail-summary-last-message)
+ (define-key map " " 'rmail-summary-scroll-msg-up)
+ (define-key map "\177" 'rmail-summary-scroll-msg-down)
+ (define-key map "?" 'describe-mode)
+ (define-key map "\C-c\C-n" 'rmail-summary-next-same-subject)
+ (define-key map "\C-c\C-p" 'rmail-summary-previous-same-subject)
+ (define-key map "\C-c\C-s\C-d" 'rmail-summary-sort-by-date)
+ (define-key map "\C-c\C-s\C-s" 'rmail-summary-sort-by-subject)
+ (define-key map "\C-c\C-s\C-a" 'rmail-summary-sort-by-author)
+ (define-key map "\C-c\C-s\C-r" 'rmail-summary-sort-by-recipient)
+ (define-key map "\C-c\C-s\C-c" 'rmail-summary-sort-by-correspondent)
+ (define-key map "\C-c\C-s\C-l" 'rmail-summary-sort-by-lines)
+ (define-key map "\C-c\C-s\C-k" 'rmail-summary-sort-by-labels)
+ (define-key map "\C-x\C-s" 'rmail-summary-save-buffer)
+
+ ;; Menu bar bindings.
+
+ (define-key map [menu-bar] (make-sparse-keymap))
+
+ (define-key map [menu-bar classify]
+ (cons "Classify" (make-sparse-keymap "Classify")))
+
+ (define-key map [menu-bar classify output-menu]
+ '("Output (Rmail Menu)..." . rmail-summary-output-menu))
+
+ (define-key map [menu-bar classify input-menu]
+ '("Input Rmail File (menu)..." . rmail-input-menu))
+
+ (define-key map [menu-bar classify input-menu]
+ '(nil))
+
+ (define-key map [menu-bar classify output-menu]
+ '(nil))
+
+ (define-key map [menu-bar classify output-body]
+ '("Output body..." . rmail-summary-output-body))
+
+ (define-key map [menu-bar classify output-inbox]
+ '("Output..." . rmail-summary-output))
+
+ (define-key map [menu-bar classify output]
+ '("Output as seen..." . rmail-summary-output-as-seen))
+
+ (define-key map [menu-bar classify kill-label]
+ '("Kill Label..." . rmail-summary-kill-label))
+
+ (define-key map [menu-bar classify add-label]
+ '("Add Label..." . rmail-summary-add-label))
+
+ (define-key map [menu-bar summary]
+ (cons "Summary" (make-sparse-keymap "Summary")))
+
+ (define-key map [menu-bar summary senders]
+ '("By Senders..." . rmail-summary-by-senders))
+
+ (define-key map [menu-bar summary labels]
+ '("By Labels..." . rmail-summary-by-labels))
+
+ (define-key map [menu-bar summary recipients]
+ '("By Recipients..." . rmail-summary-by-recipients))
+
+ (define-key map [menu-bar summary topic]
+ '("By Topic..." . rmail-summary-by-topic))
+
+ (define-key map [menu-bar summary regexp]
+ '("By Regexp..." . rmail-summary-by-regexp))
+
+ (define-key map [menu-bar summary all]
+ '("All" . rmail-summary))
+
+ (define-key map [menu-bar mail]
+ (cons "Mail" (make-sparse-keymap "Mail")))
+
+ (define-key map [menu-bar mail rmail-summary-get-new-mail]
+ '("Get New Mail" . rmail-summary-get-new-mail))
+
+ (define-key map [menu-bar mail lambda]
+ '("----"))
+
+ (define-key map [menu-bar mail continue]
+ '("Continue" . rmail-summary-continue))
+
+ (define-key map [menu-bar mail resend]
+ '("Re-send..." . rmail-summary-resend))
+
+ (define-key map [menu-bar mail forward]
+ '("Forward" . rmail-summary-forward))
+
+ (define-key map [menu-bar mail retry]
+ '("Retry" . rmail-summary-retry-failure))
+
+ (define-key map [menu-bar mail reply]
+ '("Reply" . rmail-summary-reply))
+
+ (define-key map [menu-bar mail mail]
+ '("Mail" . rmail-summary-mail))
+
+ (define-key map [menu-bar delete]
+ (cons "Delete" (make-sparse-keymap "Delete")))
+
+ (define-key map [menu-bar delete expunge/save]
+ '("Expunge/Save" . rmail-summary-expunge-and-save))
+
+ (define-key map [menu-bar delete expunge]
+ '("Expunge" . rmail-summary-expunge))
+
+ (define-key map [menu-bar delete undelete]
+ '("Undelete" . rmail-summary-undelete))
+
+ (define-key map [menu-bar delete delete]
+ '("Delete" . rmail-summary-delete-forward))
+
+ (define-key map [menu-bar move]
+ (cons "Move" (make-sparse-keymap "Move")))
+
+ (define-key map [menu-bar move search-back]
+ '("Search Back..." . rmail-summary-search-backward))
+
+ (define-key map [menu-bar move search]
+ '("Search..." . rmail-summary-search))
+
+ (define-key map [menu-bar move previous]
+ '("Previous Nondeleted" . rmail-summary-previous-msg))
+
+ (define-key map [menu-bar move next]
+ '("Next Nondeleted" . rmail-summary-next-msg))
+
+ (define-key map [menu-bar move last]
+ '("Last" . rmail-summary-last-message))
+
+ (define-key map [menu-bar move first]
+ '("First" . rmail-summary-first-message))
+
+ (define-key map [menu-bar move previous]
+ '("Previous" . rmail-summary-previous-all))
+
+ (define-key map [menu-bar move next]
+ '("Next" . rmail-summary-next-all))
+ map)
"Keymap used in Rmail summary mode.")
;; Entry points for making a summary buffer.
@@ -990,207 +1179,6 @@ Search, the `unseen' attribute is restored.")
(save-excursion
(switch-to-buffer rmail-buffer)
(save-buffer))))
-
-
-(if rmail-summary-mode-map
- nil
- (setq rmail-summary-mode-map (make-keymap))
- (suppress-keymap rmail-summary-mode-map)
-
- (define-key rmail-summary-mode-map [mouse-2] 'rmail-summary-mouse-goto-message)
- (define-key rmail-summary-mode-map "a" 'rmail-summary-add-label)
- (define-key rmail-summary-mode-map "b" 'rmail-summary-bury)
- (define-key rmail-summary-mode-map "c" 'rmail-summary-continue)
- (define-key rmail-summary-mode-map "d" 'rmail-summary-delete-forward)
- (define-key rmail-summary-mode-map "\C-d" 'rmail-summary-delete-backward)
- (define-key rmail-summary-mode-map "e" 'rmail-summary-edit-current-message)
- (define-key rmail-summary-mode-map "f" 'rmail-summary-forward)
- (define-key rmail-summary-mode-map "g" 'rmail-summary-get-new-mail)
- (define-key rmail-summary-mode-map "h" 'rmail-summary)
- (define-key rmail-summary-mode-map "i" 'rmail-summary-input)
- (define-key rmail-summary-mode-map "j" 'rmail-summary-goto-msg)
- (define-key rmail-summary-mode-map "\C-m" 'rmail-summary-goto-msg)
- (define-key rmail-summary-mode-map "k" 'rmail-summary-kill-label)
- (define-key rmail-summary-mode-map "l" 'rmail-summary-by-labels)
- (define-key rmail-summary-mode-map "\e\C-h" 'rmail-summary)
- (define-key rmail-summary-mode-map "\e\C-l" 'rmail-summary-by-labels)
- (define-key rmail-summary-mode-map "\e\C-r" 'rmail-summary-by-recipients)
- (define-key rmail-summary-mode-map "\e\C-s" 'rmail-summary-by-regexp)
- ;; `f' for "from".
- (define-key rmail-summary-mode-map "\e\C-f" 'rmail-summary-by-senders)
- (define-key rmail-summary-mode-map "\e\C-t" 'rmail-summary-by-topic)
- (define-key rmail-summary-mode-map "m" 'rmail-summary-mail)
- (define-key rmail-summary-mode-map "\M-m" 'rmail-summary-retry-failure)
- (define-key rmail-summary-mode-map "n" 'rmail-summary-next-msg)
- (define-key rmail-summary-mode-map "\en" 'rmail-summary-next-all)
- (define-key rmail-summary-mode-map "\e\C-n" 'rmail-summary-next-labeled-message)
- (define-key rmail-summary-mode-map "o" 'rmail-summary-output)
- (define-key rmail-summary-mode-map "\C-o" 'rmail-summary-output-as-seen)
- (define-key rmail-summary-mode-map "p" 'rmail-summary-previous-msg)
- (define-key rmail-summary-mode-map "\ep" 'rmail-summary-previous-all)
- (define-key rmail-summary-mode-map "\e\C-p" 'rmail-summary-previous-labeled-message)
- (define-key rmail-summary-mode-map "q" 'rmail-summary-quit)
- (define-key rmail-summary-mode-map "Q" 'rmail-summary-wipe)
- (define-key rmail-summary-mode-map "r" 'rmail-summary-reply)
- (define-key rmail-summary-mode-map "s" 'rmail-summary-expunge-and-save)
- ;; See rms's comment in rmail.el
-;;; (define-key rmail-summary-mode-map "\er" 'rmail-summary-search-backward)
- (define-key rmail-summary-mode-map "\es" 'rmail-summary-search)
- (define-key rmail-summary-mode-map "t" 'rmail-summary-toggle-header)
- (define-key rmail-summary-mode-map "u" 'rmail-summary-undelete)
- (define-key rmail-summary-mode-map "\M-u" 'rmail-summary-undelete-many)
- (define-key rmail-summary-mode-map "x" 'rmail-summary-expunge)
- (define-key rmail-summary-mode-map "w" 'rmail-summary-output-body)
- (define-key rmail-summary-mode-map "v" 'rmail-mime)
- (define-key rmail-summary-mode-map "." 'rmail-summary-beginning-of-message)
- (define-key rmail-summary-mode-map "/" 'rmail-summary-end-of-message)
- (define-key rmail-summary-mode-map "<" 'rmail-summary-first-message)
- (define-key rmail-summary-mode-map ">" 'rmail-summary-last-message)
- (define-key rmail-summary-mode-map " " 'rmail-summary-scroll-msg-up)
- (define-key rmail-summary-mode-map "\177" 'rmail-summary-scroll-msg-down)
- (define-key rmail-summary-mode-map "?" 'describe-mode)
- (define-key rmail-summary-mode-map "\C-c\C-n" 'rmail-summary-next-same-subject)
- (define-key rmail-summary-mode-map "\C-c\C-p" 'rmail-summary-previous-same-subject)
- (define-key rmail-summary-mode-map "\C-c\C-s\C-d"
- 'rmail-summary-sort-by-date)
- (define-key rmail-summary-mode-map "\C-c\C-s\C-s"
- 'rmail-summary-sort-by-subject)
- (define-key rmail-summary-mode-map "\C-c\C-s\C-a"
- 'rmail-summary-sort-by-author)
- (define-key rmail-summary-mode-map "\C-c\C-s\C-r"
- 'rmail-summary-sort-by-recipient)
- (define-key rmail-summary-mode-map "\C-c\C-s\C-c"
- 'rmail-summary-sort-by-correspondent)
- (define-key rmail-summary-mode-map "\C-c\C-s\C-l"
- 'rmail-summary-sort-by-lines)
- (define-key rmail-summary-mode-map "\C-c\C-s\C-k"
- 'rmail-summary-sort-by-labels)
- (define-key rmail-summary-mode-map "\C-x\C-s" 'rmail-summary-save-buffer)
- )
-
-;;; Menu bar bindings.
-
-(define-key rmail-summary-mode-map [menu-bar] (make-sparse-keymap))
-
-(define-key rmail-summary-mode-map [menu-bar classify]
- (cons "Classify" (make-sparse-keymap "Classify")))
-
-(define-key rmail-summary-mode-map [menu-bar classify output-menu]
- '("Output (Rmail Menu)..." . rmail-summary-output-menu))
-
-(define-key rmail-summary-mode-map [menu-bar classify input-menu]
- '("Input Rmail File (menu)..." . rmail-input-menu))
-
-(define-key rmail-summary-mode-map [menu-bar classify input-menu]
- '(nil))
-
-(define-key rmail-summary-mode-map [menu-bar classify output-menu]
- '(nil))
-
-(define-key rmail-summary-mode-map [menu-bar classify output-body]
- '("Output body..." . rmail-summary-output-body))
-
-(define-key rmail-summary-mode-map [menu-bar classify output-inbox]
- '("Output..." . rmail-summary-output))
-
-(define-key rmail-summary-mode-map [menu-bar classify output]
- '("Output as seen..." . rmail-summary-output-as-seen))
-
-(define-key rmail-summary-mode-map [menu-bar classify kill-label]
- '("Kill Label..." . rmail-summary-kill-label))
-
-(define-key rmail-summary-mode-map [menu-bar classify add-label]
- '("Add Label..." . rmail-summary-add-label))
-
-(define-key rmail-summary-mode-map [menu-bar summary]
- (cons "Summary" (make-sparse-keymap "Summary")))
-
-(define-key rmail-summary-mode-map [menu-bar summary senders]
- '("By Senders..." . rmail-summary-by-senders))
-
-(define-key rmail-summary-mode-map [menu-bar summary labels]
- '("By Labels..." . rmail-summary-by-labels))
-
-(define-key rmail-summary-mode-map [menu-bar summary recipients]
- '("By Recipients..." . rmail-summary-by-recipients))
-
-(define-key rmail-summary-mode-map [menu-bar summary topic]
- '("By Topic..." . rmail-summary-by-topic))
-
-(define-key rmail-summary-mode-map [menu-bar summary regexp]
- '("By Regexp..." . rmail-summary-by-regexp))
-
-(define-key rmail-summary-mode-map [menu-bar summary all]
- '("All" . rmail-summary))
-
-(define-key rmail-summary-mode-map [menu-bar mail]
- (cons "Mail" (make-sparse-keymap "Mail")))
-
-(define-key rmail-summary-mode-map [menu-bar mail rmail-summary-get-new-mail]
- '("Get New Mail" . rmail-summary-get-new-mail))
-
-(define-key rmail-summary-mode-map [menu-bar mail lambda]
- '("----"))
-
-(define-key rmail-summary-mode-map [menu-bar mail continue]
- '("Continue" . rmail-summary-continue))
-
-(define-key rmail-summary-mode-map [menu-bar mail resend]
- '("Re-send..." . rmail-summary-resend))
-
-(define-key rmail-summary-mode-map [menu-bar mail forward]
- '("Forward" . rmail-summary-forward))
-
-(define-key rmail-summary-mode-map [menu-bar mail retry]
- '("Retry" . rmail-summary-retry-failure))
-
-(define-key rmail-summary-mode-map [menu-bar mail reply]
- '("Reply" . rmail-summary-reply))
-
-(define-key rmail-summary-mode-map [menu-bar mail mail]
- '("Mail" . rmail-summary-mail))
-
-(define-key rmail-summary-mode-map [menu-bar delete]
- (cons "Delete" (make-sparse-keymap "Delete")))
-
-(define-key rmail-summary-mode-map [menu-bar delete expunge/save]
- '("Expunge/Save" . rmail-summary-expunge-and-save))
-
-(define-key rmail-summary-mode-map [menu-bar delete expunge]
- '("Expunge" . rmail-summary-expunge))
-
-(define-key rmail-summary-mode-map [menu-bar delete undelete]
- '("Undelete" . rmail-summary-undelete))
-
-(define-key rmail-summary-mode-map [menu-bar delete delete]
- '("Delete" . rmail-summary-delete-forward))
-
-(define-key rmail-summary-mode-map [menu-bar move]
- (cons "Move" (make-sparse-keymap "Move")))
-
-(define-key rmail-summary-mode-map [menu-bar move search-back]
- '("Search Back..." . rmail-summary-search-backward))
-
-(define-key rmail-summary-mode-map [menu-bar move search]
- '("Search..." . rmail-summary-search))
-
-(define-key rmail-summary-mode-map [menu-bar move previous]
- '("Previous Nondeleted" . rmail-summary-previous-msg))
-
-(define-key rmail-summary-mode-map [menu-bar move next]
- '("Next Nondeleted" . rmail-summary-next-msg))
-
-(define-key rmail-summary-mode-map [menu-bar move last]
- '("Last" . rmail-summary-last-message))
-
-(define-key rmail-summary-mode-map [menu-bar move first]
- '("First" . rmail-summary-first-message))
-
-(define-key rmail-summary-mode-map [menu-bar move previous]
- '("Previous" . rmail-summary-previous-all))
-
-(define-key rmail-summary-mode-map [menu-bar move next]
- '("Next" . rmail-summary-next-all))
(defun rmail-summary-mouse-goto-message (event)
"Select the message whose summary line you click on."
@@ -1808,7 +1796,7 @@ If prefix argument REVERSE is non-nil, sorts in reverse order."
"Sort messages of current Rmail summary by other correspondent.
This uses either the \"From\", \"Sender\", \"To\", or
\"Apparently-To\" header, downcased. Uses the first header not
-excluded by `rmail-dont-reply-to-names'. If prefix argument
+excluded by `mail-dont-reply-to-names'. If prefix argument
REVERSE is non-nil, sorts in reverse order."
(interactive "P")
(rmail-sort-from-summary (function rmail-sort-by-correspondent) reverse))
@@ -1846,5 +1834,4 @@ the summary is only showing a subset of messages."
;; generated-autoload-file: "rmail.el"
;; End:
-;; arch-tag: 80b0a27a-a50d-4f37-9466-83d32d1e0ca8
;;; rmailsum.el ends here
diff --git a/lisp/mail/sendmail.el b/lisp/mail/sendmail.el
index 8cd650317b1..069ad9662a2 100644
--- a/lisp/mail/sendmail.el
+++ b/lisp/mail/sendmail.el
@@ -1,7 +1,6 @@
;;; sendmail.el --- mail sending commands for Emacs. -*- byte-compile-dynamic: t -*-
-;; Copyright (C) 1985, 1986, 1992, 1993, 1994, 1995, 1996, 1998, 2000,
-;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+;; Copyright (C) 1985-1986, 1992-1996, 1998, 2000-2011
;; Free Software Foundation, Inc.
;; Maintainer: FSF
@@ -28,11 +27,7 @@
;; documented in the Emacs user's manual.
;;; Code:
-(eval-when-compile
- ;; Necessary to avoid recursive `require's.
- (provide 'sendmail)
- (require 'rmail)
- (require 'mailalias))
+(require 'mail-utils)
(autoload 'rfc2047-encode-string "rfc2047")
@@ -146,14 +141,18 @@ Otherwise, let mailer send back a message to report errors."
;; standard value.
;;;###autoload
(put 'send-mail-function 'standard-value
- '((if (and window-system (memq system-type '(darwin windows-nt)))
+ ;; MS-Windows can access the clipboard even under -nw.
+ '((if (or (and window-system (eq system-type 'darwin))
+ (eq system-type 'windows-nt))
'mailclient-send-it
'sendmail-send-it)))
;; Useful to set in site-init.el
;;;###autoload
(defcustom send-mail-function
- (if (and window-system (memq system-type '(darwin windows-nt)))
+ (if (or (and window-system (eq system-type 'darwin))
+ ;; MS-Windows can access the clipboard even under -nw.
+ (eq system-type 'windows-nt))
'mailclient-send-it
'sendmail-send-it)
"Function to call to send the current buffer as mail.
@@ -203,13 +202,14 @@ when you first send mail."
:type '(choice (const nil) string)
:group 'sendmail)
-;;;###autoload
(defcustom mail-alias-file nil
- "If non-nil, the name of a file to use instead of `/usr/lib/aliases'.
+ "If non-nil, the name of a file to use instead of the sendmail default.
This file defines aliases to be expanded by the mailer; this is a different
feature from that of defining aliases in `.mailrc' to be expanded in Emacs.
-This variable has no effect unless your system uses sendmail as its mailer."
- :type '(choice (const nil) file)
+This variable has no effect unless your system uses sendmail as its mailer.
+The default file is defined in sendmail's configuration file, e.g.
+`/etc/aliases'."
+ :type '(choice (const :tag "Sendmail default" nil) file)
:group 'sendmail)
;;;###autoload
@@ -285,19 +285,19 @@ 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
(let ((map (make-sparse-keymap)))
- (define-key map "\M-\t" 'mail-complete)
+ (define-key map "\M-\t" 'completion-at-point)
(define-key map "\C-c?" 'describe-mode)
(define-key map "\C-c\C-f\C-t" 'mail-to)
(define-key map "\C-c\C-f\C-b" 'mail-bcc)
@@ -313,7 +313,6 @@ The default value matches citations like `foo-bar>' plus whitespace."
(define-key map [remap split-line] 'mail-split-line)
(define-key map "\C-c\C-q" 'mail-fill-yanked-message)
(define-key map "\C-c\C-w" 'mail-signature)
- (define-key map "\C-c\C-v" 'mail-sent-via)
(define-key map "\C-c\C-c" 'mail-send-and-exit)
(define-key map "\C-c\C-s" 'mail-send)
(define-key map "\C-c\C-i" 'mail-attach-file)
@@ -353,9 +352,6 @@ The default value matches citations like `foo-bar>' plus whitespace."
(define-key map [menu-bar headers expand-aliases]
'("Expand Aliases" . expand-mail-aliases))
- (define-key map [menu-bar headers sent-via]
- '("Sent-Via" . mail-sent-via))
-
(define-key map [menu-bar headers mail-reply-to]
'("Mail-Reply-To" . mail-mail-reply-to))
@@ -383,15 +379,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'." t)
;;;###autoload
(defcustom mail-signature t
@@ -429,8 +418,7 @@ in `message-auto-save-directory'."
(defvar mail-reply-action nil)
(defvar mail-send-actions nil
"A list of actions to be performed upon successful sending of a message.")
-(put 'mail-reply-action 'permanent-local t)
-(put 'mail-send-actions 'permanent-local t)
+(defvar mail-return-action nil)
;;;###autoload
(defcustom mail-default-headers nil
@@ -440,8 +428,6 @@ before you edit the message, so you can edit or delete the lines."
:type '(choice (const nil) string)
:group 'sendmail)
-;; FIXME no need for autoload
-;;;###autoload
(defcustom mail-bury-selects-summary t
"If non-nil, try to show Rmail summary buffer after returning from mail.
The functions \\[mail-send-on-exit] or \\[mail-dont-send] select
@@ -450,8 +436,6 @@ is non-nil."
:type 'boolean
:group 'sendmail)
-;; FIXME no need for autoload
-;;;###autoload
(defcustom mail-send-nonascii 'mime
"Specify whether to allow sending non-ASCII characters in mail.
If t, that means do allow it. nil means don't allow it.
@@ -475,23 +459,16 @@ support Delivery Status Notification."
;; Note: could use /usr/ucb/mail instead of sendmail;
;; options -t, and -v if not interactive.
-(defvar mail-mailer-swallows-blank-line
- (if (and (string-match "sparc-sun-sunos\\(\\'\\|[^5]\\)" system-configuration)
- (file-readable-p "/etc/sendmail.cf")
- (with-temp-buffer
- (insert-file-contents "/etc/sendmail.cf")
- (goto-char (point-min))
- (let ((case-fold-search nil))
- (re-search-forward "^OR\\>" nil t))))
- ;; According to RFC822, "The field-name must be composed of printable
- ;; ASCII characters (i.e. characters that have decimal values between
- ;; 33 and 126, except colon)", i.e. any chars except ctl chars,
- ;; space, or colon.
- '(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:"))
+(defvar mail-mailer-swallows-blank-line nil
"Set this non-nil if the system's mailer runs the header and body together.
-\(This problem exists on Sunos 4 when sendmail is run in remote mode.)
-The value should be an expression to test whether the problem will
-actually occur.")
+The actual value should be an expression to evaluate that returns
+non-nil if the problem will actually occur.
+\(As far as we know, this is not an issue on any system still supported
+by Emacs.)")
+
+(put 'mail-mailer-swallows-blank-line 'risky-local-variable t) ; gets evalled
+(make-obsolete-variable 'mail-mailer-swallows-blank-line
+ "no need to set this on any modern system." "24.1")
(defvar mail-mode-syntax-table
;; define-derived-mode will make it inherit from text-mode-syntax-table.
@@ -542,16 +519,54 @@ actually occur.")
(setq mail-alias-modtime modtime
mail-aliases t)))))
-(defun mail-setup (to subject in-reply-to cc replybuffer actions)
+
+;;;###autoload
+(define-mail-user-agent 'sendmail-user-agent
+ 'sendmail-user-agent-compose
+ 'mail-send-and-exit)
+
+;;;###autoload
+(defun sendmail-user-agent-compose (&optional to subject other-headers
+ continue switch-function yank-action
+ send-actions return-action
+ &rest ignored)
+ (if switch-function
+ (let ((special-display-buffer-names nil)
+ (special-display-regexps nil)
+ (same-window-buffer-names nil)
+ (same-window-regexps nil))
+ (funcall switch-function "*mail*")))
+ (let ((cc (cdr (assoc-string "cc" other-headers t)))
+ (in-reply-to (cdr (assoc-string "in-reply-to" other-headers t)))
+ (body (cdr (assoc-string "body" other-headers t))))
+ (or (mail continue to subject in-reply-to cc yank-action
+ send-actions return-action)
+ continue
+ (error "Message aborted"))
+ (save-excursion
+ (rfc822-goto-eoh)
+ (while other-headers
+ (unless (member-ignore-case (car (car other-headers))
+ '("in-reply-to" "cc" "body"))
+ (insert (car (car other-headers)) ": "
+ (cdr (car other-headers))
+ (if use-hard-newlines hard-newline "\n")))
+ (setq other-headers (cdr other-headers)))
+ (when body
+ (forward-line 1)
+ (insert body))
+ t)))
+
+(defun mail-setup (to subject in-reply-to cc replybuffer
+ actions return-action)
(or mail-default-reply-to
(setq mail-default-reply-to (getenv "REPLYTO")))
(sendmail-sync-aliases)
- (if (eq mail-aliases t)
- (progn
- (setq mail-aliases nil)
- (when mail-personal-alias-file
- (if (file-exists-p mail-personal-alias-file)
- (build-mail-aliases)))))
+ (when (eq mail-aliases t)
+ (setq mail-aliases nil)
+ (and mail-personal-alias-file
+ (file-exists-p mail-personal-alias-file)
+ (build-mail-aliases)))
;; Don't leave this around from a previous message.
(kill-local-variable 'buffer-file-coding-system)
;; This doesn't work for enable-multibyte-characters.
@@ -559,8 +574,12 @@ actually occur.")
(set-buffer-multibyte (default-value 'enable-multibyte-characters))
(if current-input-method
(inactivate-input-method))
+
+ ;; Local variables for Mail mode.
(setq mail-send-actions actions)
(setq mail-reply-action replybuffer)
+ (setq mail-return-action return-action)
+
(goto-char (point-min))
(if mail-setup-with-from
(mail-insert-from-field))
@@ -646,11 +665,11 @@ Here are commands that move to a header field (and create it if there isn't):
\\[mail-signature] mail-signature (insert `mail-signature-file' file).
\\[mail-yank-original] mail-yank-original (insert current message, in Rmail).
\\[mail-fill-yanked-message] mail-fill-yanked-message (fill what was yanked).
-\\[mail-sent-via] mail-sent-via (add a sent-via field for each To or CC).
Turning on Mail mode runs the normal hooks `text-mode-hook' and
`mail-mode-hook' (in that order)."
(make-local-variable 'mail-reply-action)
(make-local-variable 'mail-send-actions)
+ (make-local-variable 'mail-return-action)
(setq buffer-offer-save t)
(make-local-variable 'font-lock-defaults)
(setq font-lock-defaults '(mail-font-lock-keywords t t))
@@ -673,6 +692,8 @@ Turning on Mail mode runs the normal hooks `text-mode-hook' and
(setq adaptive-fill-first-line-regexp
(concat "[ \t]*[-[:alnum:]]*>+[ \t]*\\|"
adaptive-fill-first-line-regexp))
+ (add-hook 'completion-at-point-functions #'mail-completion-at-point-function
+ nil 'local)
;; `-- ' precedes the signature. `-----' appears at the start of the
;; lines that delimit forwarded messages.
;; Lines containing just >= 3 dashes, perhaps after whitespace,
@@ -718,7 +739,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)
@@ -784,39 +805,9 @@ Prefix arg means don't delete this window."
"Bury this mail buffer."
(let ((newbuf (other-buffer (current-buffer))))
(bury-buffer (current-buffer))
- (if (and (or nil
- ;; In this case, we need to go to a different frame.
- (window-dedicated-p (frame-selected-window))
- ;; In this mode of operation, the frame was probably
- ;; made for this buffer, so the user probably wants
- ;; to delete it now.
- (and pop-up-frames (one-window-p))
- (cdr (assq 'mail-dedicated-frame (frame-parameters))))
- (not (null (delq (selected-frame) (visible-frame-list)))))
- (progn
- (if (display-multi-frame-p)
- (delete-frame (selected-frame))
- ;; The previous frame is where normally they have the
- ;; Rmail buffer displayed.
- (other-frame -1)))
- (let (rmail-flag summary-buffer)
- (and (not arg)
- (not (one-window-p))
- (with-current-buffer
- (window-buffer (next-window (selected-window) 'not))
- (setq rmail-flag (eq major-mode 'rmail-mode))
- (setq summary-buffer
- (and mail-bury-selects-summary
- (boundp 'rmail-summary-buffer)
- rmail-summary-buffer
- (buffer-name rmail-summary-buffer)
- (not (get-buffer-window rmail-summary-buffer))
- rmail-summary-buffer))))
- (if rmail-flag
- ;; If the Rmail buffer has a summary, show that.
- (if summary-buffer (switch-to-buffer summary-buffer)
- (delete-window))
- (switch-to-buffer newbuf))))))
+ (if (and (null arg) mail-return-action)
+ (apply (car mail-return-action) (cdr mail-return-action))
+ (switch-to-buffer newbuf))))
(defcustom mail-send-hook nil
"Hook run just before sending a message."
@@ -1096,23 +1087,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 +1140,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 +1169,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
@@ -1357,6 +1347,9 @@ just append to the file, in Babyl format if necessary."
(point)))))
;; Insert a copy, with altered header field name.
(insert-before-markers "Sent-via:" to-line))))))
+
+(make-obsolete 'mail-sent-via "nobody can remember what it is for." "24.1")
+
(defun mail-to ()
"Move point to end of To field, creating it if necessary."
@@ -1663,9 +1656,11 @@ 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)
+(defun mail (&optional noerase to subject in-reply-to cc replybuffer
+ actions return-action)
"Edit a message to be sent. Prefix arg means resume editing (don't erase).
When this function returns, the buffer `*mail*' is selected.
The value is t if the message was newly initialized; otherwise, nil.
@@ -1713,49 +1708,6 @@ 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))
-
(if (eq noerase 'new)
(pop-to-buffer (generate-new-buffer "*mail*"))
(and noerase
@@ -1775,7 +1727,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))))
@@ -1794,7 +1746,8 @@ The seventh argument ACTIONS is a list of actions to take
t))
(let ((inhibit-read-only t))
(erase-buffer)
- (mail-setup to subject in-reply-to cc replybuffer actions)
+ (mail-setup to subject in-reply-to cc replybuffer actions
+ return-action)
(setq initialized t)))
(if (and buffer-auto-save-file-name
(file-exists-p buffer-auto-save-file-name))
@@ -1824,6 +1777,9 @@ The seventh argument ACTIONS is a list of actions to take
;; names are normally ``trivial'', so Dired will set point after
;; all the files, at buffer bottom. We want it on the first
;; file instead.
+ ;; Require dired so that dired-trivial-filenames does not get
+ ;; unbound on exit from the let.
+ (require 'dired)
(let ((dired-trivial-filenames t))
(dired-other-window wildcard (concat dired-listing-switches "t")))
(rename-buffer "*Auto-saved Drafts*" t)
@@ -1954,5 +1910,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/smtpmail.el b/lisp/mail/smtpmail.el
index f59e8b02cd0..427d9d17746 100644
--- a/lisp/mail/smtpmail.el
+++ b/lisp/mail/smtpmail.el
@@ -1,7 +1,6 @@
;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail
-;; Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-1996, 2001-2011 Free Software Foundation, Inc.
;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
;; Maintainer: Simon Josefsson <simon@josefsson.org>
@@ -78,7 +77,7 @@
(autoload 'netrc-machine "netrc")
(autoload 'netrc-get "netrc")
(autoload 'password-read "password-cache")
-(autoload 'auth-source-user-or-password "auth-source")
+(autoload 'auth-source-search "auth-source")
;;;
(defgroup smtpmail nil
@@ -539,10 +538,14 @@ The list is in preference order.")
(defun smtpmail-try-auth-methods (process supported-extensions host port)
(let* ((mechs (cdr-safe (assoc 'auth supported-extensions)))
(mech (car (smtpmail-intersection mechs smtpmail-auth-supported)))
- (auth-user (auth-source-user-or-password
- "login" host (or port "smtp")))
- (auth-pass (auth-source-user-or-password
- "password" host (or port "smtp")))
+ (auth-info (auth-source-search :max 1
+ :host host
+ :port (or port "smtp")))
+ (auth-user (plist-get (nth 0 auth-info) :user))
+ (auth-pass (plist-get (nth 0 auth-info) :secret))
+ (auth-pass (if (functionp auth-pass)
+ (funcall auth-pass)
+ auth-pass))
(cred (if (and auth-user auth-pass) ; try user-auth-* before netrc-*
(list host port auth-user auth-pass)
;; else, if auth-source didn't return them...
diff --git a/lisp/mail/supercite.el b/lisp/mail/supercite.el
index 0dacfc3402d..084b623080a 100644
--- a/lisp/mail/supercite.el
+++ b/lisp/mail/supercite.el
@@ -1,7 +1,6 @@
;;; supercite.el --- minor mode for citing mail and news replies
-;; Copyright (C) 1993, 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1997, 2001-2011 Free Software Foundation, Inc.
;; Author: 1993 Barry A. Warsaw <bwarsaw@python.org>
;; Maintainer: Glenn Morris <rgm@gnu.org>
@@ -34,7 +33,6 @@
(require 'regi)
-(require 'sendmail) ;; For mail-header-end.
;; start user configuration variables
;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
@@ -1484,18 +1482,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 +1618,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))
@@ -1995,5 +1996,4 @@ version at point."
(provide 'supercite)
(run-hooks 'sc-load-hook)
-;; arch-tag: a5d5bfa6-3bd5-4414-8c65-0afc83e45cd3
;;; supercite.el ends here
diff --git a/lisp/mail/uce.el b/lisp/mail/uce.el
index e71dd9cea22..f1bd98af297 100644
--- a/lisp/mail/uce.el
+++ b/lisp/mail/uce.el
@@ -1,7 +1,6 @@
;;; uce.el --- facilitate reply to unsolicited commercial email
-;; Copyright (C) 1996, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1998, 2000-2011 Free Software Foundation, Inc.
;; Author: stanislav shalunov <shalunov@mccme.ru>
;; Created: 10 Dec 1996
@@ -375,5 +374,4 @@ You might need to set `uce-mail-reader' before using this."
(provide 'uce)
-;; arch-tag: 44b68c87-9b29-47bd-822c-3feee3883221
;;; uce.el ends here
diff --git a/lisp/mail/undigest.el b/lisp/mail/undigest.el
index 0403c4afc6c..04bb320a2ab 100644
--- a/lisp/mail/undigest.el
+++ b/lisp/mail/undigest.el
@@ -1,7 +1,7 @@
;;; undigest.el --- digest-cracking support for the RMAIL mail reader
-;; Copyright (C) 1985, 1986, 1994, 1996, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1986, 1994, 1996, 2001-2011
+;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: mail
@@ -329,5 +329,4 @@ following the containing message."
;; generated-autoload-file: "rmail.el"
;; End:
-;; arch-tag: 3a28b9fb-c1f5-43ef-9278-285f3e4b874d
;;; undigest.el ends here
diff --git a/lisp/mail/unrmail.el b/lisp/mail/unrmail.el
index 4aa727f9f50..9ed2e90b456 100644
--- a/lisp/mail/unrmail.el
+++ b/lisp/mail/unrmail.el
@@ -1,7 +1,6 @@
;;; unrmail.el --- convert Rmail Babyl files to mailbox files
-;; Copyright (C) 1992, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: mail
@@ -245,5 +244,4 @@ For example, invoke `emacs -batch -f batch-unrmail RMAIL'."
(provide 'unrmail)
-;; arch-tag: 14c6290d-60b2-456f-8909-5c2387de6acb
;;; unrmail.el ends here
diff --git a/lisp/mail/uudecode.el b/lisp/mail/uudecode.el
index 22b97b4b7bb..8652e67d3e1 100644
--- a/lisp/mail/uudecode.el
+++ b/lisp/mail/uudecode.el
@@ -1,7 +1,6 @@
;;; uudecode.el -- elisp native uudecode
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
;; Keywords: uudecode news
@@ -216,7 +215,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 +235,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 c6f5862fcb5..c844a8f6630 100644
--- a/lisp/makefile.w32-in
+++ b/lisp/makefile.w32-in
@@ -1,6 +1,5 @@
# -*- Makefile -*- for GNU Emacs on the Microsoft W32 API.
-# Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-# 2009, 2010, 2011 Free Software Foundation, Inc.
+# Copyright (C) 2000-2011 Free Software Foundation, Inc.
# This file is part of GNU Emacs.
@@ -28,14 +27,13 @@ lisp = $(CURDIR)
srcdir = $(CURDIR)/..
# You can specify a different executable on the make command line,
-# e.g. "make EMACS=../src/emacs ...".
+# e.g. "make EMACS=../bin/emacs ...".
-EMACS = $(THISDIR)/../bin/emacs.exe
+EMACS = ../src/$(BLD)/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-site-file --no-site-lisp
# Extra flags to pass to the byte compiler
BYTE_COMPILE_EXTRA_FLAGS =
@@ -51,12 +49,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 \
@@ -64,6 +66,15 @@ AUTOGENEL = $(lisp)/loaddefs.el $(LOADDEFS) $(lisp)/cus-load.el \
$(lisp)/cedet/semantic/loaddefs.el $(lisp)/cedet/ede/loaddefs.el \
$(lisp)/cedet/srecode/loaddefs.el
+# Value of max-lisp-eval-depth when compiling initially.
+# During bootstrapping the byte-compiler is run interpreted when compiling
+# itself, and uses more stack than usual.
+#
+BIG_STACK_DEPTH = 1200
+BIG_STACK_OPTS = --eval "(setq max-lisp-eval-depth $(BIG_STACK_DEPTH))"
+
+BYTE_COMPILE_FLAGS = $(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS)
+
# Files to compile before others during a bootstrap. This is done to
# speed up the bootstrap process. The CC files are compiled first
# because CC mode tweaks the compilation process, and requiring
@@ -73,6 +84,8 @@ AUTOGENEL = $(lisp)/loaddefs.el $(LOADDEFS) $(lisp)/cus-load.el \
COMPILE_FIRST = \
$(lisp)/emacs-lisp/byte-opt.el \
$(lisp)/emacs-lisp/bytecomp.el \
+ $(lisp)/emacs-lisp/macroexp.el \
+ $(lisp)/emacs-lisp/cconv.el \
$(lisp)/subr.el \
$(lisp)/progmodes/cc-mode.el \
$(lisp)/progmodes/cc-vars.el
@@ -114,7 +127,8 @@ WINS_BASIC=\
play \
progmodes \
textmodes \
- url
+ url \
+ vc
# Directories with lisp files to compile, and to extract data from
# (customs, autoloads, etc.)
@@ -244,16 +258,47 @@ 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: TAGS-LISP-$(MAKETYPE)
+
+TAGS-nmake:
+ echo This target is not supported with NMake
+ exit -1
-TAGS-LISP: $(lisptagsfiles1) $(lisptagsfiles2)
- $(ETAGS) -o TAGS-LISP $(lisptagsfiles1) $(lisptagsfiles2)
+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
.el.elc:
- -$(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $<
+ -$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $<
# Compile all Lisp files, but don't recompile those that are up to
# date. Some files don't actually get compiled because they set the
@@ -273,22 +318,22 @@ compile: $(lisp)/subdirs.el mh-autoloads compile-$(SHELLTYPE) doit
compile-CMD:
# -for %%f in ($(lisp) $(WINS)) do for %%g in (%%f\*.elc) do @attrib -r %%g
for %%f in ($(COMPILE_FIRST)) do \
- $(emacs) -l loaddefs $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile-if-not-done %%f
+ $(emacs) -l loaddefs $(BYTE_COMPILE_FLAGS) -f batch-byte-compile-if-not-done %%f
for %%f in (. $(WINS)) do for %%g in (%%f/*.el) do \
- $(emacs) -l loaddefs $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile-if-not-done %%f/%%g
+ $(emacs) -l loaddefs $(BYTE_COMPILE_FLAGS) -f batch-byte-compile-if-not-done %%f/%%g
compile-SH:
# for elc in $(lisp)/*.elc $(lisp)/*/*.elc; do attrib -r $$elc; done
for el in $(COMPILE_FIRST); do \
echo Compiling $$el; \
- $(emacs) -l loaddefs $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile-if-not-done $$el; \
+ $(emacs) -l loaddefs $(BYTE_COMPILE_FLAGS) -f batch-byte-compile-if-not-done $$el; \
done
for dir in $(lisp) $(WINS); do \
for el in $$dir/*.el; do \
if test -f $$el; \
then \
echo Compiling $$el; \
- $(emacs) -l loaddefs $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile-if-not-done $$el; \
+ $(emacs) -l loaddefs $(BYTE_COMPILE_FLAGS) -f batch-byte-compile-if-not-done $$el; \
fi \
done; \
done
@@ -301,31 +346,31 @@ compile-always: $(lisp)/subdirs.el compile-always-$(SHELLTYPE) doit
compile-always-CMD:
# -for %%f in ($(lisp) $(WINS)) do for %%g in (%%f\*.elc) do @attrib -r %%g
- for %%f in ($(COMPILE_FIRST)) do $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile %%f
- for %%f in (. $(WINS)) do for %%g in (%%f/*.el) do $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile %%f/%%g
+ for %%f in ($(COMPILE_FIRST)) do $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile %%f
+ for %%f in (. $(WINS)) do for %%g in (%%f/*.el) do $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile %%f/%%g
compile-always-SH:
# for elc in $(lisp)/*.elc $(lisp)/*/*.elc; do attrib -r $$elc; done
for el in $(COMPILE_FIRST); do \
echo Compiling $$el; \
- $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $$el || exit 1; \
+ $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $$el || exit 1; \
done
for dir in $(lisp) $(WINS); do \
for el in $$dir/*.el; do \
echo Compiling $$el; \
- $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $$el || exit 1; \
+ $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $$el || exit 1; \
done; \
done
compile-calc: compile-calc-$(SHELLTYPE)
compile-calc-CMD:
- for %%f in ($(lisp)/calc/*.el) do $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile %%f
+ for %%f in ($(lisp)/calc/*.el) do $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile %%f
compile-calc-SH:
for el in $(lisp)/calc/*.el; do \
echo Compiling $$el; \
- $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $$el || exit 1; \
+ $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $$el || exit 1; \
done
# Backup compiled Lisp files in elc.tar.gz. If that file already
@@ -403,6 +448,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-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 8c55c2d0e84..21fc693cfd6 100644
--- a/lisp/makesum.el
+++ b/lisp/makesum.el
@@ -1,7 +1,6 @@
;;; makesum.el --- generate key binding summary for Emacs
-;; Copyright (C) 1985, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: help
@@ -86,8 +85,7 @@ Previous contents of that buffer are killed first."
(defun double-column (start end)
(interactive "r")
- (let (half cnt
- line lines nlines
+ (let (half line lines nlines
(from-end (- (point-max) end)))
(setq nlines (count-lines start end))
(if (<= nlines 1)
@@ -98,7 +96,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 +110,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 6e0c9724672..7a9e6e3cca5 100644
--- a/lisp/man.el
+++ b/lisp/man.el
@@ -1,7 +1,7 @@
;;; man.el --- browse UNIX manual pages -*- coding: iso-8859-1 -*-
-;; Copyright (C) 1993, 1994, 1996, 1997, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1994, 1996-1997, 2001-2011
+;; Free Software Foundation, Inc.
;; Author: Barry A. Warsaw <bwarsaw@cen.com>
;; Maintainer: FSF
@@ -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.")
@@ -249,8 +254,7 @@ the associated section number."
"Regular expression describing a manpage section within parentheses.")
(defvar Man-page-header-regexp
- (if (and (string-match "-solaris2\\." system-configuration)
- (not (string-match "-solaris2\\.[123435]$" system-configuration)))
+ (if (string-match "-solaris2\\." system-configuration)
(concat "^[-A-Za-z0-9_].*[ \t]\\(" Man-name-regexp
"(\\(" Man-section-regexp "\\))\\)$")
(concat "^[ \t]*\\(" Man-name-regexp
@@ -618,36 +622,32 @@ and the `Man-section-translations-alist' variables)."
(concat Man-specified-section-option section " " name))))
(defun Man-support-local-filenames ()
- "Check the availability of `-l' option of the man command.
-This option allows `man' to interpret command line arguments
-as local filenames.
-Return the value of the variable `Man-support-local-filenames'
-if it was set to nil or t before the call of this function.
-If t, the man command supports `-l' option. If nil, it doesn't.
-Otherwise, if the value of `Man-support-local-filenames'
-is neither t nor nil, then determine a new value, set it
-to the variable `Man-support-local-filenames' and return
-a new value."
- (if (or (not Man-support-local-filenames)
- (eq Man-support-local-filenames t))
- Man-support-local-filenames
- (setq Man-support-local-filenames
- (with-temp-buffer
- (and (equal (condition-case nil
- (let ((default-directory
- ;; Assure that `default-directory' exists
- ;; and is readable.
- (if (and (file-directory-p default-directory)
- (file-readable-p default-directory))
- default-directory
- (expand-file-name "~/"))))
- (call-process manual-program nil t nil "--help"))
- (error nil))
- 0)
- (progn
- (goto-char (point-min))
- (search-forward "--local-file" nil t))
- t)))))
+ "Return non-nil if the man command supports local filenames.
+Different man programs support this feature in different ways.
+The default Debian man program (\"man-db\") has a `--local-file'
+\(or `-l') option for this purpose. The default Red Hat man
+program has no such option, but interprets any name containing
+a \"/\" as a local filename. The function returns either `man-db'
+`man', or nil."
+ (if (eq Man-support-local-filenames 'auto-detect)
+ (setq Man-support-local-filenames
+ (with-temp-buffer
+ (let ((default-directory
+ ;; Ensure that `default-directory' exists and is readable.
+ (if (and (file-directory-p default-directory)
+ (file-readable-p default-directory))
+ default-directory
+ (expand-file-name "~/"))))
+ (ignore-errors
+ (call-process manual-program nil t nil "--help")))
+ (cond ((search-backward "--local-file" nil 'move)
+ 'man-db)
+ ;; This feature seems to be present in at least ver 1.4f,
+ ;; which is about 20 years old.
+ ;; I don't know if this version has an official name?
+ ((looking-at "^man, versione? [1-9]")
+ 'man))))
+ Man-support-local-filenames))
;; ======================================================================
@@ -886,7 +886,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 +965,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 +985,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 ""))
)))
@@ -1148,7 +1149,9 @@ default type, `Man-xref-man-page' is used for the buttons."
(goto-char (point-min))
nil)))
(while (re-search-forward regexp end t)
- (make-text-button
+ ;; An overlay button is preferable because the underlying text
+ ;; may have text property highlights (Bug#7881).
+ (make-button
(match-beginning button-pos)
(match-end button-pos)
'type type
@@ -1272,6 +1275,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 +1333,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 +1669,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)
@@ -1671,5 +1718,4 @@ Specify which REFERENCE to use; default is based on word at point."
(provide 'man)
-;; arch-tag: 587cda76-8e23-4594-b1f3-89b6b09a0d47
;;; man.el ends here
diff --git a/lisp/master.el b/lisp/master.el
index 7b5ed66f741..1ea0a24ca94 100644
--- a/lisp/master.el
+++ b/lisp/master.el
@@ -1,7 +1,6 @@
;;; master.el --- make a buffer the master over another buffer
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Alex Schroeder <alex@gnu.org>
;; Maintainer: Alex Schroeder <alex@gnu.org>
@@ -159,5 +158,4 @@ See `recenter'."
(provide 'master)
-;; arch-tag: dca08daa-8127-45ae-b77e-b135160dce98
;;; master.el ends here
diff --git a/lisp/mb-depth.el b/lisp/mb-depth.el
index 80847609d0d..2ed692c1b84 100644
--- a/lisp/mb-depth.el
+++ b/lisp/mb-depth.el
@@ -1,6 +1,6 @@
;;; mb-depth.el --- Indicate minibuffer-depth in prompt
;;
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
;;
;; Author: Miles Bader <miles@gnu.org>
;; Keywords: convenience
@@ -72,5 +72,4 @@ Returns non-nil if the new state is enabled."
(provide 'mb-depth)
-;; arch-tag: 50224089-5bf5-46f8-803d-18f018c5eacf
;;; mb-depth.el ends here
diff --git a/lisp/md4.el b/lisp/md4.el
index 1d4dbc99f50..8d89004de23 100644
--- a/lisp/md4.el
+++ b/lisp/md4.el
@@ -1,6 +1,6 @@
;;; md4.el --- MD4 Message Digest Algorithm.
-;; Copyright (C) 2001, 2004, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2004, 2007-2011 Free Software Foundation, Inc.
;; Author: Taro Kawagishi <tarok@transpulse.org>
;; Keywords: MD4
@@ -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 00c1572881f..8a33381b618 100644
--- a/lisp/menu-bar.el
+++ b/lisp/menu-bar.el
@@ -1,11 +1,11 @@
;;; menu-bar.el --- define a default menu bar
-;; Copyright (C) 1993, 1994, 1995, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1995, 2000-2011 Free Software Foundation, Inc.
;; Author: RMS
;; Maintainer: FSF
;; Keywords: internal, mouse
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -28,146 +28,181 @@
;;; Code:
+;; This is referenced by some code below; it is defined in uniquify.el
+(defvar uniquify-buffer-name-style)
+
+;; From emulation/cua-base.el; used below
+(defvar cua-enable-cua-keys)
+
+
;; Don't clobber an existing menu-bar keymap, to preserve any menu-bar key
;; definitions made in loaddefs.el.
(or (lookup-key global-map [menu-bar])
(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"))))
-(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))
;; 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"))
-(define-key global-map [menu-bar buffer]
- (cons (purecopy "Buffers") global-buffers-menu-map))
-(defvar menu-bar-options-menu (make-sparse-keymap "Options"))
-(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))
-(defvar menu-bar-file-menu (make-sparse-keymap "File"))
-(define-key global-map [menu-bar file] (cons (purecopy "File") menu-bar-file-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")
-
-;; This is referenced by some code below; it is defined in uniquify.el
-(defvar uniquify-buffer-name-style)
-
-;; From emulation/cua-base.el; used below
-(defvar cua-enable-cua-keys)
-
-
-;; The "File" menu items
-(define-key menu-bar-file-menu [exit-emacs]
- `(menu-item ,(purecopy "Quit") save-buffers-kill-terminal
- :help ,(purecopy "Save unsaved buffers, then exit")))
-
-(define-key menu-bar-file-menu [separator-exit]
- menu-bar-separator)
-
-;; Don't use delete-frame as event name because that is a special
-;; event.
-(define-key menu-bar-file-menu [delete-this-frame]
- `(menu-item ,(purecopy "Delete Frame") delete-frame
- :visible (fboundp 'delete-frame)
- :enable (delete-frame-enabled-p)
- :help ,(purecopy "Delete currently selected frame")))
-(define-key menu-bar-file-menu [make-frame-on-display]
- `(menu-item ,(purecopy "New Frame on Display...") make-frame-on-display
- :visible (fboundp 'make-frame-on-display)
- :help ,(purecopy "Open a new frame on another display")))
-(define-key menu-bar-file-menu [make-frame]
- `(menu-item ,(purecopy "New Frame") make-frame-command
- :visible (fboundp 'make-frame-command)
- :help ,(purecopy "Open a new frame")))
-
-(define-key menu-bar-file-menu [one-window]
- `(menu-item ,(purecopy "Remove Splits") delete-other-windows
- :enable (not (one-window-p t nil))
- :help ,(purecopy "Selected window grows to fill the whole frame")))
-
-(define-key menu-bar-file-menu [split-window]
- `(menu-item ,(purecopy "Split Window") split-window-vertically
- :enable (and (menu-bar-menu-frame-live-and-visible-p)
- (menu-bar-non-minibuffer-window-p))
- :help ,(purecopy "Split selected window in two windows")))
-
-(define-key menu-bar-file-menu [separator-window]
- menu-bar-separator)
-
-(define-key menu-bar-file-menu [ps-print-region]
- `(menu-item ,(purecopy "Postscript Print Region (B+W)") ps-print-region
- :enable mark-active
- :help ,(purecopy "Pretty-print marked region in black and white to PostScript printer")))
-(define-key menu-bar-file-menu [ps-print-buffer]
- `(menu-item ,(purecopy "Postscript Print Buffer (B+W)") ps-print-buffer
- :enable (menu-bar-menu-frame-live-and-visible-p)
- :help ,(purecopy "Pretty-print current buffer in black and white to PostScript printer")))
-(define-key menu-bar-file-menu [ps-print-region-faces]
- `(menu-item ,(purecopy "Postscript Print Region") ps-print-region-with-faces
- :enable mark-active
- :help ,(purecopy "Pretty-print marked region to PostScript printer")))
-(define-key menu-bar-file-menu [ps-print-buffer-faces]
- `(menu-item ,(purecopy "Postscript Print Buffer") ps-print-buffer-with-faces
- :enable (menu-bar-menu-frame-live-and-visible-p)
- :help ,(purecopy "Pretty-print current buffer to PostScript printer")))
-(define-key menu-bar-file-menu [print-region]
- `(menu-item ,(purecopy "Print Region") print-region
- :enable mark-active
- :help ,(purecopy "Print region between mark and current position")))
-(define-key menu-bar-file-menu [print-buffer]
- `(menu-item ,(purecopy "Print Buffer") print-buffer
- :enable (menu-bar-menu-frame-live-and-visible-p)
- :help ,(purecopy "Print current buffer with page headings")))
-
-(define-key menu-bar-file-menu [separator-print]
- menu-bar-separator)
-
-(define-key menu-bar-file-menu [recover-session]
- `(menu-item ,(purecopy "Recover Crashed Session") recover-session
- :enable (and auto-save-list-file-prefix
- (file-directory-p
- (file-name-directory auto-save-list-file-prefix))
- (directory-files
- (file-name-directory auto-save-list-file-prefix)
- nil
- (concat "\\`"
- (regexp-quote
- (file-name-nondirectory
- auto-save-list-file-prefix)))
- t))
- :help ,(purecopy "Recover edits from a crashed session")))
-(define-key menu-bar-file-menu [revert-buffer]
- `(menu-item ,(purecopy "Revert Buffer") revert-buffer
- :enable (or revert-buffer-function
- revert-buffer-insert-file-contents-function
- (and buffer-file-number
- (or (buffer-modified-p)
- (not (verify-visited-file-modtime
- (current-buffer))))))
- :help ,(purecopy "Re-read current buffer from its file")))
-(define-key menu-bar-file-menu [write-file]
- `(menu-item ,(purecopy "Save As...") write-file
- :enable (and (menu-bar-menu-frame-live-and-visible-p)
- (menu-bar-non-minibuffer-window-p))
- :help ,(purecopy "Write current buffer to another file")))
-(define-key menu-bar-file-menu [save-buffer]
- `(menu-item ,(purecopy "Save") save-buffer
- :enable (and (buffer-modified-p)
- (buffer-file-name)
- (menu-bar-non-minibuffer-window-p))
- :help ,(purecopy "Save current buffer to its file")))
-
-(define-key menu-bar-file-menu [separator-save]
- menu-bar-separator)
+(define-obsolete-variable-alias
+ 'menu-bar-files-menu 'menu-bar-file-menu "22.1")
+(defvar menu-bar-file-menu
+ (let ((menu (make-sparse-keymap "File")))
+
+ ;; The "File" menu items
+ (define-key menu [exit-emacs]
+ `(menu-item ,(purecopy "Quit") save-buffers-kill-terminal
+ :help ,(purecopy "Save unsaved buffers, then exit")))
+
+ (define-key menu [separator-exit]
+ menu-bar-separator)
+
+ ;; Don't use delete-frame as event name because that is a special
+ ;; event.
+ (define-key menu [delete-this-frame]
+ `(menu-item ,(purecopy "Delete Frame") delete-frame
+ :visible (fboundp 'delete-frame)
+ :enable (delete-frame-enabled-p)
+ :help ,(purecopy "Delete currently selected frame")))
+ (define-key menu [make-frame-on-display]
+ `(menu-item ,(purecopy "New Frame on Display...") make-frame-on-display
+ :visible (fboundp 'make-frame-on-display)
+ :help ,(purecopy "Open a new frame on another display")))
+ (define-key menu [make-frame]
+ `(menu-item ,(purecopy "New Frame") make-frame-command
+ :visible (fboundp 'make-frame-command)
+ :help ,(purecopy "Open a new frame")))
+
+ (define-key menu [one-window]
+ `(menu-item ,(purecopy "Remove Splits") delete-other-windows
+ :enable (not (one-window-p t nil))
+ :help ,(purecopy
+ "Selected window grows to fill the whole frame")))
+
+ (define-key menu [split-window]
+ `(menu-item ,(purecopy "Split Window") split-window-vertically
+ :enable (and (menu-bar-menu-frame-live-and-visible-p)
+ (menu-bar-non-minibuffer-window-p))
+ :help ,(purecopy "Split selected window in two windows")))
+
+ (define-key menu [separator-window]
+ menu-bar-separator)
+
+ (define-key menu [ps-print-region]
+ `(menu-item ,(purecopy "Postscript Print Region (B+W)") ps-print-region
+ :enable mark-active
+ :help ,(purecopy "Pretty-print marked region in black and white to PostScript printer")))
+ (define-key menu [ps-print-buffer]
+ `(menu-item ,(purecopy "Postscript Print Buffer (B+W)") ps-print-buffer
+ :enable (menu-bar-menu-frame-live-and-visible-p)
+ :help ,(purecopy "Pretty-print current buffer in black and white to PostScript printer")))
+ (define-key menu [ps-print-region-faces]
+ `(menu-item ,(purecopy "Postscript Print Region")
+ ps-print-region-with-faces
+ :enable mark-active
+ :help ,(purecopy
+ "Pretty-print marked region to PostScript printer")))
+ (define-key menu [ps-print-buffer-faces]
+ `(menu-item ,(purecopy "Postscript Print Buffer")
+ ps-print-buffer-with-faces
+ :enable (menu-bar-menu-frame-live-and-visible-p)
+ :help ,(purecopy "Pretty-print current buffer to PostScript printer")))
+ (define-key menu [print-region]
+ `(menu-item ,(purecopy "Print Region") print-region
+ :enable mark-active
+ :help ,(purecopy "Print region between mark and current position")))
+ (define-key menu [print-buffer]
+ `(menu-item ,(purecopy "Print Buffer") print-buffer
+ :enable (menu-bar-menu-frame-live-and-visible-p)
+ :help ,(purecopy "Print current buffer with page headings")))
+
+ (define-key menu [separator-print]
+ menu-bar-separator)
+
+ (define-key menu [recover-session]
+ `(menu-item ,(purecopy "Recover Crashed Session") recover-session
+ :enable
+ (and auto-save-list-file-prefix
+ (file-directory-p
+ (file-name-directory auto-save-list-file-prefix))
+ (directory-files
+ (file-name-directory auto-save-list-file-prefix)
+ nil
+ (concat "\\`"
+ (regexp-quote
+ (file-name-nondirectory
+ auto-save-list-file-prefix)))
+ t))
+ :help ,(purecopy "Recover edits from a crashed session")))
+ (define-key menu [revert-buffer]
+ `(menu-item ,(purecopy "Revert Buffer") revert-buffer
+ :enable (or revert-buffer-function
+ revert-buffer-insert-file-contents-function
+ (and buffer-file-number
+ (or (buffer-modified-p)
+ (not (verify-visited-file-modtime
+ (current-buffer))))))
+ :help ,(purecopy "Re-read current buffer from its file")))
+ (define-key menu [write-file]
+ `(menu-item ,(purecopy "Save As...") write-file
+ :enable (and (menu-bar-menu-frame-live-and-visible-p)
+ (menu-bar-non-minibuffer-window-p))
+ :help ,(purecopy "Write current buffer to another file")))
+ (define-key menu [save-buffer]
+ `(menu-item ,(purecopy "Save") save-buffer
+ :enable (and (buffer-modified-p)
+ (buffer-file-name)
+ (menu-bar-non-minibuffer-window-p))
+ :help ,(purecopy "Save current buffer to its file")))
+
+ (define-key menu [separator-save]
+ menu-bar-separator)
+
+
+ (define-key menu [kill-buffer]
+ `(menu-item ,(purecopy "Close") kill-this-buffer
+ :enable (kill-this-buffer-enabled-p)
+ :help ,(purecopy "Discard (kill) current buffer")))
+ (define-key menu [insert-file]
+ `(menu-item ,(purecopy "Insert File...") insert-file
+ :enable (menu-bar-non-minibuffer-window-p)
+ :help ,(purecopy "Insert another file into current buffer")))
+ (define-key menu [dired]
+ `(menu-item ,(purecopy "Open Directory...") dired
+ :enable (menu-bar-non-minibuffer-window-p)
+ :help ,(purecopy
+ "Read a directory, to operate on its files")))
+ (define-key menu [open-file]
+ `(menu-item ,(purecopy "Open File...") menu-find-file-existing
+ :enable (menu-bar-non-minibuffer-window-p)
+ :help ,(purecopy
+ "Read an existing file into an Emacs buffer")))
+ (define-key menu [new-file]
+ `(menu-item ,(purecopy "Visit New File...") find-file
+ :enable (menu-bar-non-minibuffer-window-p)
+ :help ,(purecopy
+ "Specify a new file's name, to edit the file")))
+
+ menu))
(defun menu-find-file-existing ()
"Edit the existing file FILENAME."
@@ -179,31 +214,6 @@
(find-file-existing filename)
(find-file filename))))
-
-(define-key menu-bar-file-menu [kill-buffer]
- `(menu-item ,(purecopy "Close") kill-this-buffer
- :enable (kill-this-buffer-enabled-p)
- :help ,(purecopy "Discard (kill) current buffer")))
-(define-key menu-bar-file-menu [insert-file]
- `(menu-item ,(purecopy "Insert File...") insert-file
- :enable (menu-bar-non-minibuffer-window-p)
- :help ,(purecopy "Insert another file into current buffer")))
-(define-key menu-bar-file-menu [dired]
- `(menu-item ,(purecopy "Open Directory...") dired
- :enable (menu-bar-non-minibuffer-window-p)
- :help ,(purecopy "Read a directory, to operate on its files")))
-(define-key menu-bar-file-menu [open-file]
- `(menu-item ,(purecopy "Open File...") menu-find-file-existing
- :enable (menu-bar-non-minibuffer-window-p)
- :help ,(purecopy "Read an existing file into an Emacs buffer")))
-(define-key menu-bar-file-menu [new-file]
- `(menu-item ,(purecopy "Visit New File...") find-file
- :enable (menu-bar-non-minibuffer-window-p)
- :help ,(purecopy "Specify a new file's name, to edit the file")))
-
-
-;; The "Edit" menu items
-
;; The "Edit->Search" submenu
(defvar menu-bar-last-search-type nil
"Type of last non-incremental search command called from the menu.")
@@ -270,126 +280,253 @@
(isearch-update-ring string t)
(re-search-backward string)))
-(defvar menu-bar-search-menu (make-sparse-keymap "Search"))
-
;; The Edit->Search->Incremental Search menu
(defvar menu-bar-i-search-menu
- (make-sparse-keymap "Incremental Search"))
-
-(define-key menu-bar-i-search-menu [isearch-backward-regexp]
- `(menu-item ,(purecopy "Backward Regexp...") isearch-backward-regexp
- :help ,(purecopy "Search backwards for a regular expression as you type it")))
-(define-key menu-bar-i-search-menu [isearch-forward-regexp]
- `(menu-item ,(purecopy "Forward Regexp...") isearch-forward-regexp
- :help ,(purecopy "Search forward for a regular expression as you type it")))
-(define-key menu-bar-i-search-menu [isearch-backward]
- `(menu-item ,(purecopy "Backward String...") isearch-backward
- :help ,(purecopy "Search backwards for a string as you type it")))
-(define-key menu-bar-i-search-menu [isearch-forward]
- `(menu-item ,(purecopy "Forward String...") isearch-forward
- :help ,(purecopy "Search forward for a string as you type it")))
-
-(define-key menu-bar-search-menu [i-search]
- `(menu-item ,(purecopy "Incremental Search") ,menu-bar-i-search-menu))
-(define-key menu-bar-search-menu [separator-tag-isearch]
- menu-bar-separator)
-
-(define-key menu-bar-search-menu [tags-continue]
- `(menu-item ,(purecopy "Continue Tags Search") tags-loop-continue
- :help ,(purecopy "Continue last tags search operation")))
-(define-key menu-bar-search-menu [tags-srch]
- `(menu-item ,(purecopy "Search Tagged Files...") tags-search
- :help ,(purecopy "Search for a regexp in all tagged files")))
-(define-key menu-bar-search-menu [separator-tag-search]
- menu-bar-separator)
-
-(define-key menu-bar-search-menu [repeat-search-back]
- `(menu-item ,(purecopy "Repeat Backwards") nonincremental-repeat-search-backward
- :enable (or (and (eq menu-bar-last-search-type 'string)
- search-ring)
- (and (eq menu-bar-last-search-type 'regexp)
- regexp-search-ring))
- :help ,(purecopy "Repeat last search backwards")))
-(define-key menu-bar-search-menu [repeat-search-fwd]
- `(menu-item ,(purecopy "Repeat Forward") nonincremental-repeat-search-forward
- :enable (or (and (eq menu-bar-last-search-type 'string)
- search-ring)
- (and (eq menu-bar-last-search-type 'regexp)
- regexp-search-ring))
- :help ,(purecopy "Repeat last search forward")))
-(define-key menu-bar-search-menu [separator-repeat-search]
- menu-bar-separator)
-
-(define-key menu-bar-search-menu [re-search-backward]
- `(menu-item ,(purecopy "Regexp Backwards...") nonincremental-re-search-backward
- :help ,(purecopy "Search backwards for a regular expression")))
-(define-key menu-bar-search-menu [re-search-forward]
- `(menu-item ,(purecopy "Regexp Forward...") nonincremental-re-search-forward
- :help ,(purecopy "Search forward for a regular expression")))
-
-(define-key menu-bar-search-menu [search-backward]
- `(menu-item ,(purecopy "String Backwards...") nonincremental-search-backward
- :help ,(purecopy "Search backwards for a string")))
-(define-key menu-bar-search-menu [search-forward]
- `(menu-item ,(purecopy "String Forward...") nonincremental-search-forward
- :help ,(purecopy "Search forward for a string")))
+ (let ((menu (make-sparse-keymap "Incremental Search")))
+ (define-key menu [isearch-backward-regexp]
+ `(menu-item ,(purecopy "Backward Regexp...") isearch-backward-regexp
+ :help ,(purecopy
+ "Search backwards for a regular expression as you type it")))
+ (define-key menu [isearch-forward-regexp]
+ `(menu-item ,(purecopy "Forward Regexp...") isearch-forward-regexp
+ :help ,(purecopy
+ "Search forward for a regular expression as you type it")))
+ (define-key menu [isearch-backward]
+ `(menu-item ,(purecopy "Backward String...") isearch-backward
+ :help ,(purecopy "Search backwards for a string as you type it")))
+ (define-key menu [isearch-forward]
+ `(menu-item ,(purecopy "Forward String...") isearch-forward
+ :help ,(purecopy "Search forward for a string as you type it")))
+ menu))
+
+(defvar menu-bar-search-menu
+ (let ((menu (make-sparse-keymap "Search")))
+
+ (define-key menu [i-search]
+ `(menu-item ,(purecopy "Incremental Search") ,menu-bar-i-search-menu))
+ (define-key menu [separator-tag-isearch]
+ menu-bar-separator)
+
+ (define-key menu [tags-continue]
+ `(menu-item ,(purecopy "Continue Tags Search") tags-loop-continue
+ :help ,(purecopy "Continue last tags search operation")))
+ (define-key menu [tags-srch]
+ `(menu-item ,(purecopy "Search Tagged Files...") tags-search
+ :help ,(purecopy "Search for a regexp in all tagged files")))
+ (define-key menu [separator-tag-search] menu-bar-separator)
+
+ (define-key menu [repeat-search-back]
+ `(menu-item ,(purecopy "Repeat Backwards")
+ nonincremental-repeat-search-backward
+ :enable (or (and (eq menu-bar-last-search-type 'string)
+ search-ring)
+ (and (eq menu-bar-last-search-type 'regexp)
+ regexp-search-ring))
+ :help ,(purecopy "Repeat last search backwards")))
+ (define-key menu [repeat-search-fwd]
+ `(menu-item ,(purecopy "Repeat Forward")
+ nonincremental-repeat-search-forward
+ :enable (or (and (eq menu-bar-last-search-type 'string)
+ search-ring)
+ (and (eq menu-bar-last-search-type 'regexp)
+ regexp-search-ring))
+ :help ,(purecopy "Repeat last search forward")))
+ (define-key menu [separator-repeat-search]
+ menu-bar-separator)
+
+ (define-key menu [re-search-backward]
+ `(menu-item ,(purecopy "Regexp Backwards...")
+ nonincremental-re-search-backward
+ :help ,(purecopy
+ "Search backwards for a regular expression")))
+ (define-key menu [re-search-forward]
+ `(menu-item ,(purecopy "Regexp Forward...")
+ nonincremental-re-search-forward
+ :help ,(purecopy "Search forward for a regular expression")))
+
+ (define-key menu [search-backward]
+ `(menu-item ,(purecopy "String Backwards...")
+ nonincremental-search-backward
+ :help ,(purecopy "Search backwards for a string")))
+ (define-key menu [search-forward]
+ `(menu-item ,(purecopy "String Forward...") nonincremental-search-forward
+ :help ,(purecopy "Search forward for a string")))
+ menu))
;; The Edit->Replace submenu
-(defvar menu-bar-replace-menu (make-sparse-keymap "Replace"))
-
-(define-key menu-bar-replace-menu [tags-repl-continue]
- `(menu-item ,(purecopy "Continue Replace") tags-loop-continue
- :help ,(purecopy "Continue last tags replace operation")))
-(define-key menu-bar-replace-menu [tags-repl]
- `(menu-item ,(purecopy "Replace in Tagged Files...") tags-query-replace
- :help ,(purecopy "Interactively replace a regexp in all tagged files")))
-(define-key menu-bar-replace-menu [separator-replace-tags]
- menu-bar-separator)
-
-(define-key menu-bar-replace-menu [query-replace-regexp]
- `(menu-item ,(purecopy "Replace Regexp...") query-replace-regexp
- :enable (not buffer-read-only)
- :help ,(purecopy "Replace regular expression interactively, ask about each occurrence")))
-(define-key menu-bar-replace-menu [query-replace]
- `(menu-item ,(purecopy "Replace String...") query-replace
- :enable (not buffer-read-only)
- :help ,(purecopy "Replace string interactively, ask about each occurrence")))
+(defvar menu-bar-replace-menu
+ (let ((menu (make-sparse-keymap "Replace")))
+ (define-key menu [tags-repl-continue]
+ `(menu-item ,(purecopy "Continue Replace") tags-loop-continue
+ :help ,(purecopy "Continue last tags replace operation")))
+ (define-key menu [tags-repl]
+ `(menu-item ,(purecopy "Replace in Tagged Files...") tags-query-replace
+ :help ,(purecopy
+ "Interactively replace a regexp in all tagged files")))
+ (define-key menu [separator-replace-tags]
+ menu-bar-separator)
+
+ (define-key menu [query-replace-regexp]
+ `(menu-item ,(purecopy "Replace Regexp...") query-replace-regexp
+ :enable (not buffer-read-only)
+ :help ,(purecopy "Replace regular expression interactively, ask about each occurrence")))
+ (define-key menu [query-replace]
+ `(menu-item ,(purecopy "Replace String...") query-replace
+ :enable (not buffer-read-only)
+ :help ,(purecopy
+ "Replace string interactively, ask about each occurrence")))
+ menu))
;;; Assemble the top-level Edit menu items.
-(define-key menu-bar-edit-menu [props]
- `(menu-item ,(purecopy "Text Properties") facemenu-menu))
-
-(define-key menu-bar-edit-menu [fill]
- `(menu-item ,(purecopy "Fill") fill-region
- :enable (and mark-active (not buffer-read-only))
- :help
- ,(purecopy "Fill text in region to fit between left and right margin")))
-
-(define-key menu-bar-edit-menu [separator-bookmark]
- menu-bar-separator)
-
-(define-key menu-bar-edit-menu [bookmark]
- `(menu-item ,(purecopy "Bookmarks") menu-bar-bookmark-map))
+(defvar menu-bar-goto-menu
+ (let ((menu (make-sparse-keymap "Go To")))
+
+ (define-key menu [set-tags-name]
+ `(menu-item ,(purecopy "Set Tags File Name...") visit-tags-table
+ :help ,(purecopy "Tell Tags commands which tag table file to use")))
+
+ (define-key menu [separator-tag-file]
+ menu-bar-separator)
+
+ (define-key menu [apropos-tags]
+ `(menu-item ,(purecopy "Tags Apropos...") tags-apropos
+ :help ,(purecopy "Find function/variables whose names match regexp")))
+ (define-key menu [next-tag-otherw]
+ `(menu-item ,(purecopy "Next Tag in Other Window")
+ menu-bar-next-tag-other-window
+ :enable (and (boundp 'tags-location-ring)
+ (not (ring-empty-p tags-location-ring)))
+ :help ,(purecopy "Find next function/variable matching last tag name in another window")))
+
+ (define-key menu [next-tag]
+ `(menu-item ,(purecopy "Find Next Tag")
+ menu-bar-next-tag
+ :enable (and (boundp 'tags-location-ring)
+ (not (ring-empty-p tags-location-ring)))
+ :help ,(purecopy "Find next function/variable matching last tag name")))
+ (define-key menu [find-tag-otherw]
+ `(menu-item ,(purecopy "Find Tag in Other Window...") find-tag-other-window
+ :help ,(purecopy "Find function/variable definition in another window")))
+ (define-key menu [find-tag]
+ `(menu-item ,(purecopy "Find Tag...") find-tag
+ :help ,(purecopy "Find definition of function or variable")))
+
+ (define-key menu [separator-tags]
+ menu-bar-separator)
+
+ (define-key menu [end-of-buf]
+ `(menu-item ,(purecopy "Goto End of Buffer") end-of-buffer))
+ (define-key menu [beg-of-buf]
+ `(menu-item ,(purecopy "Goto Beginning of Buffer") beginning-of-buffer))
+ (define-key menu [go-to-pos]
+ `(menu-item ,(purecopy "Goto Buffer Position...") goto-char
+ :help ,(purecopy "Read a number N and go to buffer position N")))
+ (define-key menu [go-to-line]
+ `(menu-item ,(purecopy "Goto Line...") goto-line
+ :help ,(purecopy "Read a line number and go to that line")))
+ menu))
-(defvar menu-bar-goto-menu (make-sparse-keymap "Go To"))
-(define-key menu-bar-goto-menu [set-tags-name]
- `(menu-item ,(purecopy "Set Tags File Name...") visit-tags-table
- :help ,(purecopy "Tell Tags commands which tag table file to use")))
-
-(define-key menu-bar-goto-menu [separator-tag-file]
- menu-bar-separator)
+(defvar yank-menu (cons (purecopy "Select Yank") nil))
+(fset 'yank-menu (cons 'keymap yank-menu))
-(define-key menu-bar-goto-menu [apropos-tags]
- `(menu-item ,(purecopy "Tags Apropos...") tags-apropos
- :help ,(purecopy "Find function/variables whose names match regexp")))
-(define-key menu-bar-goto-menu [next-tag-otherw]
- `(menu-item ,(purecopy "Next Tag in Other Window")
- menu-bar-next-tag-other-window
- :enable (and (boundp 'tags-location-ring)
- (not (ring-empty-p tags-location-ring)))
- :help ,(purecopy "Find next function/variable matching last tag name in another window")))
+(defvar menu-bar-edit-menu
+ (let ((menu (make-sparse-keymap "Edit")))
+
+ (define-key menu [props]
+ `(menu-item ,(purecopy "Text Properties") facemenu-menu))
+
+ ;; ns-win.el said: Add spell for platorm consistency.
+ (if (featurep 'ns)
+ (define-key menu [spell]
+ `(menu-item ,(purecopy "Spell") ispell-menu-map)))
+
+ (define-key menu [fill]
+ `(menu-item ,(purecopy "Fill") fill-region
+ :enable (and mark-active (not buffer-read-only))
+ :help
+ ,(purecopy "Fill text in region to fit between left and right margin")))
+
+ (define-key menu [separator-bookmark]
+ menu-bar-separator)
+
+ (define-key menu [bookmark]
+ `(menu-item ,(purecopy "Bookmarks") menu-bar-bookmark-map))
+
+ (define-key menu [goto]
+ `(menu-item ,(purecopy "Go To") ,menu-bar-goto-menu))
+
+ (define-key menu [replace]
+ `(menu-item ,(purecopy "Replace") ,menu-bar-replace-menu))
+
+ (define-key menu [search]
+ `(menu-item ,(purecopy "Search") ,menu-bar-search-menu))
+
+ (define-key menu [separator-search]
+ menu-bar-separator)
+
+ (define-key menu [mark-whole-buffer]
+ `(menu-item ,(purecopy "Select All") mark-whole-buffer
+ :help ,(purecopy "Mark the whole buffer for a subsequent cut/copy")))
+ (define-key menu [clear]
+ `(menu-item ,(purecopy "Clear") delete-region
+ :enable (and mark-active
+ (not buffer-read-only))
+ :help
+ ,(purecopy "Delete the text in region between mark and current position")))
+
+
+ (define-key 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 [paste]
+ `(menu-item ,(purecopy "Paste") yank
+ :enable (and (or
+ ;; Emacs compiled --without-x (or --with-ns)
+ ;; doesn't have x-selection-exists-p.
+ (and (fboundp 'x-selection-exists-p)
+ (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 [copy]
+ ;; 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
+ '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 [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 [separator-undo] menu-bar-separator))
+
+ (define-key menu [undo]
+ `(menu-item ,(purecopy "Undo") undo
+ :enable (and (not buffer-read-only)
+ (not (eq t buffer-undo-list))
+ (if (eq last-command 'undo)
+ (listp pending-undo-list)
+ (consp buffer-undo-list)))
+ :help ,(purecopy "Undo last operation")))
+
+ menu))
(defun menu-bar-next-tag-other-window ()
"Find the next definition of the tag already specified."
@@ -401,96 +538,8 @@
(interactive)
(find-tag nil t))
-(define-key menu-bar-goto-menu [next-tag]
- `(menu-item ,(purecopy "Find Next Tag")
- menu-bar-next-tag
- :enable (and (boundp 'tags-location-ring)
- (not (ring-empty-p tags-location-ring)))
- :help ,(purecopy "Find next function/variable matching last tag name")))
-(define-key menu-bar-goto-menu [find-tag-otherw]
- `(menu-item ,(purecopy "Find Tag in Other Window...") find-tag-other-window
- :help ,(purecopy "Find function/variable definition in another window")))
-(define-key menu-bar-goto-menu [find-tag]
- `(menu-item ,(purecopy "Find Tag...") find-tag
- :help ,(purecopy "Find definition of function or variable")))
-
-(define-key menu-bar-goto-menu [separator-tags]
- menu-bar-separator)
-
-(define-key menu-bar-goto-menu [end-of-buf]
- `(menu-item ,(purecopy "Goto End of Buffer") end-of-buffer))
-(define-key menu-bar-goto-menu [beg-of-buf]
- `(menu-item ,(purecopy "Goto Beginning of Buffer") beginning-of-buffer))
-(define-key menu-bar-goto-menu [go-to-pos]
- `(menu-item ,(purecopy "Goto Buffer Position...") goto-char
- :help ,(purecopy "Read a number N and go to buffer position N")))
-(define-key menu-bar-goto-menu [go-to-line]
- `(menu-item ,(purecopy "Goto Line...") goto-line
- :help ,(purecopy "Read a line number and go to that line")))
-
-(define-key menu-bar-edit-menu [goto]
- `(menu-item ,(purecopy "Go To") ,menu-bar-goto-menu))
-
-(define-key menu-bar-edit-menu [replace]
- `(menu-item ,(purecopy "Replace") ,menu-bar-replace-menu))
-
-(define-key menu-bar-edit-menu [search]
- `(menu-item ,(purecopy "Search") ,menu-bar-search-menu))
-
-(define-key menu-bar-edit-menu [separator-search]
- menu-bar-separator)
-
-(define-key menu-bar-edit-menu [mark-whole-buffer]
- `(menu-item ,(purecopy "Select All") mark-whole-buffer
- :help ,(purecopy "Mark the whole buffer for a subsequent cut/copy")))
-(define-key menu-bar-edit-menu [clear]
- `(menu-item ,(purecopy "Clear") delete-region
- :enable (and mark-active
- (not buffer-read-only)
- (not (mouse-region-match)))
- :help
- ,(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
- :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.
- (and (fboundp 'x-selection-exists-p)
- (x-selection-exists-p))
- 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]")))
-(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")))
-(define-key menu-bar-edit-menu [undo]
- `(menu-item ,(purecopy "Undo") undo
- :enable (and (not buffer-read-only)
- (not (eq t buffer-undo-list))
- (if (eq last-command 'undo)
- (listp pending-undo-list)
- (consp buffer-undo-list)))
- :help ,(purecopy "Undo last operation")))
-
-
-(defun menu-bar-kill-ring-save (beg end)
- (interactive "r")
- (if (mouse-region-match)
- (message "Selecting a region with the mouse does `copy' automatically")
- (kill-ring-save beg end)))
+(define-obsolete-function-alias
+ 'menu-bar-kill-ring-save 'kill-ring-save "24.1")
;; These are alternative definitions for the cut, paste and copy
;; menu items. Use them if your system expects these to use the clipboard.
@@ -526,17 +575,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)
@@ -549,48 +587,49 @@ Do the same for the keys of the same name."
;; The "Options" menu items
-(defvar menu-bar-custom-menu (make-sparse-keymap "Customize"))
-
-(define-key menu-bar-custom-menu [customize-apropos-groups]
- `(menu-item ,(purecopy "Groups Matching Regexp...") customize-apropos-groups
- :help ,(purecopy "Browse groups whose names match regexp")))
-(define-key menu-bar-custom-menu [customize-apropos-faces]
- `(menu-item ,(purecopy "Faces Matching Regexp...") customize-apropos-faces
- :help ,(purecopy "Browse faces whose names match regexp")))
-(define-key menu-bar-custom-menu [customize-apropos-options]
- `(menu-item ,(purecopy "Options Matching Regexp...") customize-apropos-options
- :help ,(purecopy "Browse options whose names match regexp")))
-(define-key menu-bar-custom-menu [customize-apropos]
- `(menu-item ,(purecopy "Settings Matching Regexp...") customize-apropos
- :help ,(purecopy "Browse customizable settings whose names match regexp")))
-(define-key menu-bar-custom-menu [separator-1]
- menu-bar-separator)
-(define-key menu-bar-custom-menu [customize-group]
- `(menu-item ,(purecopy "Specific Group...") customize-group
- :help ,(purecopy "Customize settings of specific group")))
-(define-key menu-bar-custom-menu [customize-face]
- `(menu-item ,(purecopy "Specific Face...") customize-face
- :help ,(purecopy "Customize attributes of specific face")))
-(define-key menu-bar-custom-menu [customize-option]
- `(menu-item ,(purecopy "Specific Option...") customize-option
- :help ,(purecopy "Customize value of specific option")))
-(define-key menu-bar-custom-menu [separator-2]
- menu-bar-separator)
-(define-key menu-bar-custom-menu [customize-changed-options]
- `(menu-item ,(purecopy "New Options...") customize-changed-options
- :help ,(purecopy "Options added or changed in recent Emacs versions")))
-(define-key menu-bar-custom-menu [customize-saved]
- `(menu-item ,(purecopy "Saved Options") customize-saved
- :help ,(purecopy "Customize previously saved options")))
-(define-key menu-bar-custom-menu [separator-3]
- menu-bar-separator)
-(define-key menu-bar-custom-menu [customize-browse]
- `(menu-item ,(purecopy "Browse Customization Groups") customize-browse
- :help ,(purecopy "Browse all customization groups")))
-(define-key menu-bar-custom-menu [customize]
- `(menu-item ,(purecopy "Top-level Customization Group") customize
- :help ,(purecopy "The master group called `Emacs'")))
-
+(defvar menu-bar-custom-menu
+ (let ((menu (make-sparse-keymap "Customize")))
+
+ (define-key menu [customize-apropos-faces]
+ `(menu-item ,(purecopy "Faces Matching...") customize-apropos-faces
+ :help ,(purecopy "Browse faces matching a regexp or word list")))
+ (define-key menu [customize-apropos-options]
+ `(menu-item ,(purecopy "Options Matching...") customize-apropos-options
+ :help ,(purecopy "Browse options matching a regexp or word list")))
+ (define-key menu [customize-apropos]
+ `(menu-item ,(purecopy "All Settings Matching...") customize-apropos
+ :help ,(purecopy "Browse customizable settings matching a regexp or word list")))
+ (define-key menu [separator-1]
+ menu-bar-separator)
+ (define-key menu [customize-group]
+ `(menu-item ,(purecopy "Specific Group...") customize-group
+ :help ,(purecopy "Customize settings of specific group")))
+ (define-key menu [customize-face]
+ `(menu-item ,(purecopy "Specific Face...") customize-face
+ :help ,(purecopy "Customize attributes of specific face")))
+ (define-key menu [customize-option]
+ `(menu-item ,(purecopy "Specific Option...") customize-option
+ :help ,(purecopy "Customize value of specific option")))
+ (define-key menu [separator-2]
+ menu-bar-separator)
+ (define-key menu [customize-changed-options]
+ `(menu-item ,(purecopy "New Options...") customize-changed-options
+ :help ,(purecopy "Options added or changed in recent Emacs versions")))
+ (define-key menu [customize-saved]
+ `(menu-item ,(purecopy "Saved Options") customize-saved
+ :help ,(purecopy "Customize previously saved options")))
+ (define-key menu [separator-3]
+ menu-bar-separator)
+ (define-key menu [customize-browse]
+ `(menu-item ,(purecopy "Browse Customization Groups") customize-browse
+ :help ,(purecopy "Browse all customization groups")))
+ (define-key menu [customize]
+ `(menu-item ,(purecopy "Top-level Customization Group") customize
+ :help ,(purecopy "The master group called `Emacs'")))
+ (define-key menu [customize-themes]
+ `(menu-item ,(purecopy "Custom Themes") customize-themes
+ :help ,(purecopy "Choose a pre-defined customization theme")))
+ menu))
;(defvar menu-bar-preferences-menu (make-sparse-keymap "Preferences"))
(defmacro menu-bar-make-mm-toggle (fname doc help &optional props)
@@ -660,12 +699,6 @@ by \"Save Options\" in Custom buffers.")
(custom-push-theme 'theme-face 'default 'user 'set spec)
(put 'default 'face-modified nil))))
-
-
-;;; Assemble all the top-level items of the "Options" menu
-(define-key menu-bar-options-menu [customize]
- `(menu-item ,(purecopy "Customize Emacs") ,menu-bar-custom-menu))
-
(defun menu-bar-options-save ()
"Save current values of Options menu items using Custom."
(interactive)
@@ -701,7 +734,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,272 +746,204 @@ by \"Save Options\" in Custom buffers.")
(when need-save
(custom-save-all))))
-(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")))
-
-(define-key menu-bar-options-menu [custom-separator]
- menu-bar-separator)
-
-(define-key menu-bar-options-menu [menu-set-font]
- `(menu-item ,(purecopy "Set Default Font...") menu-set-font
- :visible (display-multi-font-p)
- :help ,(purecopy "Select a default font")))
-
-(if (featurep 'system-font-setting)
- (define-key menu-bar-options-menu [menu-system-font]
- (menu-bar-make-toggle toggle-use-system-font font-use-system-font
- "Use system font"
- "Use system font: %s"
- "Use the monospaced font defined by the system")))
+;;; Assemble all the top-level items of the "Options" menu
;; The "Show/Hide" submenu of menu "Options"
-(defvar menu-bar-showhide-menu (make-sparse-keymap "Show/Hide"))
-
-(define-key menu-bar-showhide-menu [column-number-mode]
- (menu-bar-make-mm-toggle column-number-mode
- "Column Numbers"
- "Show the current column number in the mode line"))
-
-(define-key menu-bar-showhide-menu [line-number-mode]
- (menu-bar-make-mm-toggle line-number-mode
- "Line Numbers"
- "Show the current line number in the mode line"))
-
-(define-key menu-bar-showhide-menu [size-indication-mode]
- (menu-bar-make-mm-toggle size-indication-mode
- "Size Indication"
- "Show the size of the buffer in the mode line"))
-
-(define-key menu-bar-showhide-menu [linecolumn-separator]
- menu-bar-separator)
-
-(define-key menu-bar-showhide-menu [showhide-battery]
- (menu-bar-make-mm-toggle display-battery-mode
- "Battery Status"
- "Display battery status information in mode line"))
-
-(define-key menu-bar-showhide-menu [showhide-date-time]
- (menu-bar-make-mm-toggle display-time-mode
- "Time, Load and Mail"
- "Display time, system load averages and \
-mail status in mode line"))
-
-(define-key menu-bar-showhide-menu [datetime-separator]
- menu-bar-separator)
-
-(define-key menu-bar-showhide-menu [showhide-speedbar]
- `(menu-item ,(purecopy "Speedbar") speedbar-frame-mode
- :help ,(purecopy "Display a Speedbar quick-navigation frame")
- :button (:toggle
- . (and (boundp 'speedbar-frame)
- (frame-live-p (symbol-value 'speedbar-frame))
- (frame-visible-p
- (symbol-value 'speedbar-frame))))))
-
-(defvar menu-bar-showhide-fringe-menu (make-sparse-keymap "Fringe"))
-
-(defvar menu-bar-showhide-fringe-ind-menu
- (make-sparse-keymap "Buffer boundaries"))
-
(defun menu-bar-showhide-fringe-ind-customize ()
"Show customization buffer for `indicate-buffer-boundaries'."
(interactive)
(customize-variable 'indicate-buffer-boundaries))
-(define-key menu-bar-showhide-fringe-ind-menu [customize]
- `(menu-item ,(purecopy "Other (Customize)")
- menu-bar-showhide-fringe-ind-customize
- :help ,(purecopy "Additional choices available through Custom buffer")
- :visible (display-graphic-p)
- :button (:radio . (not (member indicate-buffer-boundaries
- '(nil left right
- ((top . left) (bottom . right))
- ((t . right) (top . left))))))))
-
(defun menu-bar-showhide-fringe-ind-mixed ()
"Display top and bottom indicators in opposite fringes, arrows in right."
(interactive)
(customize-set-variable 'indicate-buffer-boundaries
'((t . right) (top . left))))
-(define-key menu-bar-showhide-fringe-ind-menu [mixed]
- `(menu-item ,(purecopy "Opposite, Arrows Right") menu-bar-showhide-fringe-ind-mixed
- :help
- ,(purecopy "Show top/bottom indicators in opposite fringes, arrows in right")
- :visible (display-graphic-p)
- :button (:radio . (equal indicate-buffer-boundaries
- '((t . right) (top . left))))))
-
(defun menu-bar-showhide-fringe-ind-box ()
"Display top and bottom indicators in opposite fringes."
(interactive)
(customize-set-variable 'indicate-buffer-boundaries
'((top . left) (bottom . right))))
-(define-key menu-bar-showhide-fringe-ind-menu [box]
- `(menu-item ,(purecopy "Opposite, No Arrows") menu-bar-showhide-fringe-ind-box
- :help ,(purecopy "Show top/bottom indicators in opposite fringes, no arrows")
- :visible (display-graphic-p)
- :button (:radio . (equal indicate-buffer-boundaries
- '((top . left) (bottom . right))))))
-
(defun menu-bar-showhide-fringe-ind-right ()
"Display buffer boundaries and arrows in the right fringe."
(interactive)
(customize-set-variable 'indicate-buffer-boundaries 'right))
-(define-key menu-bar-showhide-fringe-ind-menu [right]
- `(menu-item ,(purecopy "In Right Fringe") menu-bar-showhide-fringe-ind-right
- :help ,(purecopy "Show buffer boundaries and arrows in right fringe")
- :visible (display-graphic-p)
- :button (:radio . (eq indicate-buffer-boundaries 'right))))
-
(defun menu-bar-showhide-fringe-ind-left ()
"Display buffer boundaries and arrows in the left fringe."
(interactive)
(customize-set-variable 'indicate-buffer-boundaries 'left))
-(define-key menu-bar-showhide-fringe-ind-menu [left]
- `(menu-item ,(purecopy "In Left Fringe") menu-bar-showhide-fringe-ind-left
- :help ,(purecopy "Show buffer boundaries and arrows in left fringe")
- :visible (display-graphic-p)
- :button (:radio . (eq indicate-buffer-boundaries 'left))))
-
(defun menu-bar-showhide-fringe-ind-none ()
"Do not display any buffer boundary indicators."
(interactive)
(customize-set-variable 'indicate-buffer-boundaries nil))
-(define-key menu-bar-showhide-fringe-ind-menu [none]
- `(menu-item ,(purecopy "No Indicators") menu-bar-showhide-fringe-ind-none
- :help ,(purecopy "Hide all buffer boundary indicators and arrows")
- :visible (display-graphic-p)
- :button (:radio . (eq indicate-buffer-boundaries nil))))
-
-(define-key menu-bar-showhide-fringe-menu [showhide-fringe-ind]
- `(menu-item ,(purecopy "Buffer Boundaries") ,menu-bar-showhide-fringe-ind-menu
- :visible (display-graphic-p)
- :help ,(purecopy "Indicate buffer boundaries in fringe")))
-
-(define-key menu-bar-showhide-fringe-menu [indicate-empty-lines]
- (menu-bar-make-toggle toggle-indicate-empty-lines indicate-empty-lines
- "Empty Line Indicators"
- "Indicating of empty lines %s"
- "Indicate trailing empty lines in fringe, globally"))
+(defvar menu-bar-showhide-fringe-ind-menu
+ (let ((menu (make-sparse-keymap "Buffer boundaries")))
+
+ (define-key menu [customize]
+ `(menu-item ,(purecopy "Other (Customize)")
+ menu-bar-showhide-fringe-ind-customize
+ :help ,(purecopy "Additional choices available through Custom buffer")
+ :visible (display-graphic-p)
+ :button (:radio . (not (member indicate-buffer-boundaries
+ '(nil left right
+ ((top . left) (bottom . right))
+ ((t . right) (top . left))))))))
+
+ (define-key menu [mixed]
+ `(menu-item ,(purecopy "Opposite, Arrows Right") menu-bar-showhide-fringe-ind-mixed
+ :help
+ ,(purecopy "Show top/bottom indicators in opposite fringes, arrows in right")
+ :visible (display-graphic-p)
+ :button (:radio . (equal indicate-buffer-boundaries
+ '((t . right) (top . left))))))
+
+ (define-key menu [box]
+ `(menu-item ,(purecopy "Opposite, No Arrows") menu-bar-showhide-fringe-ind-box
+ :help ,(purecopy "Show top/bottom indicators in opposite fringes, no arrows")
+ :visible (display-graphic-p)
+ :button (:radio . (equal indicate-buffer-boundaries
+ '((top . left) (bottom . right))))))
+
+ (define-key menu [right]
+ `(menu-item ,(purecopy "In Right Fringe") menu-bar-showhide-fringe-ind-right
+ :help ,(purecopy "Show buffer boundaries and arrows in right fringe")
+ :visible (display-graphic-p)
+ :button (:radio . (eq indicate-buffer-boundaries 'right))))
+
+ (define-key menu [left]
+ `(menu-item ,(purecopy "In Left Fringe") menu-bar-showhide-fringe-ind-left
+ :help ,(purecopy "Show buffer boundaries and arrows in left fringe")
+ :visible (display-graphic-p)
+ :button (:radio . (eq indicate-buffer-boundaries 'left))))
+
+ (define-key menu [none]
+ `(menu-item ,(purecopy "No Indicators") menu-bar-showhide-fringe-ind-none
+ :help ,(purecopy "Hide all buffer boundary indicators and arrows")
+ :visible (display-graphic-p)
+ :button (:radio . (eq indicate-buffer-boundaries nil))))
+ menu))
(defun menu-bar-showhide-fringe-menu-customize ()
"Show customization buffer for `fringe-mode'."
(interactive)
(customize-variable 'fringe-mode))
-(define-key menu-bar-showhide-fringe-menu [customize]
- `(menu-item ,(purecopy "Customize Fringe") menu-bar-showhide-fringe-menu-customize
- :help ,(purecopy "Detailed customization of fringe")
- :visible (display-graphic-p)))
-
(defun menu-bar-showhide-fringe-menu-customize-reset ()
"Reset the fringe mode: display fringes on both sides of a window."
(interactive)
(customize-set-variable 'fringe-mode nil))
-(define-key menu-bar-showhide-fringe-menu [default]
- `(menu-item ,(purecopy "Default") menu-bar-showhide-fringe-menu-customize-reset
- :help ,(purecopy "Default width fringe on both left and right side")
- :visible (display-graphic-p)
- :button (:radio . (eq fringe-mode nil))))
-
(defun menu-bar-showhide-fringe-menu-customize-right ()
"Display fringes only on the right of each window."
(interactive)
(require 'fringe)
(customize-set-variable 'fringe-mode '(0 . nil)))
-(define-key menu-bar-showhide-fringe-menu [right]
- `(menu-item ,(purecopy "On the Right") menu-bar-showhide-fringe-menu-customize-right
- :help ,(purecopy "Fringe only on the right side")
- :visible (display-graphic-p)
- :button (:radio . (equal fringe-mode '(0 . nil)))))
-
(defun menu-bar-showhide-fringe-menu-customize-left ()
"Display fringes only on the left of each window."
(interactive)
(require 'fringe)
(customize-set-variable 'fringe-mode '(nil . 0)))
-(define-key menu-bar-showhide-fringe-menu [left]
- `(menu-item ,(purecopy "On the Left") menu-bar-showhide-fringe-menu-customize-left
- :help ,(purecopy "Fringe only on the left side")
- :visible (display-graphic-p)
- :button (:radio . (equal fringe-mode '(nil . 0)))))
-
(defun menu-bar-showhide-fringe-menu-customize-disable ()
"Do not display window fringes."
(interactive)
(require 'fringe)
(customize-set-variable 'fringe-mode 0))
-(define-key menu-bar-showhide-fringe-menu [none]
- `(menu-item ,(purecopy "None") menu-bar-showhide-fringe-menu-customize-disable
- :help ,(purecopy "Turn off fringe")
- :visible (display-graphic-p)
- :button (:radio . (eq fringe-mode 0))))
-
-(define-key menu-bar-showhide-menu [showhide-fringe]
- `(menu-item ,(purecopy "Fringe") ,menu-bar-showhide-fringe-menu
- :visible (display-graphic-p)))
-
-(defvar menu-bar-showhide-scroll-bar-menu (make-sparse-keymap "Scroll-bar"))
-
-(define-key menu-bar-showhide-scroll-bar-menu [right]
- `(menu-item ,(purecopy "On the Right")
- menu-bar-right-scroll-bar
- :help ,(purecopy "Scroll-bar on the right side")
- :visible (display-graphic-p)
- :button (:radio . (eq (cdr (assq 'vertical-scroll-bars
- (frame-parameters))) 'right))))
+(defvar menu-bar-showhide-fringe-menu
+ (let ((menu (make-sparse-keymap "Fringe")))
+
+ (define-key menu [showhide-fringe-ind]
+ `(menu-item ,(purecopy "Buffer Boundaries") ,menu-bar-showhide-fringe-ind-menu
+ :visible (display-graphic-p)
+ :help ,(purecopy "Indicate buffer boundaries in fringe")))
+
+ (define-key menu [indicate-empty-lines]
+ (menu-bar-make-toggle toggle-indicate-empty-lines indicate-empty-lines
+ "Empty Line Indicators"
+ "Indicating of empty lines %s"
+ "Indicate trailing empty lines in fringe, globally"))
+
+ (define-key menu [customize]
+ `(menu-item ,(purecopy "Customize Fringe") menu-bar-showhide-fringe-menu-customize
+ :help ,(purecopy "Detailed customization of fringe")
+ :visible (display-graphic-p)))
+
+ (define-key menu [default]
+ `(menu-item ,(purecopy "Default") menu-bar-showhide-fringe-menu-customize-reset
+ :help ,(purecopy "Default width fringe on both left and right side")
+ :visible (display-graphic-p)
+ :button (:radio . (eq fringe-mode nil))))
+
+ (define-key menu [right]
+ `(menu-item ,(purecopy "On the Right") menu-bar-showhide-fringe-menu-customize-right
+ :help ,(purecopy "Fringe only on the right side")
+ :visible (display-graphic-p)
+ :button (:radio . (equal fringe-mode '(0 . nil)))))
+
+ (define-key menu [left]
+ `(menu-item ,(purecopy "On the Left") menu-bar-showhide-fringe-menu-customize-left
+ :help ,(purecopy "Fringe only on the left side")
+ :visible (display-graphic-p)
+ :button (:radio . (equal fringe-mode '(nil . 0)))))
+
+ (define-key menu [none]
+ `(menu-item ,(purecopy "None") menu-bar-showhide-fringe-menu-customize-disable
+ :help ,(purecopy "Turn off fringe")
+ :visible (display-graphic-p)
+ :button (:radio . (eq fringe-mode 0))))
+ menu))
+
(defun menu-bar-right-scroll-bar ()
"Display scroll bars on the right of each window."
(interactive)
(customize-set-variable 'scroll-bar-mode 'right))
-(define-key menu-bar-showhide-scroll-bar-menu [left]
- `(menu-item ,(purecopy "On the Left")
- menu-bar-left-scroll-bar
- :help ,(purecopy "Scroll-bar on the left side")
- :visible (display-graphic-p)
- :button (:radio . (eq (cdr (assq 'vertical-scroll-bars
- (frame-parameters))) 'left))))
-
(defun menu-bar-left-scroll-bar ()
"Display scroll bars on the left of each window."
(interactive)
(customize-set-variable 'scroll-bar-mode 'left))
-(define-key menu-bar-showhide-scroll-bar-menu [none]
- `(menu-item ,(purecopy "None")
- menu-bar-no-scroll-bar
- :help ,(purecopy "Turn off scroll-bar")
- :visible (display-graphic-p)
- :button (:radio . (eq (cdr (assq 'vertical-scroll-bars
- (frame-parameters))) nil))))
-
(defun menu-bar-no-scroll-bar ()
"Turn off scroll bars."
(interactive)
(customize-set-variable 'scroll-bar-mode nil))
-(define-key menu-bar-showhide-menu [showhide-scroll-bar]
- `(menu-item ,(purecopy "Scroll-bar") ,menu-bar-showhide-scroll-bar-menu
- :visible (display-graphic-p)))
-
-(define-key menu-bar-showhide-menu [showhide-tooltip-mode]
- `(menu-item ,(purecopy "Tooltips") tooltip-mode
- :help ,(purecopy "Turn tooltips on/off")
- :visible (and (display-graphic-p) (fboundp 'x-show-tip))
- :button (:toggle . tooltip-mode)))
+(defvar menu-bar-showhide-scroll-bar-menu
+ (let ((menu (make-sparse-keymap "Scroll-bar")))
+
+ (define-key menu [right]
+ `(menu-item ,(purecopy "On the Right")
+ menu-bar-right-scroll-bar
+ :help ,(purecopy "Scroll-bar on the right side")
+ :visible (display-graphic-p)
+ :button (:radio . (eq (cdr (assq 'vertical-scroll-bars
+ (frame-parameters))) 'right))))
+
+ (define-key menu [left]
+ `(menu-item ,(purecopy "On the Left")
+ menu-bar-left-scroll-bar
+ :help ,(purecopy "Scroll-bar on the left side")
+ :visible (display-graphic-p)
+ :button (:radio . (eq (cdr (assq 'vertical-scroll-bars
+ (frame-parameters))) 'left))))
+
+ (define-key menu [none]
+ `(menu-item ,(purecopy "None")
+ menu-bar-no-scroll-bar
+ :help ,(purecopy "Turn off scroll-bar")
+ :visible (display-graphic-p)
+ :button (:radio . (eq (cdr (assq 'vertical-scroll-bars
+ (frame-parameters))) nil))))
+ menu))
(defun menu-bar-frame-for-menubar ()
"Return the frame suitable for updating the menu bar."
@@ -991,106 +956,171 @@ mail status in mode line"))
(and (numberp val)
(> val 0)))
-(define-key menu-bar-showhide-menu [menu-bar-mode]
- `(menu-item ,(purecopy "Menu-bar") toggle-menu-bar-mode-from-frame
- :help ,(purecopy "Turn menu-bar on/off")
- :button
- (:toggle . (menu-bar-positive-p
- (frame-parameter (menu-bar-frame-for-menubar)
- 'menu-bar-lines)))))
-
-(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 . (menu-bar-positive-p
- (frame-parameter (menu-bar-frame-for-menubar)
- 'tool-bar-lines)))))
-
-(define-key menu-bar-options-menu [showhide]
- `(menu-item ,(purecopy "Show/Hide") ,menu-bar-showhide-menu))
-
-(define-key menu-bar-options-menu [showhide-separator]
- menu-bar-separator)
-
-(define-key menu-bar-options-menu [mule]
- ;; It is better not to use backquote here,
- ;; because that makes a bootstrapping problem
- ;; if you need to recompile all the Lisp files using interpreted code.
- `(menu-item ,(purecopy "Mule (Multilingual Environment)") ,mule-menu-keymap
-;; Most of the MULE menu actually does make sense in unibyte mode,
-;; e.g. language selection.
-;;; :visible '(default-value 'enable-multibyte-characters)
- ))
-;(setq menu-bar-final-items (cons 'mule menu-bar-final-items))
-;(define-key menu-bar-options-menu [preferences]
-; `(menu-item ,(purecopy "Preferences") ,menu-bar-preferences-menu
-; :help ,(purecopy "Toggle important global options")))
-
-(define-key menu-bar-options-menu [mule-separator]
- menu-bar-separator)
-
-(define-key menu-bar-options-menu [debug-on-quit]
- (menu-bar-make-toggle toggle-debug-on-quit debug-on-quit
- "Enter Debugger on Quit/C-g" "Debug on Quit %s"
- "Enter Lisp debugger when C-g is pressed"))
-(define-key menu-bar-options-menu [debug-on-error]
- (menu-bar-make-toggle toggle-debug-on-error debug-on-error
- "Enter Debugger on Error" "Debug on Error %s"
- "Enter Lisp debugger when an error is signaled"))
-(define-key menu-bar-options-menu [debugger-separator]
- menu-bar-separator)
-
-(define-key menu-bar-options-menu [blink-cursor-mode]
- (menu-bar-make-mm-toggle blink-cursor-mode
- "Blinking Cursor"
- "Whether the cursor blinks (Blink Cursor mode)"))
-(define-key menu-bar-options-menu [cursor-separator]
- menu-bar-separator)
-
-(define-key menu-bar-options-menu [save-place]
- (menu-bar-make-toggle toggle-save-place-globally save-place
- "Save Place in Files between Sessions"
- "Saving place in files %s"
- "Visit files of previous session when restarting Emacs"
- (require 'saveplace)
- ;; Do it by name, to avoid a free-variable
- ;; warning during byte compilation.
- (set-default
- 'save-place (not (symbol-value 'save-place)))))
-
-(define-key menu-bar-options-menu [uniquify]
- (menu-bar-make-toggle toggle-uniquify-buffer-names uniquify-buffer-name-style
- "Use Directory Names in Buffer Names"
- "Directory name in buffer names (uniquify) %s"
- "Uniquify buffer names by adding parent directory names"
- (require 'uniquify)
- (setq uniquify-buffer-name-style
- (if (not uniquify-buffer-name-style)
- 'forward))))
-
-(define-key menu-bar-options-menu [edit-options-separator]
- menu-bar-separator)
-(define-key menu-bar-options-menu [cua-mode]
- (menu-bar-make-mm-toggle cua-mode
- "C-x/C-c/C-v Cut and Paste (CUA)"
- "Use C-z/C-x/C-c/C-v keys for undo/cut/copy/paste"
- (:visible (or (not (boundp 'cua-enable-cua-keys))
- cua-enable-cua-keys))))
-
-(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."
- (:visible (and (boundp 'cua-enable-cua-keys)
- (not cua-enable-cua-keys)))))
-
-(define-key menu-bar-options-menu [case-fold-search]
- (menu-bar-make-toggle toggle-case-fold-search case-fold-search
- "Case-Insensitive Search"
- "Case-Insensitive Search %s"
- "Ignore letter-case in search commands"))
+(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))
+
+(when (featurep 'move-toolbar)
+ (defvar menu-bar-showhide-tool-bar-menu
+ (let ((menu (make-sparse-keymap "Tool-bar")))
+
+ (define-key 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
+ (menu-bar-frame-for-menubar)
+ 'tool-bar-position)
+ 'left)))))
+
+ (define-key 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
+ (menu-bar-frame-for-menubar)
+ 'tool-bar-position)
+ 'right)))))
+
+ (define-key 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
+ (menu-bar-frame-for-menubar)
+ 'tool-bar-position)
+ 'bottom)))))
+
+ (define-key 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
+ (menu-bar-frame-for-menubar)
+ 'tool-bar-position)
+ 'top)))))
+
+ (define-key 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))))
+ menu)))
+
+(defvar menu-bar-showhide-menu
+ (let ((menu (make-sparse-keymap "Show/Hide")))
+
+ (define-key menu [column-number-mode]
+ (menu-bar-make-mm-toggle column-number-mode
+ "Column Numbers"
+ "Show the current column number in the mode line"))
+
+ (define-key menu [line-number-mode]
+ (menu-bar-make-mm-toggle line-number-mode
+ "Line Numbers"
+ "Show the current line number in the mode line"))
+
+ (define-key menu [size-indication-mode]
+ (menu-bar-make-mm-toggle size-indication-mode
+ "Size Indication"
+ "Show the size of the buffer in the mode line"))
+
+ (define-key menu [linecolumn-separator]
+ menu-bar-separator)
+
+ (define-key menu [showhide-battery]
+ (menu-bar-make-mm-toggle display-battery-mode
+ "Battery Status"
+ "Display battery status information in mode line"))
+
+ (define-key menu [showhide-date-time]
+ (menu-bar-make-mm-toggle display-time-mode
+ "Time, Load and Mail"
+ "Display time, system load averages and \
+mail status in mode line"))
+
+ (define-key menu [datetime-separator]
+ menu-bar-separator)
+
+ (define-key menu [showhide-speedbar]
+ `(menu-item ,(purecopy "Speedbar") speedbar-frame-mode
+ :help ,(purecopy "Display a Speedbar quick-navigation frame")
+ :button (:toggle
+ . (and (boundp 'speedbar-frame)
+ (frame-live-p (symbol-value 'speedbar-frame))
+ (frame-visible-p
+ (symbol-value 'speedbar-frame))))))
+
+ (define-key menu [showhide-fringe]
+ `(menu-item ,(purecopy "Fringe") ,menu-bar-showhide-fringe-menu
+ :visible (display-graphic-p)))
+
+ (define-key menu [showhide-scroll-bar]
+ `(menu-item ,(purecopy "Scroll-bar") ,menu-bar-showhide-scroll-bar-menu
+ :visible (display-graphic-p)))
+
+ (define-key menu [showhide-tooltip-mode]
+ `(menu-item ,(purecopy "Tooltips") tooltip-mode
+ :help ,(purecopy "Turn tooltips on/off")
+ :visible (and (display-graphic-p) (fboundp 'x-show-tip))
+ :button (:toggle . tooltip-mode)))
+
+ (define-key menu [menu-bar-mode]
+ `(menu-item ,(purecopy "Menu-bar") toggle-menu-bar-mode-from-frame
+ :help ,(purecopy "Turn menu-bar on/off")
+ :button
+ (:toggle . (menu-bar-positive-p
+ (frame-parameter (menu-bar-frame-for-menubar)
+ 'menu-bar-lines)))))
+
+ (if (and (boundp 'menu-bar-showhide-tool-bar-menu)
+ (keymapp menu-bar-showhide-tool-bar-menu))
+ (define-key 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 [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 . (menu-bar-positive-p
+ (frame-parameter (menu-bar-frame-for-menubar)
+ 'tool-bar-lines))))))
+ menu))
(defun menu-bar-text-mode-auto-fill ()
(interactive)
@@ -1100,71 +1130,187 @@ mail status in mode line"))
;; -- Per Abrahamsen <abraham@dina.kvl.dk> 2002-02-11.
(customize-mark-as-set 'text-mode-hook))
-(define-key menu-bar-options-menu [auto-fill-mode]
- `(menu-item ,(purecopy "Auto Fill in Text Modes")
- menu-bar-text-mode-auto-fill
- :help ,(purecopy "Automatically fill text while typing (Auto Fill mode)")
- :button (:toggle . (if (listp text-mode-hook)
- (member 'turn-on-auto-fill text-mode-hook)
- (eq 'turn-on-auto-fill text-mode-hook)))))
-
-
-(defvar menu-bar-line-wrapping-menu (make-sparse-keymap "Line Wrapping"))
-
-(define-key menu-bar-line-wrapping-menu [word-wrap]
- `(menu-item ,(purecopy "Word Wrap (Visual Line mode)")
- (lambda ()
- (interactive)
- (unless visual-line-mode
- (visual-line-mode 1))
- (message ,(purecopy "Visual-Line mode enabled")))
- :help ,(purecopy "Wrap long lines at word boundaries")
- :button (:radio . (and (null truncate-lines)
- (not (truncated-partial-width-window-p))
- word-wrap))
- :visible (menu-bar-menu-frame-live-and-visible-p)))
-
-(define-key menu-bar-line-wrapping-menu [truncate]
- `(menu-item ,(purecopy "Truncate Long Lines")
- (lambda ()
- (interactive)
- (if visual-line-mode (visual-line-mode 0))
- (setq word-wrap nil)
- (toggle-truncate-lines 1))
- :help ,(purecopy "Truncate long lines at window edge")
- :button (:radio . (or truncate-lines
- (truncated-partial-width-window-p)))
- :visible (menu-bar-menu-frame-live-and-visible-p)
- :enable (not (truncated-partial-width-window-p))))
-
-(define-key menu-bar-line-wrapping-menu [window-wrap]
- `(menu-item ,(purecopy "Wrap at Window Edge")
- (lambda () (interactive)
- (if visual-line-mode (visual-line-mode 0))
- (setq word-wrap nil)
- (if truncate-lines (toggle-truncate-lines -1)))
- :help ,(purecopy "Wrap long lines at window edge")
- :button (:radio . (and (null truncate-lines)
- (not (truncated-partial-width-window-p))
- (not word-wrap)))
- :visible (menu-bar-menu-frame-live-and-visible-p)
- :enable (not (truncated-partial-width-window-p))))
-
-(define-key menu-bar-options-menu [line-wrapping]
- `(menu-item ,(purecopy "Line Wrapping in this Buffer") ,menu-bar-line-wrapping-menu))
-
-
-(define-key menu-bar-options-menu [highlight-separator]
- menu-bar-separator)
-(define-key menu-bar-options-menu [highlight-paren-mode]
- (menu-bar-make-mm-toggle show-paren-mode
- "Paren Match Highlighting"
- "Highlight matching/mismatched parentheses at cursor (Show Paren mode)"))
-(define-key menu-bar-options-menu [transient-mark-mode]
- (menu-bar-make-mm-toggle transient-mark-mode
- "Active Region Highlighting"
- "Make text in active region stand out in color (Transient Mark mode)"
- (:enable (not cua-mode))))
+
+(defvar menu-bar-line-wrapping-menu
+ (let ((menu (make-sparse-keymap "Line Wrapping")))
+
+ (define-key menu [word-wrap]
+ `(menu-item ,(purecopy "Word Wrap (Visual Line mode)")
+ (lambda ()
+ (interactive)
+ (unless visual-line-mode
+ (visual-line-mode 1))
+ (message ,(purecopy "Visual-Line mode enabled")))
+ :help ,(purecopy "Wrap long lines at word boundaries")
+ :button (:radio . (and (null truncate-lines)
+ (not (truncated-partial-width-window-p))
+ word-wrap))
+ :visible (menu-bar-menu-frame-live-and-visible-p)))
+
+ (define-key menu [truncate]
+ `(menu-item ,(purecopy "Truncate Long Lines")
+ (lambda ()
+ (interactive)
+ (if visual-line-mode (visual-line-mode 0))
+ (setq word-wrap nil)
+ (toggle-truncate-lines 1))
+ :help ,(purecopy "Truncate long lines at window edge")
+ :button (:radio . (or truncate-lines
+ (truncated-partial-width-window-p)))
+ :visible (menu-bar-menu-frame-live-and-visible-p)
+ :enable (not (truncated-partial-width-window-p))))
+
+ (define-key menu [window-wrap]
+ `(menu-item ,(purecopy "Wrap at Window Edge")
+ (lambda () (interactive)
+ (if visual-line-mode (visual-line-mode 0))
+ (setq word-wrap nil)
+ (if truncate-lines (toggle-truncate-lines -1)))
+ :help ,(purecopy "Wrap long lines at window edge")
+ :button (:radio . (and (null truncate-lines)
+ (not (truncated-partial-width-window-p))
+ (not word-wrap)))
+ :visible (menu-bar-menu-frame-live-and-visible-p)
+ :enable (not (truncated-partial-width-window-p))))
+ menu))
+
+(defvar menu-bar-options-menu
+ (let ((menu (make-sparse-keymap "Options")))
+ (define-key menu [customize]
+ `(menu-item ,(purecopy "Customize Emacs") ,menu-bar-custom-menu))
+
+ (define-key menu [package]
+ '(menu-item "Manage Emacs Packages" package-list-packages
+ :help "Install or uninstall additional Emacs packages"))
+
+ (define-key menu [save]
+ `(menu-item ,(purecopy "Save Options") menu-bar-options-save
+ :help ,(purecopy "Save options set from the menu above")))
+
+ (define-key menu [custom-separator]
+ menu-bar-separator)
+
+ (define-key menu [menu-set-font]
+ `(menu-item ,(purecopy "Set Default Font...") menu-set-font
+ :visible (display-multi-font-p)
+ :help ,(purecopy "Select a default font")))
+
+ (if (featurep 'system-font-setting)
+ (define-key menu [menu-system-font]
+ (menu-bar-make-toggle
+ toggle-use-system-font font-use-system-font
+ "Use system font"
+ "Use system font: %s"
+ "Use the monospaced font defined by the system")))
+
+ (define-key menu [showhide]
+ `(menu-item ,(purecopy "Show/Hide") ,menu-bar-showhide-menu))
+
+ (define-key menu [showhide-separator]
+ menu-bar-separator)
+
+ (define-key menu [mule]
+ ;; It is better not to use backquote here,
+ ;; because that makes a bootstrapping problem
+ ;; if you need to recompile all the Lisp files using interpreted code.
+ `(menu-item ,(purecopy "Multilingual Environment") ,mule-menu-keymap
+ ;; Most of the MULE menu actually does make sense in
+ ;; unibyte mode, e.g. language selection.
+ ;; :visible '(default-value 'enable-multibyte-characters)
+ ))
+ ;;(setq menu-bar-final-items (cons 'mule menu-bar-final-items))
+ ;;(define-key menu [preferences]
+ ;; `(menu-item ,(purecopy "Preferences") ,menu-bar-preferences-menu
+ ;; :help ,(purecopy "Toggle important global options")))
+
+ (define-key menu [mule-separator]
+ menu-bar-separator)
+
+ (define-key menu [debug-on-quit]
+ (menu-bar-make-toggle toggle-debug-on-quit debug-on-quit
+ "Enter Debugger on Quit/C-g" "Debug on Quit %s"
+ "Enter Lisp debugger when C-g is pressed"))
+ (define-key menu [debug-on-error]
+ (menu-bar-make-toggle toggle-debug-on-error debug-on-error
+ "Enter Debugger on Error" "Debug on Error %s"
+ "Enter Lisp debugger when an error is signaled"))
+ (define-key menu [debugger-separator]
+ menu-bar-separator)
+
+ (define-key menu [blink-cursor-mode]
+ (menu-bar-make-mm-toggle blink-cursor-mode
+ "Blinking Cursor"
+ "Whether the cursor blinks (Blink Cursor mode)"))
+ (define-key menu [cursor-separator]
+ menu-bar-separator)
+
+ (define-key menu [save-place]
+ (menu-bar-make-toggle toggle-save-place-globally save-place
+ "Save Place in Files between Sessions"
+ "Saving place in files %s"
+ "Visit files of previous session when restarting Emacs"
+ (require 'saveplace)
+ ;; Do it by name, to avoid a free-variable
+ ;; warning during byte compilation.
+ (set-default
+ 'save-place (not (symbol-value 'save-place)))))
+
+ (define-key menu [uniquify]
+ (menu-bar-make-toggle toggle-uniquify-buffer-names uniquify-buffer-name-style
+ "Use Directory Names in Buffer Names"
+ "Directory name in buffer names (uniquify) %s"
+ "Uniquify buffer names by adding parent directory names"
+ (require 'uniquify)
+ (setq uniquify-buffer-name-style
+ (if (not uniquify-buffer-name-style)
+ 'forward))))
+
+ (define-key menu [edit-options-separator]
+ menu-bar-separator)
+ (define-key menu [cua-mode]
+ (menu-bar-make-mm-toggle cua-mode
+ "C-x/C-c/C-v Cut and Paste (CUA)"
+ "Use C-z/C-x/C-c/C-v keys for undo/cut/copy/paste"
+ (:visible (or (not (boundp 'cua-enable-cua-keys))
+ cua-enable-cua-keys))))
+
+ (define-key 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"
+ (:visible (and (boundp 'cua-enable-cua-keys)
+ (not cua-enable-cua-keys)))))
+
+ (define-key menu [case-fold-search]
+ (menu-bar-make-toggle toggle-case-fold-search case-fold-search
+ "Case-Insensitive Search"
+ "Case-Insensitive Search %s"
+ "Ignore letter-case in search commands"))
+
+ (define-key menu [auto-fill-mode]
+ `(menu-item ,(purecopy "Auto Fill in Text Modes")
+ menu-bar-text-mode-auto-fill
+ :help ,(purecopy "Automatically fill text while typing (Auto Fill mode)")
+ :button (:toggle . (if (listp text-mode-hook)
+ (member 'turn-on-auto-fill text-mode-hook)
+ (eq 'turn-on-auto-fill text-mode-hook)))))
+
+ (define-key menu [line-wrapping]
+ `(menu-item ,(purecopy "Line Wrapping in this Buffer") ,menu-bar-line-wrapping-menu))
+
+
+ (define-key menu [highlight-separator]
+ menu-bar-separator)
+ (define-key menu [highlight-paren-mode]
+ (menu-bar-make-mm-toggle show-paren-mode
+ "Paren Match Highlighting"
+ "Highlight matching/mismatched parentheses at cursor (Show Paren mode)"))
+ (define-key menu [transient-mark-mode]
+ (menu-bar-make-mm-toggle transient-mark-mode
+ "Active Region Highlighting"
+ "Make text in active region stand out in color (Transient Mark mode)"
+ (:enable (not cua-mode))))
+ menu))
;; The "Tools" menu items
@@ -1189,267 +1335,276 @@ mail status in mode line"))
(known (assq read-mail-command known-rmail-commands)))
(if known (cdr known) (symbol-name read-mail-command))))
-(defvar menu-bar-games-menu (make-sparse-keymap "Games"))
-
-(define-key menu-bar-tools-menu [games]
- `(menu-item ,(purecopy "Games") ,menu-bar-games-menu))
-
-(define-key menu-bar-tools-menu [separator-games]
- menu-bar-separator)
-
-(define-key menu-bar-games-menu [zone]
- `(menu-item ,(purecopy "Zone Out") zone
- :help ,(purecopy "Play tricks with Emacs display when Emacs is idle")))
-(define-key menu-bar-games-menu [tetris]
- `(menu-item ,(purecopy "Tetris") tetris
- :help ,(purecopy "Falling blocks game")))
-(define-key menu-bar-games-menu [solitaire]
- `(menu-item ,(purecopy "Solitaire") solitaire
- :help ,(purecopy "Get rid of all the stones")))
-(define-key menu-bar-games-menu [snake]
- `(menu-item ,(purecopy "Snake") snake
- :help ,(purecopy "Move snake around avoiding collisions")))
-(define-key menu-bar-games-menu [pong]
- `(menu-item ,(purecopy "Pong") pong
- :help ,(purecopy "Bounce the ball to your opponent")))
-(define-key menu-bar-games-menu [mult]
- `(menu-item ,(purecopy "Multiplication Puzzle") mpuz
- :help ,(purecopy "Exercise brain with multiplication")))
-(define-key menu-bar-games-menu [life]
- `(menu-item ,(purecopy "Life") life
- :help ,(purecopy "Watch how John Conway's cellular automaton evolves")))
-(define-key menu-bar-games-menu [land]
- `(menu-item ,(purecopy "Landmark") landmark
- :help ,(purecopy "Watch a neural-network robot learn landmarks")))
-(define-key menu-bar-games-menu [hanoi]
- `(menu-item ,(purecopy "Towers of Hanoi") hanoi
- :help ,(purecopy "Watch Towers-of-Hanoi puzzle solved by Emacs")))
-(define-key menu-bar-games-menu [gomoku]
- `(menu-item ,(purecopy "Gomoku") gomoku
- :help ,(purecopy "Mark 5 contiguous squares (like tic-tac-toe)")))
-(define-key menu-bar-games-menu [bubbles]
- `(menu-item ,(purecopy "Bubbles") bubbles
- :help ,(purecopy "Remove all bubbles using the fewest moves")))
-(define-key menu-bar-games-menu [black-box]
- `(menu-item ,(purecopy "Blackbox") blackbox
- :help ,(purecopy "Find balls in a black box by shooting rays")))
-(define-key menu-bar-games-menu [adventure]
- `(menu-item ,(purecopy "Adventure") dunnet
- :help ,(purecopy "Dunnet, a text Adventure game for Emacs")))
-(define-key menu-bar-games-menu [5x5]
- `(menu-item ,(purecopy "5x5") 5x5
- :help ,(purecopy "Fill in all the squares on a 5x5 board")))
+(defvar menu-bar-games-menu
+ (let ((menu (make-sparse-keymap "Games")))
+
+ (define-key menu [zone]
+ `(menu-item ,(purecopy "Zone Out") zone
+ :help ,(purecopy "Play tricks with Emacs display when Emacs is idle")))
+ (define-key menu [tetris]
+ `(menu-item ,(purecopy "Tetris") tetris
+ :help ,(purecopy "Falling blocks game")))
+ (define-key menu [solitaire]
+ `(menu-item ,(purecopy "Solitaire") solitaire
+ :help ,(purecopy "Get rid of all the stones")))
+ (define-key menu [snake]
+ `(menu-item ,(purecopy "Snake") snake
+ :help ,(purecopy "Move snake around avoiding collisions")))
+ (define-key menu [pong]
+ `(menu-item ,(purecopy "Pong") pong
+ :help ,(purecopy "Bounce the ball to your opponent")))
+ (define-key menu [mult]
+ `(menu-item ,(purecopy "Multiplication Puzzle") mpuz
+ :help ,(purecopy "Exercise brain with multiplication")))
+ (define-key menu [life]
+ `(menu-item ,(purecopy "Life") life
+ :help ,(purecopy "Watch how John Conway's cellular automaton evolves")))
+ (define-key menu [land]
+ `(menu-item ,(purecopy "Landmark") landmark
+ :help ,(purecopy "Watch a neural-network robot learn landmarks")))
+ (define-key menu [hanoi]
+ `(menu-item ,(purecopy "Towers of Hanoi") hanoi
+ :help ,(purecopy "Watch Towers-of-Hanoi puzzle solved by Emacs")))
+ (define-key menu [gomoku]
+ `(menu-item ,(purecopy "Gomoku") gomoku
+ :help ,(purecopy "Mark 5 contiguous squares (like tic-tac-toe)")))
+ (define-key menu [bubbles]
+ `(menu-item ,(purecopy "Bubbles") bubbles
+ :help ,(purecopy "Remove all bubbles using the fewest moves")))
+ (define-key menu [black-box]
+ `(menu-item ,(purecopy "Blackbox") blackbox
+ :help ,(purecopy "Find balls in a black box by shooting rays")))
+ (define-key menu [adventure]
+ `(menu-item ,(purecopy "Adventure") dunnet
+ :help ,(purecopy "Dunnet, a text Adventure game for Emacs")))
+ (define-key menu [5x5]
+ `(menu-item ,(purecopy "5x5") 5x5
+ :help ,(purecopy "Fill in all the squares on a 5x5 board")))
+ menu))
(defvar menu-bar-encryption-decryption-menu
- (make-sparse-keymap "Encryption/Decryption"))
-
-(define-key menu-bar-tools-menu [encryption-decryption]
- `(menu-item ,(purecopy "Encryption/Decryption") ,menu-bar-encryption-decryption-menu))
-
-(define-key menu-bar-tools-menu [separator-encryption-decryption]
- menu-bar-separator)
-
-(define-key menu-bar-encryption-decryption-menu [insert-keys]
- `(menu-item ,(purecopy "Insert Keys") epa-insert-keys
- :help ,(purecopy "Insert public keys after the current point")))
-
-(define-key menu-bar-encryption-decryption-menu [export-keys]
- `(menu-item ,(purecopy "Export Keys") epa-export-keys
- :help ,(purecopy "Export public keys to a file")))
-
-(define-key menu-bar-encryption-decryption-menu [import-keys-region]
- `(menu-item ,(purecopy "Import Keys from Region") epa-import-keys-region
- :help ,(purecopy "Import public keys from the current region")))
-
-(define-key menu-bar-encryption-decryption-menu [import-keys]
- `(menu-item ,(purecopy "Import Keys from File...") epa-import-keys
- :help ,(purecopy "Import public keys from a file")))
-
-(define-key menu-bar-encryption-decryption-menu [list-keys]
- `(menu-item ,(purecopy "List Keys") epa-list-keys
- :help ,(purecopy "Browse your public keyring")))
-
-(define-key menu-bar-encryption-decryption-menu [separator-keys]
- menu-bar-separator)
-
-(define-key menu-bar-encryption-decryption-menu [sign-region]
- `(menu-item ,(purecopy "Sign Region") epa-sign-region
- :help ,(purecopy "Create digital signature of the current region")))
-
-(define-key menu-bar-encryption-decryption-menu [verify-region]
- `(menu-item ,(purecopy "Verify Region") epa-verify-region
- :help ,(purecopy "Verify digital signature of the current region")))
-
-(define-key menu-bar-encryption-decryption-menu [encrypt-region]
- `(menu-item ,(purecopy "Encrypt Region") epa-encrypt-region
- :help ,(purecopy "Encrypt the current region")))
-
-(define-key menu-bar-encryption-decryption-menu [decrypt-region]
- `(menu-item ,(purecopy "Decrypt Region") epa-decrypt-region
- :help ,(purecopy "Decrypt the current region")))
-
-(define-key menu-bar-encryption-decryption-menu [separator-file]
- menu-bar-separator)
-
-(define-key menu-bar-encryption-decryption-menu [sign-file]
- `(menu-item ,(purecopy "Sign File...") epa-sign-file
- :help ,(purecopy "Create digital signature of a file")))
-
-(define-key menu-bar-encryption-decryption-menu [verify-file]
- `(menu-item ,(purecopy "Verify File...") epa-verify-file
- :help ,(purecopy "Verify digital signature of a file")))
-
-(define-key menu-bar-encryption-decryption-menu [encrypt-file]
- `(menu-item ,(purecopy "Encrypt File...") epa-encrypt-file
- :help ,(purecopy "Encrypt a file")))
-
-(define-key menu-bar-encryption-decryption-menu [decrypt-file]
- `(menu-item ,(purecopy "Decrypt File...") epa-decrypt-file
- :help ,(purecopy "Decrypt a file")))
-
-(define-key menu-bar-tools-menu [simple-calculator]
- `(menu-item ,(purecopy "Simple Calculator") calculator
- :help ,(purecopy "Invoke the Emacs built-in quick calculator")))
-(define-key menu-bar-tools-menu [calc]
- `(menu-item ,(purecopy "Programmable Calculator") calc
- :help ,(purecopy "Invoke the Emacs built-in full scientific calculator")))
-(define-key menu-bar-tools-menu [calendar]
- `(menu-item ,(purecopy "Calendar") calendar
- :help ,(purecopy "Invoke the Emacs built-in calendar")))
-
-(define-key menu-bar-tools-menu [separator-net]
- menu-bar-separator)
-
-(define-key menu-bar-tools-menu [directory-search]
- `(menu-item ,(purecopy "Directory Search") eudc-tools-menu))
-(define-key menu-bar-tools-menu [compose-mail]
- `(menu-item (format "Send Mail (with %s)" (send-mail-item-name)) compose-mail
- :visible (and mail-user-agent (not (eq mail-user-agent 'ignore)))
- :help ,(purecopy "Send a mail message")))
-(define-key menu-bar-tools-menu [rmail]
- `(menu-item (format "Read Mail (with %s)" (read-mail-item-name))
- menu-bar-read-mail
- :visible (and read-mail-command
- (not (eq read-mail-command 'ignore)))
- :help ,(purecopy "Read your mail and reply to it")))
+ (let ((menu (make-sparse-keymap "Encryption/Decryption")))
+ (define-key menu [insert-keys]
+ `(menu-item ,(purecopy "Insert Keys") epa-insert-keys
+ :help ,(purecopy "Insert public keys after the current point")))
+
+ (define-key menu [export-keys]
+ `(menu-item ,(purecopy "Export Keys") epa-export-keys
+ :help ,(purecopy "Export public keys to a file")))
+
+ (define-key menu [import-keys-region]
+ `(menu-item ,(purecopy "Import Keys from Region") epa-import-keys-region
+ :help ,(purecopy "Import public keys from the current region")))
+
+ (define-key menu [import-keys]
+ `(menu-item ,(purecopy "Import Keys from File...") epa-import-keys
+ :help ,(purecopy "Import public keys from a file")))
+
+ (define-key menu [list-keys]
+ `(menu-item ,(purecopy "List Keys") epa-list-keys
+ :help ,(purecopy "Browse your public keyring")))
+
+ (define-key menu [separator-keys]
+ menu-bar-separator)
+
+ (define-key menu [sign-region]
+ `(menu-item ,(purecopy "Sign Region") epa-sign-region
+ :help ,(purecopy "Create digital signature of the current region")))
+
+ (define-key menu [verify-region]
+ `(menu-item ,(purecopy "Verify Region") epa-verify-region
+ :help ,(purecopy "Verify digital signature of the current region")))
+
+ (define-key menu [encrypt-region]
+ `(menu-item ,(purecopy "Encrypt Region") epa-encrypt-region
+ :help ,(purecopy "Encrypt the current region")))
+
+ (define-key menu [decrypt-region]
+ `(menu-item ,(purecopy "Decrypt Region") epa-decrypt-region
+ :help ,(purecopy "Decrypt the current region")))
+
+ (define-key menu [separator-file]
+ menu-bar-separator)
+
+ (define-key menu [sign-file]
+ `(menu-item ,(purecopy "Sign File...") epa-sign-file
+ :help ,(purecopy "Create digital signature of a file")))
+
+ (define-key menu [verify-file]
+ `(menu-item ,(purecopy "Verify File...") epa-verify-file
+ :help ,(purecopy "Verify digital signature of a file")))
+
+ (define-key menu [encrypt-file]
+ `(menu-item ,(purecopy "Encrypt File...") epa-encrypt-file
+ :help ,(purecopy "Encrypt a file")))
+
+ (define-key menu [decrypt-file]
+ `(menu-item ,(purecopy "Decrypt File...") epa-decrypt-file
+ :help ,(purecopy "Decrypt a file")))
+
+ menu))
(defun menu-bar-read-mail ()
"Read mail using `read-mail-command'."
(interactive)
(call-interactively read-mail-command))
-(define-key menu-bar-tools-menu [gnus]
- `(menu-item ,(purecopy "Read Net News (Gnus)") gnus
- :help ,(purecopy "Read network news groups")))
-
-(define-key menu-bar-tools-menu [separator-vc]
- menu-bar-separator)
-
-(define-key menu-bar-tools-menu [pcl-cvs]
- `(menu-item ,(purecopy "PCL-CVS") cvs-global-menu))
-(define-key menu-bar-tools-menu [vc] nil) ;Create the place for the VC menu.
-
-(define-key menu-bar-tools-menu [separator-compare]
- menu-bar-separator)
-
-(define-key menu-bar-tools-menu [epatch]
- `(menu-item ,(purecopy "Apply Patch") menu-bar-epatch-menu))
-(define-key menu-bar-tools-menu [ediff-merge]
- `(menu-item ,(purecopy "Merge") menu-bar-ediff-merge-menu))
-(define-key menu-bar-tools-menu [compare]
- `(menu-item ,(purecopy "Compare (Ediff)") menu-bar-ediff-menu))
-
-(define-key menu-bar-tools-menu [separator-spell]
- menu-bar-separator)
-
-(define-key menu-bar-tools-menu [spell]
- `(menu-item ,(purecopy "Spell Checking") ispell-menu-map))
-
-(define-key menu-bar-tools-menu [separator-prog]
- menu-bar-separator)
-
-(define-key menu-bar-tools-menu [semantic]
- `(menu-item ,(purecopy "Source Code Parsers (Semantic)")
- semantic-mode
- :help ,(purecopy "Toggle automatic parsing in source code buffers (Semantic mode)")
- :button (:toggle . (bound-and-true-p semantic-mode))))
-
-(define-key menu-bar-tools-menu [ede]
- `(menu-item ,(purecopy "Project support (EDE)")
- global-ede-mode
- :help ,(purecopy "Toggle the Emacs Development Environment (Global EDE mode)")
- :button (:toggle . (bound-and-true-p global-ede-mode))))
-
-(define-key menu-bar-tools-menu [gdb]
- `(menu-item ,(purecopy "Debugger (GDB)...") gdb
- :help ,(purecopy "Debug a program from within Emacs with GDB")))
-(define-key menu-bar-tools-menu [shell-on-region]
- `(menu-item ,(purecopy "Shell Command on Region...") shell-command-on-region
- :enable mark-active
- :help ,(purecopy "Pass marked region to a shell command")))
-(define-key menu-bar-tools-menu [shell]
- `(menu-item ,(purecopy "Shell Command...") shell-command
- :help ,(purecopy "Invoke a shell command and catch its output")))
-(define-key menu-bar-tools-menu [compile]
- `(menu-item ,(purecopy "Compile...") compile
- :help ,(purecopy "Invoke compiler or Make, view compilation errors")))
-(define-key menu-bar-tools-menu [grep]
- `(menu-item ,(purecopy "Search Files (Grep)...") grep
- :help ,(purecopy "Search files for strings or regexps (with Grep)")))
-
+(defvar menu-bar-tools-menu
+ (let ((menu (make-sparse-keymap "Tools")))
+
+ (define-key menu [games]
+ `(menu-item ,(purecopy "Games") ,menu-bar-games-menu))
+
+ (define-key menu [separator-games]
+ menu-bar-separator)
+
+ (define-key menu [encryption-decryption]
+ `(menu-item ,(purecopy "Encryption/Decryption") ,menu-bar-encryption-decryption-menu))
+
+ (define-key menu [separator-encryption-decryption]
+ menu-bar-separator)
+
+ (define-key menu [simple-calculator]
+ `(menu-item ,(purecopy "Simple Calculator") calculator
+ :help ,(purecopy "Invoke the Emacs built-in quick calculator")))
+ (define-key menu [calc]
+ `(menu-item ,(purecopy "Programmable Calculator") calc
+ :help ,(purecopy "Invoke the Emacs built-in full scientific calculator")))
+ (define-key menu [calendar]
+ `(menu-item ,(purecopy "Calendar") calendar
+ :help ,(purecopy "Invoke the Emacs built-in calendar")))
+
+ (define-key menu [separator-net]
+ menu-bar-separator)
+
+ (define-key menu [directory-search]
+ `(menu-item ,(purecopy "Directory Search") eudc-tools-menu))
+ (define-key menu [compose-mail]
+ `(menu-item (format "Send Mail (with %s)" (send-mail-item-name)) compose-mail
+ :visible (and mail-user-agent (not (eq mail-user-agent 'ignore)))
+ :help ,(purecopy "Send a mail message")))
+ (define-key menu [rmail]
+ `(menu-item (format "Read Mail (with %s)" (read-mail-item-name))
+ menu-bar-read-mail
+ :visible (and read-mail-command
+ (not (eq read-mail-command 'ignore)))
+ :help ,(purecopy "Read your mail and reply to it")))
+
+ (define-key menu [gnus]
+ `(menu-item ,(purecopy "Read Net News (Gnus)") gnus
+ :help ,(purecopy "Read network news groups")))
+
+ (define-key menu [separator-vc]
+ menu-bar-separator)
+
+ (define-key menu [pcl-cvs]
+ `(menu-item ,(purecopy "PCL-CVS") cvs-global-menu))
+ (define-key menu [vc] nil) ;Create the place for the VC menu.
+
+ (define-key menu [separator-compare]
+ menu-bar-separator)
+
+ (define-key menu [epatch]
+ `(menu-item ,(purecopy "Apply Patch") menu-bar-epatch-menu))
+ (define-key menu [ediff-merge]
+ `(menu-item ,(purecopy "Merge") menu-bar-ediff-merge-menu))
+ (define-key menu [compare]
+ `(menu-item ,(purecopy "Compare (Ediff)") menu-bar-ediff-menu))
+
+ (define-key menu [separator-spell]
+ menu-bar-separator)
+
+ (define-key menu [spell]
+ `(menu-item ,(purecopy "Spell Checking") ispell-menu-map))
+
+ (define-key menu [separator-prog]
+ menu-bar-separator)
+
+ (define-key menu [semantic]
+ `(menu-item ,(purecopy "Source Code Parsers (Semantic)")
+ semantic-mode
+ :help ,(purecopy "Toggle automatic parsing in source code buffers (Semantic mode)")
+ :button (:toggle . (bound-and-true-p semantic-mode))))
+
+ (define-key menu [ede]
+ `(menu-item ,(purecopy "Project support (EDE)")
+ global-ede-mode
+ :help ,(purecopy "Toggle the Emacs Development Environment (Global EDE mode)")
+ :button (:toggle . (bound-and-true-p global-ede-mode))))
+
+ (define-key menu [gdb]
+ `(menu-item ,(purecopy "Debugger (GDB)...") gdb
+ :help ,(purecopy "Debug a program from within Emacs with GDB")))
+ (define-key menu [shell-on-region]
+ `(menu-item ,(purecopy "Shell Command on Region...") shell-command-on-region
+ :enable mark-active
+ :help ,(purecopy "Pass marked region to a shell command")))
+ (define-key menu [shell]
+ `(menu-item ,(purecopy "Shell Command...") shell-command
+ :help ,(purecopy "Invoke a shell command and catch its output")))
+ (define-key menu [compile]
+ `(menu-item ,(purecopy "Compile...") compile
+ :help ,(purecopy "Invoke compiler or Make, view compilation errors")))
+ (define-key menu [grep]
+ `(menu-item ,(purecopy "Search Files (Grep)...") grep
+ :help ,(purecopy "Search files for strings or regexps (with Grep)")))
+ menu))
;; The "Help" menu items
-(defvar menu-bar-describe-menu (make-sparse-keymap "Describe"))
-
-(define-key menu-bar-describe-menu [mule-diag]
- `(menu-item ,(purecopy "Show All of Mule Status") mule-diag
- :visible (default-value 'enable-multibyte-characters)
- :help ,(purecopy "Display multilingual environment settings")))
-(define-key menu-bar-describe-menu [describe-coding-system-briefly]
- `(menu-item ,(purecopy "Describe Coding System (Briefly)")
- describe-current-coding-system-briefly
- :visible (default-value 'enable-multibyte-characters)))
-(define-key menu-bar-describe-menu [describe-coding-system]
- `(menu-item ,(purecopy "Describe Coding System...") describe-coding-system
- :visible (default-value 'enable-multibyte-characters)))
-(define-key menu-bar-describe-menu [describe-input-method]
- `(menu-item ,(purecopy "Describe Input Method...") describe-input-method
- :visible (default-value 'enable-multibyte-characters)
- :help ,(purecopy "Keyboard layout for specific input method")))
-(define-key menu-bar-describe-menu [describe-language-environment]
- `(menu-item ,(purecopy "Describe Language Environment")
- ,describe-language-environment-map))
-
-(define-key menu-bar-describe-menu [separator-desc-mule]
- menu-bar-separator)
-
-(define-key menu-bar-describe-menu [list-keybindings]
- `(menu-item ,(purecopy "List Key Bindings") describe-bindings
- :help ,(purecopy "Display all current key bindings (keyboard shortcuts)")))
-(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-face]
- `(menu-item ,(purecopy "Describe Face...") describe-face
- :help ,(purecopy "Display the properties of a face")))
-(define-key menu-bar-describe-menu [describe-variable]
- `(menu-item ,(purecopy "Describe Variable...") describe-variable
- :help ,(purecopy "Display documentation of variable/option")))
-(define-key menu-bar-describe-menu [describe-function]
- `(menu-item ,(purecopy "Describe Function...") describe-function
- :help ,(purecopy "Display documentation of function/command")))
-(define-key menu-bar-describe-menu [describe-key-1]
- `(menu-item ,(purecopy "Describe Key or Mouse Operation...") describe-key
- ;; Users typically don't identify keys and menu items...
- :help ,(purecopy "Display documentation of command bound to a \
+(defvar menu-bar-describe-menu
+ (let ((menu (make-sparse-keymap "Describe")))
+
+ (define-key menu [mule-diag]
+ `(menu-item ,(purecopy "Show All of Mule Status") mule-diag
+ :visible (default-value 'enable-multibyte-characters)
+ :help ,(purecopy "Display multilingual environment settings")))
+ (define-key menu [describe-coding-system-briefly]
+ `(menu-item ,(purecopy "Describe Coding System (Briefly)")
+ describe-current-coding-system-briefly
+ :visible (default-value 'enable-multibyte-characters)))
+ (define-key menu [describe-coding-system]
+ `(menu-item ,(purecopy "Describe Coding System...") describe-coding-system
+ :visible (default-value 'enable-multibyte-characters)))
+ (define-key menu [describe-input-method]
+ `(menu-item ,(purecopy "Describe Input Method...") describe-input-method
+ :visible (default-value 'enable-multibyte-characters)
+ :help ,(purecopy "Keyboard layout for specific input method")))
+ (define-key menu [describe-language-environment]
+ `(menu-item ,(purecopy "Describe Language Environment")
+ ,describe-language-environment-map))
+
+ (define-key menu [separator-desc-mule]
+ menu-bar-separator)
+
+ (define-key menu [list-keybindings]
+ `(menu-item ,(purecopy "List Key Bindings") describe-bindings
+ :help ,(purecopy "Display all current key bindings (keyboard shortcuts)")))
+ (define-key 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 [describe-package]
+ `(menu-item ,(purecopy "Describe Package...") describe-package
+ :help ,(purecopy "Display documentation of a Lisp package")))
+ (define-key menu [describe-face]
+ `(menu-item ,(purecopy "Describe Face...") describe-face
+ :help ,(purecopy "Display the properties of a face")))
+ (define-key menu [describe-variable]
+ `(menu-item ,(purecopy "Describe Variable...") describe-variable
+ :help ,(purecopy "Display documentation of variable/option")))
+ (define-key menu [describe-function]
+ `(menu-item ,(purecopy "Describe Function...") describe-function
+ :help ,(purecopy "Display documentation of function/command")))
+ (define-key menu [describe-key-1]
+ `(menu-item ,(purecopy "Describe Key or Mouse Operation...") describe-key
+ ;; Users typically don't identify keys and menu items...
+ :help ,(purecopy "Display documentation of command bound to a \
key, a click, or a menu-item")))
-(define-key menu-bar-describe-menu [describe-mode]
- `(menu-item ,(purecopy "Describe Buffer Modes") describe-mode
- :help ,(purecopy "Describe this buffer's major and minor mode")))
+ (define-key menu [describe-mode]
+ `(menu-item ,(purecopy "Describe Buffer Modes") describe-mode
+ :help ,(purecopy "Describe this buffer's major and minor mode")))
+ menu))
-(defvar menu-bar-search-documentation-menu
- (make-sparse-keymap "Search Documentation"))
(defun menu-bar-read-lispref ()
"Display the Emacs Lisp Reference manual in Info mode."
(interactive)
@@ -1477,80 +1632,69 @@ key, a click, or a menu-item")))
(info "elisp")
(Info-index topic))
-(define-key menu-bar-search-documentation-menu [search-documentation-strings]
- `(menu-item ,(purecopy "Search Documentation Strings...") apropos-documentation
- :help
- ,(purecopy "Find functions and variables whose doc strings match a regexp")))
-(define-key menu-bar-search-documentation-menu [find-any-object-by-name]
- `(menu-item ,(purecopy "Find Any Object by Name...") apropos
- :help ,(purecopy "Find symbols of any kind whose names match a regexp")))
-(define-key menu-bar-search-documentation-menu [find-option-by-value]
- `(menu-item ,(purecopy "Find Options by Value...") apropos-value
- :help ,(purecopy "Find variables whose values match a regexp")))
-(define-key menu-bar-search-documentation-menu [find-options-by-name]
- `(menu-item ,(purecopy "Find Options by Name...") apropos-variable
- :help ,(purecopy "Find variables whose names match a regexp")))
-(define-key menu-bar-search-documentation-menu [find-commands-by-name]
- `(menu-item ,(purecopy "Find Commands by Name...") apropos-command
- :help ,(purecopy "Find commands whose names match a regexp")))
-(define-key menu-bar-search-documentation-menu [sep1]
- menu-bar-separator)
-(define-key menu-bar-search-documentation-menu [lookup-command-in-manual]
- `(menu-item ,(purecopy "Look Up Command in User Manual...") Info-goto-emacs-command-node
- :help ,(purecopy "Display manual section that describes a command")))
-(define-key menu-bar-search-documentation-menu [lookup-key-in-manual]
- `(menu-item ,(purecopy "Look Up Key in User Manual...") Info-goto-emacs-key-command-node
- :help ,(purecopy "Display manual section that describes a key")))
-(define-key menu-bar-search-documentation-menu [lookup-subject-in-elisp-manual]
- `(menu-item ,(purecopy "Look Up Subject in ELisp Manual...") elisp-index-search
- :help ,(purecopy "Find description of a subject in Emacs Lisp manual")))
-(define-key menu-bar-search-documentation-menu [lookup-subject-in-emacs-manual]
- `(menu-item ,(purecopy "Look Up Subject in User Manual...") emacs-index-search
- :help ,(purecopy "Find description of a subject in Emacs User manual")))
-(define-key menu-bar-search-documentation-menu [emacs-terminology]
- `(menu-item ,(purecopy "Emacs Terminology") search-emacs-glossary
- :help ,(purecopy "Display the Glossary section of the Emacs manual")))
-
-(defvar menu-bar-manuals-menu (make-sparse-keymap "More Manuals"))
-
-(define-key menu-bar-manuals-menu [man]
- `(menu-item ,(purecopy "Read Man Page...") manual-entry
- :help ,(purecopy "Man-page docs for external commands and libraries")))
-(define-key menu-bar-manuals-menu [sep2]
- menu-bar-separator)
-(define-key menu-bar-manuals-menu [order-emacs-manuals]
- `(menu-item ,(purecopy "Ordering Manuals") view-order-manuals
- :help ,(purecopy "How to order manuals from the Free Software Foundation")))
-(define-key menu-bar-manuals-menu [lookup-subject-in-all-manuals]
- `(menu-item ,(purecopy "Lookup Subject in all Manuals...") info-apropos
- :help ,(purecopy "Find description of a subject in all installed manuals")))
-(define-key menu-bar-manuals-menu [other-manuals]
- `(menu-item ,(purecopy "All Other Manuals (Info)") Info-directory
- :help ,(purecopy "Read any of the installed manuals")))
-(define-key menu-bar-manuals-menu [emacs-lisp-reference]
- `(menu-item ,(purecopy "Emacs Lisp Reference") menu-bar-read-lispref
- :help ,(purecopy "Read the Emacs Lisp Reference manual")))
-(define-key menu-bar-manuals-menu [emacs-lisp-intro]
- `(menu-item ,(purecopy "Introduction to Emacs Lisp") menu-bar-read-lispintro
- :help ,(purecopy "Read the Introduction to Emacs Lisp Programming")))
-
-(define-key menu-bar-help-menu [about-gnu-project]
- `(menu-item ,(purecopy "About GNU") describe-gnu-project
- :help ,(purecopy "About the GNU System, GNU Project, and GNU/Linux")))
-(define-key menu-bar-help-menu [about-emacs]
- `(menu-item ,(purecopy "About Emacs") about-emacs
- :help ,(purecopy "Display version number, copyright info, and basic help")))
-(define-key menu-bar-help-menu [sep4]
- menu-bar-separator)
-(define-key menu-bar-help-menu [describe-no-warranty]
- `(menu-item ,(purecopy "(Non)Warranty") describe-no-warranty
- :help ,(purecopy "Explain that Emacs has NO WARRANTY")))
-(define-key menu-bar-help-menu [describe-copying]
- `(menu-item ,(purecopy "Copying Conditions") describe-copying
- :help ,(purecopy "Show the Emacs license (GPL)")))
-(define-key menu-bar-help-menu [getting-new-versions]
- `(menu-item ,(purecopy "Getting New Versions") describe-distribution
- :help ,(purecopy "How to get the latest version of Emacs")))
+(defvar menu-bar-search-documentation-menu
+ (let ((menu (make-sparse-keymap "Search Documentation")))
+
+ (define-key menu [search-documentation-strings]
+ `(menu-item ,(purecopy "Search Documentation Strings...") apropos-documentation
+ :help
+ ,(purecopy "Find functions and variables whose doc strings match a regexp")))
+ (define-key menu [find-any-object-by-name]
+ `(menu-item ,(purecopy "Find Any Object by Name...") apropos
+ :help ,(purecopy "Find symbols of any kind whose names match a regexp")))
+ (define-key menu [find-option-by-value]
+ `(menu-item ,(purecopy "Find Options by Value...") apropos-value
+ :help ,(purecopy "Find variables whose values match a regexp")))
+ (define-key menu [find-options-by-name]
+ `(menu-item ,(purecopy "Find Options by Name...") apropos-variable
+ :help ,(purecopy "Find variables whose names match a regexp")))
+ (define-key menu [find-commands-by-name]
+ `(menu-item ,(purecopy "Find Commands by Name...") apropos-command
+ :help ,(purecopy "Find commands whose names match a regexp")))
+ (define-key menu [sep1]
+ menu-bar-separator)
+ (define-key menu [lookup-command-in-manual]
+ `(menu-item ,(purecopy "Look Up Command in User Manual...") Info-goto-emacs-command-node
+ :help ,(purecopy "Display manual section that describes a command")))
+ (define-key menu [lookup-key-in-manual]
+ `(menu-item ,(purecopy "Look Up Key in User Manual...") Info-goto-emacs-key-command-node
+ :help ,(purecopy "Display manual section that describes a key")))
+ (define-key menu [lookup-subject-in-elisp-manual]
+ `(menu-item ,(purecopy "Look Up Subject in ELisp Manual...") elisp-index-search
+ :help ,(purecopy "Find description of a subject in Emacs Lisp manual")))
+ (define-key menu [lookup-subject-in-emacs-manual]
+ `(menu-item ,(purecopy "Look Up Subject in User Manual...") emacs-index-search
+ :help ,(purecopy "Find description of a subject in Emacs User manual")))
+ (define-key menu [emacs-terminology]
+ `(menu-item ,(purecopy "Emacs Terminology") search-emacs-glossary
+ :help ,(purecopy "Display the Glossary section of the Emacs manual")))
+ menu))
+
+(defvar menu-bar-manuals-menu
+ (let ((menu (make-sparse-keymap "More Manuals")))
+
+ (define-key menu [man]
+ `(menu-item ,(purecopy "Read Man Page...") manual-entry
+ :help ,(purecopy "Man-page docs for external commands and libraries")))
+ (define-key menu [sep2]
+ menu-bar-separator)
+ (define-key menu [order-emacs-manuals]
+ `(menu-item ,(purecopy "Ordering Manuals") view-order-manuals
+ :help ,(purecopy "How to order manuals from the Free Software Foundation")))
+ (define-key menu [lookup-subject-in-all-manuals]
+ `(menu-item ,(purecopy "Lookup Subject in all Manuals...") info-apropos
+ :help ,(purecopy "Find description of a subject in all installed manuals")))
+ (define-key menu [other-manuals]
+ `(menu-item ,(purecopy "All Other Manuals (Info)") Info-directory
+ :help ,(purecopy "Read any of the installed manuals")))
+ (define-key menu [emacs-lisp-reference]
+ `(menu-item ,(purecopy "Emacs Lisp Reference") menu-bar-read-lispref
+ :help ,(purecopy "Read the Emacs Lisp Reference manual")))
+ (define-key menu [emacs-lisp-intro]
+ `(menu-item ,(purecopy "Introduction to Emacs Lisp") menu-bar-read-lispintro
+ :help ,(purecopy "Read the Introduction to Emacs Lisp Programming")))
+ menu))
+
(defun menu-bar-help-extra-packages ()
"Display help about some additional packages available for Emacs."
(interactive)
@@ -1558,53 +1702,101 @@ key, a click, or a menu-item")))
(view-file (expand-file-name "MORE.STUFF"
data-directory))
(goto-address-mode 1)))
-(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
- :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")))
-(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]
- `(menu-item ,(purecopy "Read the Emacs Manual") info-emacs-manual
- :help ,(purecopy "Full documentation of Emacs features")))
-(define-key menu-bar-help-menu [describe]
- `(menu-item ,(purecopy "Describe") ,menu-bar-describe-menu))
-(define-key menu-bar-help-menu [search-documentation]
- `(menu-item ,(purecopy "Search Documentation") ,menu-bar-search-documentation-menu))
-(define-key menu-bar-help-menu [sep1]
- menu-bar-separator)
-(define-key menu-bar-help-menu [emacs-psychotherapist]
- `(menu-item ,(purecopy "Emacs Psychotherapist") doctor
- :help ,(purecopy "Our doctor will help you feel better")))
-(define-key menu-bar-help-menu [send-emacs-bug-report]
- `(menu-item ,(purecopy "Send Bug Report...") report-emacs-bug
- :help ,(purecopy "Send e-mail to Emacs maintainers")))
-(define-key menu-bar-help-menu [emacs-known-problems]
- `(menu-item ,(purecopy "Emacs Known Problems") view-emacs-problems
- :help ,(purecopy "Read about known problems with Emacs")))
-(define-key menu-bar-help-menu [emacs-news]
- `(menu-item ,(purecopy "Emacs News") view-emacs-news
- :help ,(purecopy "New features of this version")))
-(define-key menu-bar-help-menu [emacs-faq]
- `(menu-item ,(purecopy "Emacs FAQ") view-emacs-FAQ
- :help ,(purecopy "Frequently asked (and answered) questions about Emacs")))
(defun help-with-tutorial-spec-language ()
"Use the Emacs tutorial, specifying which language you want."
(interactive)
(help-with-tutorial t))
-(define-key menu-bar-help-menu [emacs-tutorial-language-specific]
- `(menu-item ,(purecopy "Emacs Tutorial (choose language)...")
- help-with-tutorial-spec-language
- :help ,(purecopy "Learn how to use Emacs (choose a language)")))
-(define-key menu-bar-help-menu [emacs-tutorial]
- `(menu-item ,(purecopy "Emacs Tutorial") help-with-tutorial
- :help ,(purecopy "Learn how to use Emacs")))
+(defvar menu-bar-help-menu
+ (let ((menu (make-sparse-keymap "Help")))
+ (define-key menu [about-gnu-project]
+ `(menu-item ,(purecopy "About GNU") describe-gnu-project
+ :help ,(purecopy "About the GNU System, GNU Project, and GNU/Linux")))
+ (define-key menu [about-emacs]
+ `(menu-item ,(purecopy "About Emacs") about-emacs
+ :help ,(purecopy "Display version number, copyright info, and basic help")))
+ (define-key menu [sep4]
+ menu-bar-separator)
+ (define-key menu [describe-no-warranty]
+ `(menu-item ,(purecopy "(Non)Warranty") describe-no-warranty
+ :help ,(purecopy "Explain that Emacs has NO WARRANTY")))
+ (define-key menu [describe-copying]
+ `(menu-item ,(purecopy "Copying Conditions") describe-copying
+ :help ,(purecopy "Show the Emacs license (GPL)")))
+ (define-key menu [getting-new-versions]
+ `(menu-item ,(purecopy "Getting New Versions") describe-distribution
+ :help ,(purecopy "How to get the latest version of Emacs")))
+ (define-key menu [sep2]
+ menu-bar-separator)
+ (define-key menu [external-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 [find-emacs-packages]
+ `(menu-item ,(purecopy "Search Built-in Packages") finder-by-keyword
+ :help ,(purecopy "Find built-in packages and features by keyword")))
+ (define-key menu [more-manuals]
+ `(menu-item ,(purecopy "More Manuals") ,menu-bar-manuals-menu))
+ (define-key menu [emacs-manual]
+ `(menu-item ,(purecopy "Read the Emacs Manual") info-emacs-manual
+ :help ,(purecopy "Full documentation of Emacs features")))
+ (define-key menu [describe]
+ `(menu-item ,(purecopy "Describe") ,menu-bar-describe-menu))
+ (define-key menu [search-documentation]
+ `(menu-item ,(purecopy "Search Documentation") ,menu-bar-search-documentation-menu))
+ (define-key menu [sep1]
+ menu-bar-separator)
+ (define-key menu [emacs-psychotherapist]
+ `(menu-item ,(purecopy "Emacs Psychotherapist") doctor
+ :help ,(purecopy "Our doctor will help you feel better")))
+ (define-key menu [send-emacs-bug-report]
+ `(menu-item ,(purecopy "Send Bug Report...") report-emacs-bug
+ :help ,(purecopy "Send e-mail to Emacs maintainers")))
+ (define-key menu [emacs-known-problems]
+ `(menu-item ,(purecopy "Emacs Known Problems") view-emacs-problems
+ :help ,(purecopy "Read about known problems with Emacs")))
+ (define-key menu [emacs-news]
+ `(menu-item ,(purecopy "Emacs News") view-emacs-news
+ :help ,(purecopy "New features of this version")))
+ (define-key menu [emacs-faq]
+ `(menu-item ,(purecopy "Emacs FAQ") view-emacs-FAQ
+ :help ,(purecopy "Frequently asked (and answered) questions about Emacs")))
+
+ (define-key menu [emacs-tutorial-language-specific]
+ `(menu-item ,(purecopy "Emacs Tutorial (choose language)...")
+ help-with-tutorial-spec-language
+ :help ,(purecopy "Learn how to use Emacs (choose a language)")))
+ (define-key menu [emacs-tutorial]
+ `(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 [info-panel]
+ `(menu-item ,(purecopy "About Emacs...") ns-do-emacs-info-panel)))
+ menu))
+
+(define-key global-map [menu-bar tools]
+ (cons (purecopy "Tools") menu-bar-tools-menu))
+(define-key global-map [menu-bar buffer]
+ (cons (purecopy "Buffers") global-buffers-menu-map))
+(define-key global-map [menu-bar options]
+ (cons (purecopy "Options") menu-bar-options-menu))
+(define-key global-map [menu-bar edit]
+ (cons (purecopy "Edit") menu-bar-edit-menu))
+(define-key global-map [menu-bar file]
+ (cons (purecopy "File") menu-bar-file-menu))
+
+;; Put "Help" menu at the end, or Info at the front.
+;; If running under GNUstep, "Help" is moved and renamed "Info" (see below).
+(if (and (featurep 'ns)
+ (not (eq system-type 'darwin)))
+ (define-key global-map [menu-bar help-menu]
+ (cons (purecopy "Info") menu-bar-help-menu))
+ (define-key-after global-map [menu-bar help-menu]
+ (cons (purecopy "Help") menu-bar-help-menu)))
(defun menu-bar-menu-frame-live-and-visible-p ()
"Return non-nil if the menu frame is alive and visible.
@@ -1956,21 +2148,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.)
@@ -1987,7 +2186,10 @@ turn on menu bars; otherwise, turn off menu bars."
See `menu-bar-mode' for more information."
(interactive (list (or current-prefix-arg 'toggle)))
(if (eq arg 'toggle)
- (menu-bar-mode (if (> (frame-parameter nil 'menu-bar-lines) 0) 0 1))
+ (menu-bar-mode
+ (if (menu-bar-positive-p
+ (frame-parameter (menu-bar-frame-for-menubar) 'menu-bar-lines))
+ 0 1))
(menu-bar-mode arg)))
(declare-function x-menu-bar-open "term/x-win" (&optional frame))
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 1c07be301b1..5228dc86fa2 100644
--- a/lisp/mh-e/ChangeLog
+++ b/lisp/mh-e/ChangeLog
@@ -1,12 +1,60 @@
+2011-04-28 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * mh-utils.el (mh-folder-completion-function): Make it work like
+ file-name completion, so partial-completion can do its job.
+
+ * mh-letter.el (mh-letter-completion-at-point): New function, extracted
+ from mh-letter-complete
+ (mh-letter-mode, mh-letter-complete, mh-letter-complete-or-space):
+ Use it.
+ (mh-complete-word): Only use the common-substring arg when it works.
+ (mh-folder-expand-at-point):
+ * mh-alias.el (mh-alias-letter-expand-alias): Return data suitable for
+ completion-at-point-functions.
+
+2011-04-06 Juanma Barranquero <lekktu@gmail.com>
+
+ * mh-funcs.el (mh-undo-folder): Accept and ignore arguments,
+ for compatibility with `revert-buffer'. Doc fix. (Bug#8431)
+
2011-03-07 Chong Yidong <cyd@stupidchicken.com>
* Version 23.3 released.
+2011-03-05 Antoine Levitt <antoine.levitt@gmail.com>
+
+ * mh-funcs.el (mh-store-msg, mh-store-buffer):
+ * mh-mime.el (mh-mime-save-parts): Use read-directory-name.
+
+2011-01-13 Chong Yidong <cyd@stupidchicken.com>
+
+ * mh-comp.el (mh-user-agent-compose): New arg RETURN-ACTION.
+
+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)
@@ -18,6 +66,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.
@@ -492,8 +544,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).
@@ -1403,7 +1455,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.
@@ -1720,7 +1772,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.
@@ -1879,7 +1931,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.
@@ -2448,7 +2500,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
@@ -2748,7 +2800,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)
@@ -3250,7 +3302,7 @@
* ChangeLog.1: New file. Contains old ChangeLog.
- Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 2005-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -3273,4 +3325,3 @@
;; add-log-time-zone-rule: t
;; End:
-;;; arch-tag: 87324964-69b6-4925-a3c2-9c1df53d7d51
diff --git a/lisp/mh-e/ChangeLog.1 b/lisp/mh-e/ChangeLog.1
index bf90d0dce40..69ca927d5e7 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,7 @@
(dist): Leave release in current directory.
- Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 2003-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -11422,5 +11416,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-acros.el b/lisp/mh-e/mh-acros.el
index a53ae4a3ed4..c1964d5a4ea 100644
--- a/lisp/mh-e/mh-acros.el
+++ b/lisp/mh-e/mh-acros.el
@@ -1,7 +1,6 @@
;;; mh-acros.el --- macros used in MH-E
-;; Copyright (C) 2004, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004, 2006-2011 Free Software Foundation, Inc.
;; Author: Satyaki Das <satyaki@theforce.stanford.edu>
;; Maintainer: Bill Wohler <wohler@newt.com>
@@ -327,5 +326,4 @@ MH-E functions."
;; sentence-end-double-space: nil
;; End:
-;; arch-tag: b383b49a-494f-4ed0-a30a-cb6d5d2da4ff
;;; mh-acros.el ends here
diff --git a/lisp/mh-e/mh-alias.el b/lisp/mh-e/mh-alias.el
index 6ed04ebb74a..c93aaeb70da 100644
--- a/lisp/mh-e/mh-alias.el
+++ b/lisp/mh-e/mh-alias.el
@@ -1,8 +1,6 @@
;;; mh-alias.el --- MH-E mail alias completion and expansion
-;; Copyright (C) 1994, 1995, 1996, 1997,
-;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1994-1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Peter S. Galbraith <psg@debian.org>
;; Maintainer: Bill Wohler <wohler@newt.com>
@@ -234,7 +232,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))
@@ -288,7 +286,7 @@ Blind aliases or users from /etc/passwd are not expanded."
(the-name (buffer-substring-no-properties beg (point))))
(if (mh-assoc-string the-name mh-alias-alist t)
(message "%s -> %s" the-name (mh-alias-expand the-name))
- ;; Check if if was a single word likely to be an alias
+ ;; Check if it was a single word likely to be an alias
(if (and (equal mh-alias-flash-on-comma 1)
(not (string-match " " the-name)))
(message "No alias for %s" the-name))))))
@@ -298,16 +296,28 @@ Blind aliases or users from /etc/passwd are not expanded."
(defun mh-alias-letter-expand-alias ()
"Expand mail alias before point."
(mh-alias-reload-maybe)
- (let* ((end (point))
- (begin (mh-beginning-of-word))
- (input (buffer-substring-no-properties begin end)))
- (mh-complete-word input mh-alias-alist begin end)
- (when mh-alias-expand-aliases-flag
- (let* ((end (point))
- (expansion (mh-alias-expand (buffer-substring begin end))))
- (delete-region begin end)
- (insert expansion)))))
-
+ (let* ((begin (mh-beginning-of-word))
+ (end (save-excursion
+ (goto-char begin)
+ (mh-beginning-of-word -1))))
+ (when (>= end (point))
+ (list
+ begin (if (fboundp 'completion-at-point) end (point))
+ (if (not mh-alias-expand-aliases-flag)
+ mh-alias-alist
+ (lambda (string pred action)
+ (case action
+ ((nil)
+ (let ((res (try-completion string mh-alias-alist pred)))
+ (if (or (eq res t)
+ (and (stringp res)
+ (eq t (try-completion res mh-alias-alist pred))))
+ (or (mh-alias-expand (if (stringp res) res string))
+ res)
+ res)))
+ ((t) (all-completions string mh-alias-alist pred))
+ ((lambda) (if (fboundp 'test-completion)
+ (test-completion string mh-alias-alist pred))))))))))
;;; Alias File Updating
@@ -670,5 +680,4 @@ show buffer, the message in the show buffer doesn't match."
;; sentence-end-double-space: nil
;; End:
-;; arch-tag: 49879e46-5aa3-4569-bece-e5a58731d690
;;; mh-alias.el ends here
diff --git a/lisp/mh-e/mh-buffers.el b/lisp/mh-e/mh-buffers.el
index d8666f6f8cb..48154cbf4e0 100644
--- a/lisp/mh-e/mh-buffers.el
+++ b/lisp/mh-e/mh-buffers.el
@@ -1,8 +1,6 @@
;;; mh-buffers.el --- MH-E buffer constants and utilities
-;; Copyright (C) 1993, 1995, 1997,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1995, 1997, 2000-2011 Free Software Foundation, Inc.
;; Author: Bill Wohler <wohler@newt.com>
;; Maintainer: Bill Wohler <wohler@newt.com>
@@ -83,5 +81,4 @@ The function returns the size of the final size of the log buffer."
;; sentence-end-double-space: nil
;; End:
-;; arch-tag: 812e9f29-78b8-4e73-ada9-aa61dc1ceecb
;;; mh-buffers.el ends here
diff --git a/lisp/mh-e/mh-comp.el b/lisp/mh-e/mh-comp.el
index 1ae6495168a..169679e88ae 100644
--- a/lisp/mh-e/mh-comp.el
+++ b/lisp/mh-e/mh-comp.el
@@ -1,8 +1,6 @@
;;; mh-comp.el --- MH-E functions for composing and sending messages
-;; Copyright (C) 1993, 1995, 1997,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1995, 1997, 2000-2011 Free Software Foundation, Inc.
;; Author: Bill Wohler <wohler@newt.com>
;; Maintainer: Bill Wohler <wohler@newt.com>
@@ -199,7 +197,8 @@ applications should use `mh-user-agent-compose'."
;;;###autoload
(defun mh-user-agent-compose (&optional to subject other-headers continue
switch-function yank-action
- send-actions)
+ send-actions return-action
+ &rest ignored)
"Set up mail composition draft with the MH mail system.
This is the `mail-user-agent' entry point to MH-E. This function
conforms to the contract specified by `define-mail-user-agent'
@@ -213,8 +212,8 @@ OTHER-HEADERS is an alist specifying additional header fields.
Elements look like (HEADER . VALUE) where both HEADER and VALUE
are strings.
-CONTINUE, SWITCH-FUNCTION, YANK-ACTION and SEND-ACTIONS are
-ignored."
+CONTINUE, SWITCH-FUNCTION, YANK-ACTION, SEND-ACTIONS, and
+RETURN-ACTION are ignored."
(mh-find-path)
(let ((mh-error-if-no-draft t))
(mh-send to "" subject)
@@ -905,6 +904,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)
@@ -1109,5 +1111,4 @@ doesn't exist there."
;; sentence-end-double-space: nil
;; End:
-;; arch-tag: 62865511-e610-4923-b0b5-f45a8ab70a34
;;; mh-comp.el ends here
diff --git a/lisp/mh-e/mh-compat.el b/lisp/mh-e/mh-compat.el
index 0ecd9ac6710..01a0f26b9e8 100644
--- a/lisp/mh-e/mh-compat.el
+++ b/lisp/mh-e/mh-compat.el
@@ -1,7 +1,6 @@
;;; mh-compat.el --- make MH-E compatibile with various versions of Emacs
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
;; Author: Bill Wohler <wohler@newt.com>
;; Maintainer: Bill Wohler <wohler@newt.com>
@@ -315,5 +314,4 @@ XEmacs."
;; sentence-end-double-space: nil
;; End:
-;; arch-tag: 577b0eab-a5cd-45e1-8d9f-c1a426f4d73c
;;; mh-compat.el ends here
diff --git a/lisp/mh-e/mh-e.el b/lisp/mh-e/mh-e.el
index 7cdaa6f15b5..ccae063827f 100644
--- a/lisp/mh-e/mh-e.el
+++ b/lisp/mh-e/mh-e.el
@@ -1,8 +1,6 @@
;;; mh-e.el --- GNU Emacs interface to the MH mail system
-;; Copyright (C) 1985, 1986, 1987, 1988,
-;; 1990, 1992, 1993, 1994, 1995, 1997, 1999,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+;; Copyright (C) 1985-1988, 1990, 1992-1995, 1997, 1999-2011
;; Free Software Foundation, Inc.
;; Author: Bill Wohler <wohler@newt.com>
@@ -287,8 +285,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.
@@ -1179,7 +1179,7 @@ lowercase for mailing lists and uppercase for people."
"*Non-nil means to expand aliases entered in the minibuffer.
In other words, aliases entered in the minibuffer will be
-expanded to the full address in the message draft. By default,
+expanded to the full address in the message draft. By default,
this expansion is not performed."
:type 'boolean
:group 'mh-alias
@@ -3725,5 +3725,4 @@ The background and foreground are used in the image."
;; sentence-end-double-space: nil
;; End:
-;; arch-tag: cce884de-bd37-4104-9963-e4439d5ed22b
;;; mh-e.el ends here
diff --git a/lisp/mh-e/mh-folder.el b/lisp/mh-e/mh-folder.el
index b225474a030..aab40c7be13 100644
--- a/lisp/mh-e/mh-folder.el
+++ b/lisp/mh-e/mh-folder.el
@@ -1,7 +1,6 @@
;;; mh-folder.el --- MH-Folder mode
-;; Copyright (C) 2002, 2003, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2003, 2005-2011 Free Software Foundation, Inc.
;; Author: Bill Wohler <wohler@newt.com>
;; Maintainer: Bill Wohler <wohler@newt.com>
@@ -1974,5 +1973,4 @@ If MSG is nil then act on the message at point"
;; sentence-end-double-space: nil
;; End:
-;; arch-tag: aa97b758-d4f6-4c86-bc5a-1950921da1e7
;;; mh-folder.el ends here
diff --git a/lisp/mh-e/mh-funcs.el b/lisp/mh-e/mh-funcs.el
index 188ac2d86dc..dfac684ed50 100644
--- a/lisp/mh-e/mh-funcs.el
+++ b/lisp/mh-e/mh-funcs.el
@@ -1,8 +1,6 @@
;;; mh-funcs.el --- MH-E functions not everyone will use right away
-;; Copyright (C) 1993, 1995,
-;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1995, 2001-2011 Free Software Foundation, Inc.
;; Author: Bill Wohler <wohler@newt.com>
;; Maintainer: Bill Wohler <wohler@newt.com>
@@ -288,7 +286,7 @@ to \"Directory\", and then enter the name of the directory for
storing the content of these messages."
(interactive (list (let ((udir (or mh-store-default-directory
default-directory)))
- (read-file-name "Store message in directory: "
+ (read-directory-name "Store message in directory: "
udir udir nil))))
(let ((msg-file-to-store (mh-msg-filename (mh-get-msg-num t))))
(with-current-buffer (get-buffer-create mh-temp-buffer)
@@ -302,7 +300,7 @@ storing the content of these messages."
See `mh-store-msg' for a description of DIRECTORY."
(interactive (list (let ((udir (or mh-store-default-directory
default-directory)))
- (read-file-name "Store buffer in directory: "
+ (read-directory-name "Store buffer in directory: "
udir udir nil))))
(let ((store-directory (expand-file-name directory))
(sh-start (save-excursion
@@ -351,8 +349,9 @@ See `mh-store-msg' for a description of DIRECTORY."
(error "Error occurred during execution of %s" command)))))
;;;###mh-autoload
-(defun mh-undo-folder ()
- "Undo all refiles and deletes in the current folder."
+(defun mh-undo-folder (&rest _ignored)
+ "Undo all refiles and deletes in the current folder.
+Arguments are IGNORED (for `revert-buffer')."
(interactive)
(cond ((or mh-do-not-confirm-flag
(yes-or-no-p "Undo all commands in folder? "))
@@ -372,5 +371,4 @@ See `mh-store-msg' for a description of DIRECTORY."
;; sentence-end-double-space: nil
;; End:
-;; arch-tag: 1936c4f1-4843-438e-bc4b-a63bb75a7762
;;; mh-funcs.el ends here
diff --git a/lisp/mh-e/mh-gnus.el b/lisp/mh-e/mh-gnus.el
index 23c2b038b4a..f644282fc82 100644
--- a/lisp/mh-e/mh-gnus.el
+++ b/lisp/mh-e/mh-gnus.el
@@ -1,7 +1,6 @@
;;; mh-gnus.el --- make MH-E compatible with various versions of Gnus
-;; Copyright (C) 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2003-2004, 2006-2011 Free Software Foundation, Inc.
;; Author: Satyaki Das <satyaki@theforce.stanford.edu>
;; Maintainer: Bill Wohler <wohler@newt.com>
@@ -177,5 +176,4 @@ PROMPT overrides the default one used to ask user for a file name."
;; sentence-end-double-space: nil
;; End:
-;; arch-tag: 1e3638af-cad3-4c69-8427-bc8eb6e5e4fa
;;; mh-gnus.el ends here
diff --git a/lisp/mh-e/mh-identity.el b/lisp/mh-e/mh-identity.el
index 1590feaabf5..7e8b8576ff1 100644
--- a/lisp/mh-e/mh-identity.el
+++ b/lisp/mh-e/mh-identity.el
@@ -1,7 +1,6 @@
;;; mh-identity.el --- multiple identify support for MH-E
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Peter S. Galbraith <psg@debian.org>
;; Maintainer: Bill Wohler <wohler@newt.com>
@@ -304,5 +303,4 @@ the header."
;; sentence-end-double-space: nil
;; End:
-;; arch-tag: 07d66ef6-8726-4ac6-9ecf-e566cd5bfb45
;;; mh-identity.el ends here
diff --git a/lisp/mh-e/mh-inc.el b/lisp/mh-e/mh-inc.el
index 6e3cff212e9..4f83ed70508 100644
--- a/lisp/mh-e/mh-inc.el
+++ b/lisp/mh-e/mh-inc.el
@@ -1,7 +1,6 @@
;;; mh-inc.el --- MH-E "inc" and separate mail spool handling
-;; Copyright (C) 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2003-2004, 2006-2011 Free Software Foundation, Inc.
;; Author: Peter S. Galbraith <psg@debian.org>
;; Maintainer: Bill Wohler <wohler@newt.com>
@@ -90,5 +89,4 @@
;; sentence-end-double-space: nil
;; End:
-;; arch-tag: 3713cf2a-6082-4cb4-8ce2-99d9acaba835
;;; mh-inc.el ends here
diff --git a/lisp/mh-e/mh-junk.el b/lisp/mh-e/mh-junk.el
index deb1c339a16..2ffc24e26e8 100644
--- a/lisp/mh-e/mh-junk.el
+++ b/lisp/mh-e/mh-junk.el
@@ -1,7 +1,6 @@
;;; mh-junk.el --- MH-E interface to anti-spam measures
-;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2003-2011 Free Software Foundation, Inc.
;; Author: Satyaki Das <satyaki@theforce.stanford.edu>,
;; Bill Wohler <wohler@newt.com>
@@ -467,5 +466,4 @@ See `mh-spamprobe-blacklist' for more information."
;; sentence-end-double-space: nil
;; End:
-;; arch-tag: 603335f1-77ff-4306-8828-5d3dad51abe1
;;; mh-junk.el ends here
diff --git a/lisp/mh-e/mh-letter.el b/lisp/mh-e/mh-letter.el
index 74635663b6b..2ced886c05e 100644
--- a/lisp/mh-e/mh-letter.el
+++ b/lisp/mh-e/mh-letter.el
@@ -1,8 +1,6 @@
;;; mh-letter.el --- MH-Letter mode
-;; Copyright (C) 1993, 1995, 1997,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1995, 1997, 2000-2011 Free Software Foundation, Inc.
;; Author: Bill Wohler <wohler@newt.com>
;; Maintainer: Bill Wohler <wohler@newt.com>
@@ -187,7 +185,7 @@ semi-obsolete and is only used if `mail-citation-hook' is nil.")
"\C-c\C-w" mh-check-whom
"\C-c\C-y" mh-yank-cur-msg
"\C-c\M-d" mh-insert-auto-fields
- "\M-\t" mh-letter-complete
+ "\M-\t" mh-letter-complete ;; FIXME: completion-at-point
"\t" mh-letter-next-header-field-or-indent
[backtab] mh-letter-previous-header-field)
@@ -348,6 +346,8 @@ order).
(define-key mh-letter-mode-map [menu-bar mail] 'undefined)
(mh-do-in-xemacs (easy-menu-remove mail-menubar-menu))
(setq fill-column mh-letter-fill-column)
+ (add-hook 'completion-at-point-functions
+ 'mh-letter-completion-at-point nil 'local)
;; If text-mode-hook turned on auto-fill, tune it for messages
(when auto-fill-function
(make-local-variable 'auto-fill-function)
@@ -490,24 +490,38 @@ In a program, you can pass in a signature FILE."
(message "No signature found")))))
(force-mode-line-update))
-(defun mh-letter-complete (arg)
- "Perform completion on header field or word preceding point.
+(defun mh-letter-completion-at-point ()
+ "Return the completion data at point for MH letters.
+This provides alias and folder completion in header fields according to
+`mh-letter-complete-function-alist' and falls back on
+`mh-letter-complete-function-alist' elsewhere."
+ (let ((func (and (mh-in-header-p)
+ (cdr (assoc (mh-letter-header-field-at-point)
+ mh-letter-complete-function-alist)))))
+ (if func
+ (or (funcall func) #'ignore)
+ mh-letter-complete-function)))
+
+(defalias 'mh-letter-complete
+ (if (fboundp 'completion-at-point) #'completion-at-point
+ (lambda ()
+ "Perform completion on header field or word preceding point.
If the field contains addresses (for example, \"To:\" or \"Cc:\")
or folders (for example, \"Fcc:\") then this command will provide
alias completion. In the body of the message, this command runs
`mh-letter-complete-function' instead, which is set to
-`ispell-complete-word' by default. This command takes a prefix
-argument ARG that is passed to the
-`mh-letter-complete-function'."
- (interactive "P")
- (let ((func nil))
- (cond ((not (mh-in-header-p))
- (funcall mh-letter-complete-function arg))
- ((setq func (cdr (assoc (mh-letter-header-field-at-point)
- mh-letter-complete-function-alist)))
- (funcall func))
- (t (funcall mh-letter-complete-function arg)))))
+`ispell-complete-word' by default."
+ (interactive)
+ (let ((data (mh-letter-completion-at-point)))
+ (cond
+ ((functionp data) (funcall data))
+ ((consp data)
+ (let ((start (nth 0 data))
+ (end (nth 1 data))
+ (table (nth 2 data)))
+ (mh-complete-word (buffer-substring-no-properties start end)
+ table start end))))))))
(defun mh-letter-complete-or-space (arg)
"Perform completion or insert space.
@@ -523,11 +537,12 @@ one space."
(mh-beginning-of-word -1))))
(cond ((not mh-compose-space-does-completion-flag)
(self-insert-command arg))
- ((not (mh-in-header-p)) (self-insert-command arg))
+ ;; FIXME: This > test is redundant now that all the completion
+ ;; functions do it anyway.
((> (point) end-of-prev) (self-insert-command arg))
- ((setq func (cdr (assoc (mh-letter-header-field-at-point)
- mh-letter-complete-function-alist)))
- (funcall func))
+ ((let ((mh-letter-complete-function nil))
+ (mh-letter-completion-at-point))
+ (mh-letter-complete))
(t (self-insert-command arg)))))
(defun mh-letter-confirm-address ()
@@ -864,18 +879,17 @@ downcasing the field name."
(defun mh-folder-expand-at-point ()
"Do folder name completion in Fcc header field."
- (let* ((end (point))
- (beg (mh-beginning-of-word))
- (folder (buffer-substring-no-properties beg end))
- (leading-plus (and (> (length folder) 0) (equal (aref folder 0) ?+)))
- (choices (mapcar (lambda (x) (list x))
- (mh-folder-completion-function folder nil t))))
- (unless leading-plus
- (setq folder (concat "+" folder)))
- (mh-complete-word folder choices beg end)))
+ (let* ((beg (mh-beginning-of-word))
+ (end (save-excursion
+ (goto-char beg)
+ (mh-beginning-of-word -1))))
+ (when (>= end (point))
+ (list beg (if (fboundp 'completion-at-point) end (point))
+ #'mh-folder-completion-function))))
;;;###mh-autoload
(defun mh-complete-word (word choices begin end)
+ ;; FIXME: Only needed when completion-at-point doesn't exist.
"Complete WORD from CHOICES.
Any match found replaces the text from BEGIN to END."
(let ((completion (try-completion word choices))
@@ -891,8 +905,16 @@ Any match found replaces the text from BEGIN to END."
((stringp completion)
(if (equal word completion)
(with-output-to-temp-buffer completions-buffer
- (mh-display-completion-list (all-completions word choices)
- word))
+ (mh-display-completion-list
+ (all-completions word choices)
+ ;; The `common-subtring' arg only works if it's a prefix.
+ (unless (and (functionp choices)
+ (let ((bounds
+ (funcall choices
+ word nil '(boundaries . ""))))
+ (and (eq 'boundaries (car-safe bounds))
+ (< 0 (cadr bounds)))))
+ word)))
(ignore-errors
(kill-buffer completions-buffer))
(delete-region begin end)
@@ -960,5 +982,4 @@ Otherwise, simply insert MH-INS-STRING before each line."
;; sentence-end-double-space: nil
;; End:
-;; arch-tag: 0548632c-aadb-4e3b-bb80-bbd62ff90bf3
;;; mh-letter.el ends here
diff --git a/lisp/mh-e/mh-limit.el b/lisp/mh-e/mh-limit.el
index 62606211bfd..db17b05ef37 100644
--- a/lisp/mh-e/mh-limit.el
+++ b/lisp/mh-e/mh-limit.el
@@ -1,7 +1,6 @@
;;; mh-limit.el --- MH-E display limits
-;; Copyright (C) 2001, 2002, 2003, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001-2003, 2006-2011 Free Software Foundation, Inc.
;; Author: Peter S. Galbraith <psg@debian.org>
;; Maintainer: Bill Wohler <wohler@newt.com>
@@ -334,5 +333,4 @@ The MH command pick is used to do the match."
;; sentence-end-double-space: nil
;; End:
-;; arch-tag: b0d24378-1234-4c42-aa3f-7abad25b40a1
;;; mh-limit.el ends here
diff --git a/lisp/mh-e/mh-mime.el b/lisp/mh-e/mh-mime.el
index 3ae274277b5..ba994e73a91 100644
--- a/lisp/mh-e/mh-mime.el
+++ b/lisp/mh-e/mh-mime.el
@@ -1,8 +1,6 @@
;;; mh-mime.el --- MH-E MIME support
-;; Copyright (C) 1993, 1995,
-;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1995, 2001-2011 Free Software Foundation, Inc.
;; Author: Bill Wohler <wohler@newt.com>
;; Maintainer: Bill Wohler <wohler@newt.com>
@@ -392,11 +390,11 @@ do the work."
(equal nil mh-mime-save-parts-default-directory)
(equal t mh-mime-save-parts-default-directory))
(not mh-mime-save-parts-directory))
- (read-file-name "Store in directory: " nil nil t nil))
+ (read-directory-name "Store in directory: " nil nil t))
((and (or prompt
(equal t mh-mime-save-parts-default-directory))
mh-mime-save-parts-directory)
- (read-file-name (format
+ (read-directory-name (format
"Store in directory (default %s): "
mh-mime-save-parts-directory)
"" mh-mime-save-parts-directory t ""))
@@ -508,6 +506,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 +835,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 +1833,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-print.el b/lisp/mh-e/mh-print.el
index bc73c32e0f7..bd99245efe6 100644
--- a/lisp/mh-e/mh-print.el
+++ b/lisp/mh-e/mh-print.el
@@ -1,7 +1,6 @@
;;; mh-print.el --- MH-E printing support
-;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2003-2011 Free Software Foundation, Inc.
;; Author: Jeffrey C Honig <jch@honig.net>
;; Maintainer: Bill Wohler <wohler@newt.com>
@@ -248,5 +247,4 @@ Consider using \\[mh-ps-print-msg] instead."
;; sentence-end-double-space: nil
;; End:
-;; arch-tag: 8d84d50b-2a49-4d0d-b51e-ba9c9b6fc679
;;; mh-print.el ends here
diff --git a/lisp/mh-e/mh-scan.el b/lisp/mh-e/mh-scan.el
index 8f9bcd53cda..8a3e1632e2e 100644
--- a/lisp/mh-e/mh-scan.el
+++ b/lisp/mh-e/mh-scan.el
@@ -1,8 +1,6 @@
;;; mh-scan.el --- MH-E scan line constants and utilities
-;; Copyright (C) 1993, 1995, 1997,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1995, 1997, 2000-2011 Free Software Foundation, Inc.
;; Author: Bill Wohler <wohler@newt.com>
;; Maintainer: Bill Wohler <wohler@newt.com>
@@ -310,7 +308,7 @@ This column will have one of \" \", \"%\", \"-\", \"t\", \"c\", \"b\", or \"n\"
in it.
\" \" blank space is the default character.
- \"%\" indicates that the message in in a named MH sequence.
+ \"%\" indicates that the message in a named MH sequence.
\"-\" indicates that the message has been annotated with a replied field.
\"t\" indicates that the message contains mymbox in the To: field.
\"c\" indicates that the message contains mymbox in the Cc: field.
@@ -485,5 +483,4 @@ comes after that."
;; sentence-end-double-space: nil
;; End:
-;; arch-tag: 5ab35d46-101e-443b-a2b6-5a908cf97528
;;; mh-scan.el ends here
diff --git a/lisp/mh-e/mh-search.el b/lisp/mh-e/mh-search.el
index 6da4e322fe5..a90a26ab2a4 100644
--- a/lisp/mh-e/mh-search.el
+++ b/lisp/mh-e/mh-search.el
@@ -1,8 +1,6 @@
;;; mh-search --- MH-Search mode
-;; Copyright (C) 1993, 1995,
-;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1995, 2001-2011 Free Software Foundation, Inc.
;; Author: Indexed search by Satyaki Das <satyaki@theforce.stanford.edu>
;; Maintainer: Bill Wohler <wohler@newt.com>
@@ -1511,7 +1509,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)
@@ -1931,5 +1929,4 @@ folder buffer."
;; sentence-end-double-space: nil
;; End:
-;; arch-tag: 607762ad-0dff-4fe1-a27e-6c0dde0dcc47
;;; mh-search ends here
diff --git a/lisp/mh-e/mh-seq.el b/lisp/mh-e/mh-seq.el
index 6c8a0e91359..145b689c6b9 100644
--- a/lisp/mh-e/mh-seq.el
+++ b/lisp/mh-e/mh-seq.el
@@ -1,8 +1,6 @@
;;; mh-seq.el --- MH-E sequences support
-;; Copyright (C) 1993, 1995,
-;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1995, 2001-2011 Free Software Foundation, Inc.
;; Author: Bill Wohler <wohler@newt.com>
;; Maintainer: Bill Wohler <wohler@newt.com>
@@ -819,7 +817,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 +1015,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 4b866d5ccfc..5c2f08cefe5 100644
--- a/lisp/mh-e/mh-show.el
+++ b/lisp/mh-e/mh-show.el
@@ -1,8 +1,6 @@
;;; mh-show.el --- MH-Show mode
-;; Copyright (C) 1993, 1995, 1997,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1995, 1997, 2000-2011 Free Software Foundation, Inc.
;; Author: Bill Wohler <wohler@newt.com>
;; Maintainer: Bill Wohler <wohler@newt.com>
@@ -170,16 +168,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))
@@ -927,5 +915,4 @@ See also `mh-folder-mode'.
;; sentence-end-double-space: nil
;; End:
-;; arch-tag: 8607a80a-9b5c-43a7-a25d-d7e4a848c25b
;;; mh-show.el ends here
diff --git a/lisp/mh-e/mh-speed.el b/lisp/mh-e/mh-speed.el
index 8782671c95d..b782081c85c 100644
--- a/lisp/mh-e/mh-speed.el
+++ b/lisp/mh-e/mh-speed.el
@@ -1,7 +1,6 @@
;;; mh-speed.el --- MH-E speedbar support
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Satyaki Das <satyaki@theforce.stanford.edu>
;; Maintainer: Bill Wohler <wohler@newt.com>
@@ -581,5 +580,4 @@ The function invalidates the latest ancestor that is present."
;; sentence-end-double-space: nil
;; End:
-;; arch-tag: d38ddcd4-3c00-4e37-99bf-8b89dda7b32c
;;; mh-speed.el ends here
diff --git a/lisp/mh-e/mh-thread.el b/lisp/mh-e/mh-thread.el
index f172d450132..c6f33a15fd2 100644
--- a/lisp/mh-e/mh-thread.el
+++ b/lisp/mh-e/mh-thread.el
@@ -1,7 +1,6 @@
;;; mh-thread.el --- MH-E threading support
-;; Copyright (C) 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2004, 2006-2011 Free Software Foundation, Inc.
;; Author: Satyaki Das <satyaki@theforce.stanford.edu>
;; Maintainer: Bill Wohler <wohler@newt.com>
@@ -880,5 +879,4 @@ This function can only be used the folder is threaded."
;; sentence-end-double-space: nil
;; End:
-;; arch-tag: b10e62f5-f028-4e04-873e-89d0e069b3d5
;;; mh-thread.el ends here
diff --git a/lisp/mh-e/mh-tool-bar.el b/lisp/mh-e/mh-tool-bar.el
index f51c97e4e67..ddc9b3ffe94 100644
--- a/lisp/mh-e/mh-tool-bar.el
+++ b/lisp/mh-e/mh-tool-bar.el
@@ -1,7 +1,6 @@
;;; mh-tool-bar.el --- MH-E tool bar support
-;; Copyright (C) 2002, 2003, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2003, 2005-2011 Free Software Foundation, Inc.
;; Author: Satyaki Das <satyaki@theforce.stanford.edu>
;; Maintainer: Bill Wohler <wohler@newt.com>
@@ -465,5 +464,4 @@ This button runs `mh-widen'"))
;; sentence-end-double-space: nil
;; End:
-;; arch-tag: 28c2436d-bb8d-486a-a8d7-5a4d9cae3513
;;; mh-tool-bar.el ends here
diff --git a/lisp/mh-e/mh-utils.el b/lisp/mh-e/mh-utils.el
index 2ac6d2faad4..4394e1b1b22 100644
--- a/lisp/mh-e/mh-utils.el
+++ b/lisp/mh-e/mh-utils.el
@@ -1,8 +1,6 @@
;;; mh-utils.el --- MH-E general utilities
-;; Copyright (C) 1993, 1995, 1997,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1995, 1997, 2000-2011 Free Software Foundation, Inc.
;; Author: Bill Wohler <wohler@newt.com>
;; Maintainer: Bill Wohler <wohler@newt.com>
@@ -598,6 +596,7 @@ Expects FOLDER to have already been normalized with
(setq name (substring name 0 (1- (length name)))))
(push
(cons name
+ ;; FIXME: what is this used for? --Stef
(search-forward "(others)" (mh-line-end-position) t))
results))))
(forward-line 1))))
@@ -704,32 +703,33 @@ See Info node `(elisp) Programmed Completion' for details."
(remainder (cond (last-complete (substring name (1+ last-slash)))
(name (substring name 1))
(t ""))))
- (cond ((eq flag nil)
+ (cond ((eq (car-safe flag) 'boundaries)
+ (list* 'boundaries
+ (let ((slash (mh-search-from-end ?/ orig-name)))
+ (if slash (1+ slash)
+ (if (string-match "\\`\\+" orig-name) 1 0)))
+ (if (cdr flag) (string-match "/" (cdr flag)))))
+ ((eq flag nil)
(let ((try-res
(try-completion
- name
- (mapcar (lambda (x)
- (cons (concat (or last-complete "+") (car x))
- (cdr x)))
- (mh-sub-folders last-complete t))
+ remainder
+ (mh-sub-folders last-complete t)
predicate)))
(cond ((eq try-res nil) nil)
((and (eq try-res t) (equal name orig-name)) t)
((eq try-res t) name)
- (t try-res))))
+ (t (concat (or last-complete "+") try-res)))))
((eq flag t)
- (mapcar (lambda (x)
- (concat (or last-complete "+") x))
- (all-completions
- remainder (mh-sub-folders last-complete t) predicate)))
+ (all-completions
+ remainder (mh-sub-folders last-complete t) predicate))
((eq flag 'lambda)
(let ((path (concat (unless (and (> (length name) 1)
(eq (aref name 1) ?/))
mh-user-path)
(substring name 1))))
- (cond (mh-allow-root-folder-flag (file-exists-p path))
+ (cond (mh-allow-root-folder-flag (file-directory-p path))
((equal path mh-user-path) nil)
- (t (file-exists-p path))))))))
+ (t (file-directory-p path))))))))
;; Shush compiler.
(defvar completion-root-regexp) ; XEmacs
@@ -1013,5 +1013,4 @@ If the current line is too long truncate a part of it as well."
;; sentence-end-double-space: nil
;; End:
-;; arch-tag: 1af39fdf-f66f-4b06-9b48-18a7656c8e36
;;; mh-utils.el ends here
diff --git a/lisp/mh-e/mh-xface.el b/lisp/mh-e/mh-xface.el
index 5229f95f5d6..027d79a948a 100644
--- a/lisp/mh-e/mh-xface.el
+++ b/lisp/mh-e/mh-xface.el
@@ -1,7 +1,6 @@
;;; mh-xface.el --- MH-E X-Face and Face header field display
-;; Copyright (C) 2002, 2003, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2003, 2005-2011 Free Software Foundation, Inc.
;; Author: Bill Wohler <wohler@newt.com>
;; Maintainer: Bill Wohler <wohler@newt.com>
@@ -471,5 +470,4 @@ The argument CHANGE is ignored."
;; sentence-end-double-space: nil
;; End:
-;; arch-tag: a79dd33f-d0e5-4b19-a53a-be690f90229a
;;; mh-xface.el ends here
diff --git a/lisp/midnight.el b/lisp/midnight.el
index ef4d0dd1136..762bc5445ba 100644
--- a/lisp/midnight.el
+++ b/lisp/midnight.el
@@ -1,10 +1,9 @@
;;; midnight.el --- run something every midnight, e.g., kill old buffers
-;; Copyright (C) 1998, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 2001-2011 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
@@ -40,8 +39,6 @@
(eval-when-compile
(require 'cl))
-(require 'timer)
-
(defgroup midnight nil
"Run something every day at midnight."
:group 'calendar
@@ -67,12 +64,6 @@ call `cancel-timer' or `timer-activate' on `midnight-timer' instead."
;;; time conversion
-(defun midnight-time-float (num)
- "Convert the float number of seconds since epoch to the list of 3 integers."
- (let* ((div (ash 1 16)) (1st (floor num div)))
- (list 1st (floor (- num (* (float div) 1st)))
- (round (* 10000000 (mod num 1))))))
-
(defun midnight-buffer-display-time (&optional buffer)
"Return the time-stamp of BUFFER, or current buffer, as float."
(with-current-buffer (or buffer (current-buffer))
@@ -126,7 +117,7 @@ See also `clean-buffer-list-kill-regexps',
:group 'midnight)
(defcustom clean-buffer-list-kill-never-buffer-names
- '("*scratch*" "*Messages*" "*server*")
+ '("*scratch*" "*Messages*")
"List of buffer names which will never be killed by `clean-buffer-list'.
See also `clean-buffer-list-kill-never-regexps'.
Note that this does override `clean-buffer-list-kill-regexps' and
@@ -205,7 +196,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)))
@@ -234,5 +225,4 @@ first argument to `run-at-time'."
(provide 'midnight)
-;; arch-tag: a5979be9-2890-46a3-ba84-791f0a4a6e80
;;; midnight.el ends here
diff --git a/lisp/minibuf-eldef.el b/lisp/minibuf-eldef.el
index 50e90c1e067..e6ebe3c53f1 100644
--- a/lisp/minibuf-eldef.el
+++ b/lisp/minibuf-eldef.el
@@ -1,7 +1,6 @@
;;; minibuf-eldef.el --- Only show defaults in prompts when applicable
;;
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;;
;; Author: Miles Bader <miles@gnu.org>
;; Keywords: convenience
@@ -156,5 +155,4 @@ Returns non-nil if the new state is enabled."
(provide 'minibuf-eldef)
-;; arch-tag: 7e421fae-c275-4729-b0da-7836af377d3d
;;; minibuf-eldef.el ends here
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index adbb9a6c539..41399f3f141 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -1,8 +1,9 @@
-;;; minibuffer.el --- Minibuffer completion functions
+;;; minibuffer.el --- Minibuffer completion functions -*- lexical-binding: t -*-
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -57,6 +58,12 @@
;;; Todo:
+;; - Make things like icomplete-mode or lightning-completion work with
+;; completion-in-region-mode.
+;; - completion-insert-complete-hook (called after inserting a complete
+;; completion), typically used for "complete-abbrev" where it would expand
+;; the abbrev. Tho we'd probably want to provide it from the
+;; completion-table.
;; - extend `boundaries' to provide various other meta-data about the
;; output of `all-completions':
;; - preferred sorting order when displayed in *Completions*.
@@ -76,6 +83,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.
@@ -129,8 +139,8 @@ the closest directory separators."
"Apply FUN to each element of XS in turn.
Return the first non-nil returned value.
Like CL's `some'."
- (lexical-let ((firsterror nil)
- res)
+ (let ((firsterror nil)
+ res)
(while (and (not res) xs)
(condition-case err
(setq res (funcall fun (pop xs)))
@@ -167,8 +177,11 @@ FUN will be called in the buffer from which the minibuffer was entered.
The result of the `completion-table-dynamic' form is a function
that can be used as the COLLECTION argument to `try-completion' and
`all-completions'. See Info node `(elisp)Programmed Completion'."
- (lexical-let ((fun fun))
- (lambda (string pred action)
+ (lambda (string pred action)
+ (if (eq (car-safe action) 'boundaries)
+ ;; `fun' is not supposed to return another function but a plain old
+ ;; completion table, whose boundaries are always trivial.
+ nil
(with-current-buffer (let ((win (minibuffer-selected-window)))
(if (window-live-p win) (window-buffer win)
(current-buffer)))
@@ -192,24 +205,27 @@ You should give VAR a non-nil `risky-local-variable' property."
(setq ,var (,fun)))
,var))))
+(defun completion-table-case-fold (table string pred action)
+ (let ((completion-ignore-case t))
+ (complete-with-action action table string pred)))
+
(defun completion-table-with-context (prefix table string pred action)
;; TODO: add `suffix' maybe?
;; Notice that `pred' may not be a function in some abusive cases.
(when (functionp pred)
(setq pred
- (lexical-let ((pred pred))
- ;; Predicates are called differently depending on the nature of
- ;; the completion table :-(
- (cond
- ((vectorp table) ;Obarray.
- (lambda (sym) (funcall pred (concat prefix (symbol-name sym)))))
- ((hash-table-p table)
- (lambda (s v) (funcall pred (concat prefix s))))
- ((functionp table)
- (lambda (s) (funcall pred (concat prefix s))))
- (t ;Lists and alists.
- (lambda (s)
- (funcall pred (concat prefix (if (consp s) (car s) s)))))))))
+ ;; Predicates are called differently depending on the nature of
+ ;; the completion table :-(
+ (cond
+ ((vectorp table) ;Obarray.
+ (lambda (sym) (funcall pred (concat prefix (symbol-name sym)))))
+ ((hash-table-p table)
+ (lambda (s _v) (funcall pred (concat prefix s))))
+ ((functionp table)
+ (lambda (s) (funcall pred (concat prefix s))))
+ (t ;Lists and alists.
+ (lambda (s)
+ (funcall pred (concat prefix (if (consp s) (car s) s))))))))
(if (eq (car-safe action) 'boundaries)
(let* ((len (length prefix))
(bound (completion-boundaries string table pred (cdr action))))
@@ -231,29 +247,41 @@ TERMINATOR can also be a cons cell (TERMINATOR . TERMINATOR-REGEXP)
in which case TERMINATOR-REGEXP is a regular expression whose submatch
number 1 should match TERMINATOR. This is used when there is a need to
distinguish occurrences of the TERMINATOR strings which are really terminators
-from others (e.g. escaped)."
+from others (e.g. escaped). In this form, the car of TERMINATOR can also be,
+instead of a string, a function that takes the completion and returns the
+\"terminated\" string."
+ ;; FIXME: This implementation is not right since it only adds the terminator
+ ;; in try-completion, so any completion-style that builds the completion via
+ ;; all-completions won't get the terminator, and selecting an entry in
+ ;; *Completions* won't get the terminator added either.
(cond
((eq (car-safe action) 'boundaries)
(let* ((suffix (cdr action))
(bounds (completion-boundaries string table pred suffix))
(terminator-regexp (if (consp terminator)
(cdr terminator) (regexp-quote terminator)))
- (max (string-match terminator-regexp suffix)))
+ (max (and terminator-regexp
+ (string-match terminator-regexp suffix))))
(list* 'boundaries (car bounds)
(min (cdr bounds) (or max (length suffix))))))
((eq action nil)
(let ((comp (try-completion string table pred)))
(if (consp terminator) (setq terminator (car terminator)))
(if (eq comp t)
- (concat string terminator)
- (if (and (stringp comp)
- ;; FIXME: Try to avoid this second call, especially since
+ (if (functionp terminator)
+ (funcall terminator string)
+ (concat string terminator))
+ (if (and (stringp comp) (not (zerop (length comp)))
+ ;; Try to avoid the second call to try-completion, since
;; it may be very inefficient (because `comp' made us
;; jump to a new boundary, so we complete in that
;; boundary with an empty start string).
- ;; completion-boundaries might help.
+ (let ((newbounds (completion-boundaries comp table pred "")))
+ (< (car newbounds) (length comp)))
(eq (try-completion comp table pred) t))
- (concat comp terminator)
+ (if (functionp terminator)
+ (funcall terminator comp)
+ (concat comp terminator))
comp))))
((eq action t)
;; FIXME: We generally want the `try' and `all' behaviors to be
@@ -284,11 +312,10 @@ Note: TABLE needs to be a proper completion table which obeys predicates."
(t
(or (complete-with-action action table string
(if (null pred2) pred1
- (lexical-let ((pred1 pred2) (pred2 pred2))
- (lambda (x)
- ;; Call `pred1' first, so that `pred2'
- ;; really can't tell that `x' is in table.
- (if (funcall pred1 x) (funcall pred2 x))))))
+ (lambda (x)
+ ;; Call `pred1' first, so that `pred2'
+ ;; really can't tell that `x' is in table.
+ (if (funcall pred1 x) (funcall pred2 x)))))
;; If completion failed and we're not applying pred1 strictly, try
;; again without pred1.
(and (not strict)
@@ -298,11 +325,10 @@ Note: TABLE needs to be a proper completion table which obeys predicates."
"Create a completion table that tries each table in TABLES in turn."
;; FIXME: the boundaries may come from TABLE1 even when the completion list
;; is returned by TABLE2 (because TABLE1 returned an empty list).
- (lexical-let ((tables tables))
- (lambda (string pred action)
- (completion--some (lambda (table)
- (complete-with-action action table string pred))
- tables))))
+ (lambda (string pred action)
+ (completion--some (lambda (table)
+ (complete-with-action action table string pred))
+ tables)))
;; (defmacro complete-in-turn (a b) `(completion-table-in-turn ,a ,b))
;; (defmacro dynamic-completion-table (fun) `(completion-table-dynamic ,fun))
@@ -369,6 +395,9 @@ If the current buffer is not a minibuffer, erase its entire contents."
;; is on, the field doesn't cover the entire minibuffer contents.
(delete-region (minibuffer-prompt-end) (point-max)))
+(defvar completion-show-inline-help t
+ "If non-nil, print helpful inline messages during completion.")
+
(defcustom completion-auto-help t
"Non-nil means automatically provide help for invalid completion input.
If the value is t the *Completion* buffer is displayed whenever completion
@@ -407,6 +436,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 +539,29 @@ 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--message (msg)
+ (if completion-show-inline-help
+ (minibuffer-message msg)))
+
(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.
@@ -519,35 +577,36 @@ E = after completion we now have an Exact match.
101 5 ??? impossible
110 6 some completion happened
111 7 completed to an exact completion"
- (lexical-let*
- ((beg (field-beginning))
- (end (field-end))
- (string (buffer-substring beg end))
- (comp (funcall (or try-completion-function
- 'completion-try-completion)
- string
- minibuffer-completion-table
- minibuffer-completion-predicate
- (- (point) beg))))
+ (let* ((beg (field-beginning))
+ (end (field-end))
+ (string (buffer-substring beg end))
+ (comp (funcall (or try-completion-function
+ 'completion-try-completion)
+ string
+ minibuffer-completion-table
+ minibuffer-completion-predicate
+ (- (point) beg))))
(cond
((null comp)
(minibuffer-hide-completions)
- (ding) (minibuffer-message "No match") (minibuffer--bitset nil nil nil))
+ (unless completion-fail-discreetly
+ (ding)
+ (completion--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,
;; for appearance, the string is rewritten if the case changes.
- (lexical-let*
- ((comp-pos (cdr comp))
- (completion (car comp))
- (completed (not (eq t (compare-strings completion nil nil
- string nil nil t))))
- (unchanged (eq t (compare-strings completion nil nil
- string nil nil nil))))
+ (let* ((comp-pos (cdr comp))
+ (completion (car comp))
+ (completed (not (eq t (compare-strings completion nil nil
+ string nil nil t))))
+ (unchanged (eq t (compare-strings completion nil nil
+ string nil nil nil))))
(if unchanged
(goto-char end)
;; Insert in minibuffer the chars we got.
@@ -556,35 +615,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 (cond (icomplete-mode t)
- ((eq 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)
+ (completion--message "Next char not unique")))
+ ;; If the last exact completion and this one were the same, it
+ ;; means we've already given a "Complete, but 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))))))))
@@ -598,32 +684,37 @@ 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))
- ;; If there's a fresh completion window with a live buffer,
- ;; and this command is repeated, scroll that window.
- (if (window-live-p 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)
+ (cond
+ ;; If there's a fresh completion window with a live buffer,
+ ;; and this command is repeated, scroll that 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)))
+ ;; 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")
+ (#b001 (completion--message "Sole completion")
t)
- (#b011 (minibuffer-message "Complete, but not unique")
+ (#b011 (completion--message "Complete, but not unique")
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)
+(defun completion--flush-all-sorted-completions (&rest _ignore)
+ (remove-hook 'after-change-functions
+ 'completion--flush-all-sorted-completions t)
+ (setq completion-cycling nil)
(setq completion-all-sorted-completions nil))
(defun completion-all-sorted-completions ()
@@ -639,8 +730,18 @@ scroll the window of possible completions."
(when last
(setcdr last nil)
;; Prefer shorter completions.
- (setq all (sort all (lambda (c1 c2) (< (length c1) (length c2)))))
+ (setq all (sort all (lambda (c1 c2)
+ (let ((s1 (get-text-property
+ 0 :completion-cycle-penalty c1))
+ (s2 (get-text-property
+ 0 :completion-cycle-penalty c2)))
+ (if (eq s1 s2)
+ (< (length c1) (length c2))
+ (< (or s1 (length c1))
+ (or s2 (length c2))))))))
;; Prefer recently used completions.
+ ;; FIXME: Additional sorting ideas:
+ ;; - for M-x, prefer commands that have no key binding.
(let ((hist (symbol-value minibuffer-history-variable)))
(setq all (sort all (lambda (c1 c2)
(> (length (member c1 hist))
@@ -664,7 +765,9 @@ Repeated uses step through the possible completions."
(end (field-end))
(all (completion-all-sorted-completions)))
(if (not (consp all))
- (minibuffer-message (if all "No more completions" "No completions"))
+ (completion--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)
@@ -697,8 +800,8 @@ If `minibuffer-completion-confirm' is `confirm-after-completion',
`minibuffer-confirm-exit-commands', and accept the input
otherwise."
(interactive)
- (lexical-let ((beg (field-beginning))
- (end (field-end)))
+ (let ((beg (field-beginning))
+ (end (field-end)))
(cond
;; Allow user to specify null string
((= beg end) (exit-minibuffer))
@@ -851,22 +954,22 @@ Return nil if there is no valid completion, else t."
(interactive)
(case (completion--do-completion 'completion--try-word-completion)
(#b000 nil)
- (#b001 (minibuffer-message "Sole completion")
+ (#b001 (completion--message "Sole completion")
t)
- (#b011 (minibuffer-message "Complete, but not unique")
+ (#b011 (completion--message "Complete, but not unique")
t)
(t 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")
@@ -932,8 +1035,8 @@ It also eliminates runs of equal strings."
;; a space displayed.
(set-text-properties (- (point) 1) (point)
;; We can't just set tab-width, because
- ;; completion-setup-function will kill all
- ;; local variables :-(
+ ;; completion-setup-function will kill
+ ;; all local variables :-(
`(display (space :align-to ,column)))
nil))))
(if (not (consp str))
@@ -943,7 +1046,7 @@ It also eliminates runs of equal strings."
'mouse-face 'highlight)
(add-text-properties (point) (progn (insert (cadr str)) (point))
'(mouse-face nil
- face completions-annotations)))
+ face completions-annotations)))
(cond
((eq completions-format 'vertical)
;; Vertical format
@@ -1075,14 +1178,14 @@ variables.")
"Display a list of possible completions of the current minibuffer contents."
(interactive)
(message "Making completion list...")
- (lexical-let* ((start (field-beginning))
- (end (field-end))
- (string (field-string))
- (completions (completion-all-completions
- string
- minibuffer-completion-table
- minibuffer-completion-predicate
- (- (point) (field-beginning)))))
+ (let* ((start (field-beginning))
+ (end (field-end))
+ (string (field-string))
+ (completions (completion-all-completions
+ string
+ minibuffer-completion-table
+ minibuffer-completion-predicate
+ (- (point) (field-beginning)))))
(message nil)
(if (and completions
(or (consp (cdr completions))
@@ -1161,25 +1264,101 @@ the ones passed to `completion-in-region'. The functions on this hook
are expected to perform completion on START..END using COLLECTION
and PREDICATE, either by calling NEXT-FUN or by doing it themselves.")
+(defvar completion-in-region--data nil)
+
+(defvar completion-in-region-mode-predicate nil
+ "Predicate to tell `completion-in-region-mode' when to exit.
+It is called with no argument and should return nil when
+`completion-in-region-mode' should exit (and hence pop down
+the *Completions* buffer).")
+
+(defvar completion-in-region-mode--predicate nil
+ "Copy of the value of `completion-in-region-mode-predicate'.
+This holds the value `completion-in-region-mode-predicate' had when
+we entered `completion-in-region-mode'.")
+
(defun completion-in-region (start end collection &optional predicate)
"Complete the text between START and END using COLLECTION.
Return nil if there is no valid completion, else t.
Point needs to be somewhere between START and END."
(assert (<= start (point)) (<= (point) end))
- ;; FIXME: undisplay the *Completions* buffer once the completion is done.
(with-wrapper-hook
+ ;; FIXME: Maybe we should use this hook to provide a "display
+ ;; completions" operation as well.
completion-in-region-functions (start end collection predicate)
(let ((minibuffer-completion-table collection)
(minibuffer-completion-predicate predicate)
(ol (make-overlay start end nil nil t)))
(overlay-put ol 'field 'completion)
+ (when completion-in-region-mode-predicate
+ (completion-in-region-mode 1)
+ (setq completion-in-region--data
+ (list (current-buffer) start end collection)))
(unwind-protect
(call-interactively 'minibuffer-complete)
(delete-overlay ol)))))
-(defvar completion-at-point-functions nil
+(defvar completion-in-region-mode-map
+ (let ((map (make-sparse-keymap)))
+ ;; FIXME: Only works if completion-in-region-mode was activated via
+ ;; completion-at-point called directly.
+ (define-key map "?" 'completion-help-at-point)
+ (define-key map "\t" 'completion-at-point)
+ map)
+ "Keymap activated during `completion-in-region'.")
+
+;; It is difficult to know when to exit completion-in-region-mode (i.e. hide
+;; the *Completions*).
+;; - lisp-mode: never.
+;; - comint: only do it if you hit SPC at the right time.
+;; - pcomplete: pop it down on SPC or after some time-delay.
+;; - semantic: use a post-command-hook check similar to this one.
+(defun completion-in-region--postch ()
+ (or unread-command-events ;Don't pop down the completions in the middle of
+ ;mouse-drag-region/mouse-set-point.
+ (and completion-in-region--data
+ (and (eq (car completion-in-region--data)
+ (current-buffer))
+ (>= (point) (nth 1 completion-in-region--data))
+ (<= (point)
+ (save-excursion
+ (goto-char (nth 2 completion-in-region--data))
+ (line-end-position)))
+ (funcall completion-in-region-mode--predicate)))
+ (completion-in-region-mode -1)))
+
+;; (defalias 'completion-in-region--prech 'completion-in-region--postch)
+
+(define-minor-mode completion-in-region-mode
+ "Transient minor mode used during `completion-in-region'."
+ :global t
+ (setq completion-in-region--data nil)
+ ;; (remove-hook 'pre-command-hook #'completion-in-region--prech)
+ (remove-hook 'post-command-hook #'completion-in-region--postch)
+ (setq minor-mode-overriding-map-alist
+ (delq (assq 'completion-in-region-mode minor-mode-overriding-map-alist)
+ minor-mode-overriding-map-alist))
+ (if (null completion-in-region-mode)
+ (unless (equal "*Completions*" (buffer-name (window-buffer)))
+ (minibuffer-hide-completions))
+ ;; (add-hook 'pre-command-hook #'completion-in-region--prech)
+ (assert completion-in-region-mode-predicate)
+ (setq completion-in-region-mode--predicate
+ completion-in-region-mode-predicate)
+ (add-hook 'post-command-hook #'completion-in-region--postch)
+ (push `(completion-in-region-mode . ,completion-in-region-mode-map)
+ minor-mode-overriding-map-alist)))
+
+;; Define-minor-mode added our keymap to minor-mode-map-alist, but we want it
+;; on minor-mode-overriding-map-alist instead.
+(setq minor-mode-map-alist
+ (delq (assq 'completion-in-region-mode minor-mode-map-alist)
+ minor-mode-map-alist))
+
+(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,
+Each function on this hook is called in turns without any argument and should
+return either nil to mean that it is not applicable at point,
or a function of no argument to perform completion (discouraged),
or a list of the form (START END COLLECTION &rest PROPS) where
START and END delimit the entity to complete and should include point,
@@ -1189,24 +1368,90 @@ Currently supported properties are:
`:predicate' a predicate that completion candidates need to satisfy.
`:annotation-function' the value to use for `completion-annotate-function'.")
+(defvar completion--capf-misbehave-funs nil
+ "List of functions found on `completion-at-point-functions' that misbehave.")
+(defvar completion--capf-safe-funs nil
+ "List of well-behaved functions found on `completion-at-point-functions'.")
+
+(defun completion--capf-wrapper (fun which)
+ ;; FIXME: The safe/misbehave handling assumes that a given function will
+ ;; always return the same kind of data, but this breaks down with functions
+ ;; like comint-completion-at-point or mh-letter-completion-at-point, which
+ ;; could be sometimes safe and sometimes misbehaving (and sometimes neither).
+ (if (case which
+ (all t)
+ (safe (member fun completion--capf-safe-funs))
+ (optimist (not (member fun completion--capf-misbehave-funs))))
+ (let ((res (funcall fun)))
+ (cond
+ ((consp res)
+ (unless (member fun completion--capf-safe-funs)
+ (push fun completion--capf-safe-funs)))
+ ((not (or (listp res) (functionp res)))
+ (unless (member fun completion--capf-misbehave-funs)
+ (message
+ "Completion function %S uses a deprecated calling convention" fun)
+ (push fun completion--capf-misbehave-funs))))
+ (if res (cons fun res)))))
+
(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."
+ "Perform completion on the text around point.
+The completion method is determined by `completion-at-point-functions'."
(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))
+ (let ((res (run-hook-wrapped 'completion-at-point-functions
+ #'completion--capf-wrapper 'all)))
+ (pcase res
+ (`(,_ . ,(and (pred functionp) f)) (funcall f))
+ (`(,hookfun . (,start ,end ,collection . ,plist))
+ (let* ((completion-annotate-function
+ (or (plist-get plist :annotation-function)
+ completion-annotate-function))
+ (completion-in-region-mode-predicate
+ (lambda ()
+ ;; We're still in the same completion field.
+ (eq (car-safe (funcall hookfun)) start))))
+ (completion-in-region start end collection
+ (plist-get plist :predicate))))
+ ;; Maybe completion already happened and the function returned t.
+ (_ (cdr res)))))
+
+(defun completion-help-at-point ()
+ "Display the completions on the text around point.
+The completion method is determined by `completion-at-point-functions'."
+ (interactive)
+ (let ((res (run-hook-wrapped 'completion-at-point-functions
+ ;; Ignore misbehaving functions.
+ #'completion--capf-wrapper 'optimist)))
+ (pcase res
+ (`(,_ . ,(and (pred functionp) f))
+ (message "Don't know how to show completions for %S" f))
+ (`(,hookfun . (,start ,end ,collection . ,plist))
+ (let* ((minibuffer-completion-table collection)
+ (minibuffer-completion-predicate (plist-get plist :predicate))
(completion-annotate-function
(or (plist-get plist :annotation-function)
- completion-annotate-function)))
- (completion-in-region start end (nth 2 res)
- (plist-get plist :predicate)))))))
+ completion-annotate-function))
+ (completion-in-region-mode-predicate
+ (lambda ()
+ ;; We're still in the same completion field.
+ (eq (car-safe (funcall hookfun)) start)))
+ (ol (make-overlay start end nil nil t)))
+ ;; FIXME: We should somehow (ab)use completion-in-region-function or
+ ;; introduce a corresponding hook (plus another for word-completion,
+ ;; and another for force-completion, maybe?).
+ (overlay-put ol 'field 'completion)
+ (completion-in-region-mode 1)
+ (setq completion-in-region--data
+ (list (current-buffer) start end collection))
+ (unwind-protect
+ (call-interactively 'minibuffer-completion-help)
+ (delete-overlay ol))))
+ (`(,hookfun . ,_)
+ ;; The hook function already performed completion :-(
+ ;; Not much we can do at this point.
+ (message "%s already performed completion!" hookfun)
+ nil)
+ (_ (message "Nothing to complete at point")))))
;;; Key bindings.
@@ -1254,7 +1499,7 @@ non-nil."
(concat "\\(?:^\\|[^$]\\(?:\\$\\$\\)*\\)"
"$\\([[:alnum:]_]*\\|{\\([^}]*\\)\\)\\'"))
-(defun completion--embedded-envvar-table (string pred action)
+(defun completion--embedded-envvar-table (string _pred action)
"Completion table for envvars embedded in a string.
The envvar syntax (and escaping) rules followed by this table are the
same as `substitute-in-file-name'."
@@ -1274,20 +1519,20 @@ same as `substitute-in-file-name'."
;; other table handle the test-completion case.
nil)
((eq (car-safe action) 'boundaries)
- ;; Only return boundaries if there's something to complete,
- ;; since otherwise when we're used in
- ;; completion-table-in-turn, we could return boundaries and
- ;; let some subsequent table return a list of completions.
- ;; FIXME: Maybe it should rather be fixed in
- ;; completion-table-in-turn instead, but it's difficult to
- ;; do it efficiently there.
+ ;; Only return boundaries if there's something to complete,
+ ;; since otherwise when we're used in
+ ;; completion-table-in-turn, we could return boundaries and
+ ;; let some subsequent table return a list of completions.
+ ;; FIXME: Maybe it should rather be fixed in
+ ;; completion-table-in-turn instead, but it's difficult to
+ ;; do it efficiently there.
(when (try-completion (substring string beg) table nil)
- ;; Compute the boundaries of the subfield to which this
- ;; completion applies.
- (let ((suffix (cdr action)))
- (list* 'boundaries
- (or (match-beginning 2) (match-beginning 1))
- (when (string-match "[^[:alnum:]_]" suffix)
+ ;; Compute the boundaries of the subfield to which this
+ ;; completion applies.
+ (let ((suffix (cdr action)))
+ (list* 'boundaries
+ (or (match-beginning 2) (match-beginning 1))
+ (when (string-match "[^[:alnum:]_]" suffix)
(match-beginning 0))))))
(t
(if (eq (aref string (1- beg)) ?{)
@@ -1302,48 +1547,55 @@ same as `substitute-in-file-name'."
(defun completion-file-name-table (string pred action)
"Completion table for file names."
(ignore-errors
- (cond
- ((eq (car-safe action) 'boundaries)
- (let ((start (length (file-name-directory string)))
- (end (string-match-p "/" (cdr action))))
- (list* 'boundaries start end)))
+ (cond
+ ((eq (car-safe action) 'boundaries)
+ (let ((start (length (file-name-directory string)))
+ (end (string-match-p "/" (cdr action))))
+ (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
+ (t
(let* ((name (file-name-nondirectory string))
(specdir (file-name-directory string))
(realdir (or specdir default-directory)))
- (cond
- ((null action)
+ (cond
+ ((null action)
(let ((comp (file-name-completion name realdir pred)))
(if (stringp comp)
(concat specdir comp)
comp)))
- ((eq action t)
- (let ((all (file-name-all-completions name realdir)))
+ ((eq action t)
+ (let ((all (file-name-all-completions name realdir)))
- ;; Check the predicate, if necessary.
+ ;; Check the predicate, if necessary.
(unless (memq pred '(nil file-exists-p))
- (let ((comp ())
- (pred
+ (let ((comp ())
+ (pred
(if (eq pred 'file-directory-p)
- ;; Brute-force speed up for directory checking:
- ;; Discard strings which don't end in a slash.
- (lambda (s)
- (let ((len (length s)))
- (and (> len 0) (eq (aref s (1- len)) ?/))))
- ;; Must do it the hard (and slow) way.
+ ;; Brute-force speed up for directory checking:
+ ;; Discard strings which don't end in a slash.
+ (lambda (s)
+ (let ((len (length s)))
+ (and (> len 0) (eq (aref s (1- len)) ?/))))
+ ;; Must do it the hard (and slow) way.
pred)))
(let ((default-directory (expand-file-name realdir)))
- (dolist (tem all)
- (if (funcall pred tem) (push tem comp))))
- (setq all (nreverse comp))))
+ (dolist (tem all)
+ (if (funcall pred tem) (push tem comp))))
+ (setq all (nreverse comp))))
all))))))))
@@ -1359,19 +1611,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'
@@ -1383,7 +1636,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)
@@ -1403,8 +1658,9 @@ except that it passes the file name through `substitute-in-file-name'."
'completion--file-name-table)
"Internal subroutine for `read-file-name'. Do not call this.")
-(defvar read-file-name-function nil
- "If this is non-nil, `read-file-name' does its work by calling this function.")
+(defvar read-file-name-function 'read-file-name-default
+ "The function called by `read-file-name' to do its work.
+It should accept the same arguments as `read-file-name'.")
(defcustom read-file-name-completion-ignore-case
(if (memq system-type '(ms-dos windows-nt darwin cygwin))
@@ -1442,7 +1698,7 @@ such as making the current buffer visit no file in the case of
(declare-function x-file-dialog "xfns.c"
(prompt dir &optional default-filename mustmatch only-dir-p))
-(defun read-file-name-defaults (&optional dir initial)
+(defun read-file-name--defaults (&optional dir initial)
(let ((default
(cond
;; With non-nil `initial', use `dir' as the first default.
@@ -1509,6 +1765,12 @@ treated as equivalent to nil.
See also `read-file-name-completion-ignore-case'
and `read-file-name-function'."
+ (funcall (or read-file-name-function #'read-file-name-default)
+ prompt dir default-filename mustmatch initial predicate))
+
+(defun read-file-name-default (prompt &optional dir default-filename mustmatch initial predicate)
+ "Default method for reading file names.
+See `read-file-name' for the meaning of the arguments."
(unless dir (setq dir default-directory))
(unless (file-name-absolute-p dir) (setq dir (expand-file-name dir)))
(unless default-filename
@@ -1530,125 +1792,122 @@ and `read-file-name-function'."
(minibuffer--double-dollars dir)))
(initial (cons (minibuffer--double-dollars initial) 0)))))
- (if read-file-name-function
- (funcall read-file-name-function
- prompt dir default-filename mustmatch initial predicate)
- (let ((completion-ignore-case read-file-name-completion-ignore-case)
- (minibuffer-completing-file-name t)
- (pred (or predicate 'file-exists-p))
- (add-to-history nil))
-
- (let* ((val
- (if (or (not (next-read-file-uses-dialog-p))
- ;; Graphical file dialogs can't handle remote
- ;; files (Bug#99).
- (file-remote-p dir))
- ;; We used to pass `dir' to `read-file-name-internal' by
- ;; abusing the `predicate' argument. It's better to
- ;; just use `default-directory', but in order to avoid
- ;; changing `default-directory' in the current buffer,
- ;; we don't let-bind it.
- (lexical-let ((dir (file-name-as-directory
- (expand-file-name dir))))
- (minibuffer-with-setup-hook
- (lambda ()
- (setq default-directory dir)
- ;; When the first default in `minibuffer-default'
- ;; duplicates initial input `insdef',
- ;; reset `minibuffer-default' to nil.
- (when (equal (or (car-safe insdef) insdef)
- (or (car-safe minibuffer-default)
- minibuffer-default))
- (setq minibuffer-default
- (cdr-safe minibuffer-default)))
- ;; On the first request on `M-n' fill
- ;; `minibuffer-default' with a list of defaults
- ;; relevant for file-name reading.
- (set (make-local-variable 'minibuffer-default-add-function)
- (lambda ()
- (with-current-buffer
- (window-buffer (minibuffer-selected-window))
- (read-file-name-defaults dir initial)))))
- (completing-read prompt 'read-file-name-internal
- pred mustmatch insdef
- 'file-name-history default-filename)))
- ;; If DEFAULT-FILENAME not supplied and DIR contains
- ;; a file name, split it.
- (let ((file (file-name-nondirectory dir))
- ;; When using a dialog, revert to nil and non-nil
- ;; interpretation of mustmatch. confirm options
- ;; need to be interpreted as nil, otherwise
- ;; it is impossible to create new files using
- ;; dialogs with the default settings.
- (dialog-mustmatch
- (not (memq mustmatch
- '(nil confirm confirm-after-completion)))))
- (when (and (not default-filename)
- (not (zerop (length file))))
- (setq default-filename file)
- (setq dir (file-name-directory dir)))
- (when default-filename
- (setq default-filename
- (expand-file-name (if (consp default-filename)
- (car default-filename)
- default-filename)
- dir)))
- (setq add-to-history t)
- (x-file-dialog prompt dir default-filename
- dialog-mustmatch
- (eq predicate 'file-directory-p)))))
-
- (replace-in-history (eq (car-safe file-name-history) val)))
- ;; If completing-read returned the inserted default string itself
- ;; (rather than a new string with the same contents),
- ;; it has to mean that the user typed RET with the minibuffer empty.
- ;; In that case, we really want to return ""
- ;; so that commands such as set-visited-file-name can distinguish.
- (when (consp default-filename)
- (setq default-filename (car default-filename)))
- (when (eq val default-filename)
- ;; In this case, completing-read has not added an element
- ;; to the history. Maybe we should.
- (if (not replace-in-history)
- (setq add-to-history t))
- (setq val ""))
- (unless val (error "No file name specified"))
-
- (if (and default-filename
- (string-equal val (if (consp insdef) (car insdef) insdef)))
- (setq val default-filename))
- (setq val (substitute-in-file-name val))
-
- (if replace-in-history
- ;; Replace what Fcompleting_read added to the history
- ;; with what we will actually return. As an exception,
- ;; if that's the same as the second item in
- ;; file-name-history, it's really a repeat (Bug#4657).
+ (let ((completion-ignore-case read-file-name-completion-ignore-case)
+ (minibuffer-completing-file-name t)
+ (pred (or predicate 'file-exists-p))
+ (add-to-history nil))
+
+ (let* ((val
+ (if (or (not (next-read-file-uses-dialog-p))
+ ;; Graphical file dialogs can't handle remote
+ ;; files (Bug#99).
+ (file-remote-p dir))
+ ;; We used to pass `dir' to `read-file-name-internal' by
+ ;; abusing the `predicate' argument. It's better to
+ ;; just use `default-directory', but in order to avoid
+ ;; changing `default-directory' in the current buffer,
+ ;; we don't let-bind it.
+ (let ((dir (file-name-as-directory
+ (expand-file-name dir))))
+ (minibuffer-with-setup-hook
+ (lambda ()
+ (setq default-directory dir)
+ ;; When the first default in `minibuffer-default'
+ ;; duplicates initial input `insdef',
+ ;; reset `minibuffer-default' to nil.
+ (when (equal (or (car-safe insdef) insdef)
+ (or (car-safe minibuffer-default)
+ minibuffer-default))
+ (setq minibuffer-default
+ (cdr-safe minibuffer-default)))
+ ;; On the first request on `M-n' fill
+ ;; `minibuffer-default' with a list of defaults
+ ;; relevant for file-name reading.
+ (set (make-local-variable 'minibuffer-default-add-function)
+ (lambda ()
+ (with-current-buffer
+ (window-buffer (minibuffer-selected-window))
+ (read-file-name--defaults dir initial)))))
+ (completing-read prompt 'read-file-name-internal
+ pred mustmatch insdef
+ 'file-name-history default-filename)))
+ ;; If DEFAULT-FILENAME not supplied and DIR contains
+ ;; a file name, split it.
+ (let ((file (file-name-nondirectory dir))
+ ;; When using a dialog, revert to nil and non-nil
+ ;; interpretation of mustmatch. confirm options
+ ;; need to be interpreted as nil, otherwise
+ ;; it is impossible to create new files using
+ ;; dialogs with the default settings.
+ (dialog-mustmatch
+ (not (memq mustmatch
+ '(nil confirm confirm-after-completion)))))
+ (when (and (not default-filename)
+ (not (zerop (length file))))
+ (setq default-filename file)
+ (setq dir (file-name-directory dir)))
+ (when default-filename
+ (setq default-filename
+ (expand-file-name (if (consp default-filename)
+ (car default-filename)
+ default-filename)
+ dir)))
+ (setq add-to-history t)
+ (x-file-dialog prompt dir default-filename
+ dialog-mustmatch
+ (eq predicate 'file-directory-p)))))
+
+ (replace-in-history (eq (car-safe file-name-history) val)))
+ ;; If completing-read returned the inserted default string itself
+ ;; (rather than a new string with the same contents),
+ ;; it has to mean that the user typed RET with the minibuffer empty.
+ ;; In that case, we really want to return ""
+ ;; so that commands such as set-visited-file-name can distinguish.
+ (when (consp default-filename)
+ (setq default-filename (car default-filename)))
+ (when (eq val default-filename)
+ ;; In this case, completing-read has not added an element
+ ;; to the history. Maybe we should.
+ (if (not replace-in-history)
+ (setq add-to-history t))
+ (setq val ""))
+ (unless val (error "No file name specified"))
+
+ (if (and default-filename
+ (string-equal val (if (consp insdef) (car insdef) insdef)))
+ (setq val default-filename))
+ (setq val (substitute-in-file-name val))
+
+ (if replace-in-history
+ ;; Replace what Fcompleting_read added to the history
+ ;; with what we will actually return. As an exception,
+ ;; if that's the same as the second item in
+ ;; file-name-history, it's really a repeat (Bug#4657).
+ (let ((val1 (minibuffer--double-dollars val)))
+ (if history-delete-duplicates
+ (setcdr file-name-history
+ (delete val1 (cdr file-name-history))))
+ (if (string= val1 (cadr file-name-history))
+ (pop file-name-history)
+ (setcar file-name-history val1)))
+ (if add-to-history
+ ;; Add the value to the history--but not if it matches
+ ;; the last value already there.
(let ((val1 (minibuffer--double-dollars val)))
- (if history-delete-duplicates
- (setcdr file-name-history
- (delete val1 (cdr file-name-history))))
- (if (string= val1 (cadr file-name-history))
- (pop file-name-history)
- (setcar file-name-history val1)))
- (if add-to-history
- ;; Add the value to the history--but not if it matches
- ;; the last value already there.
- (let ((val1 (minibuffer--double-dollars val)))
- (unless (and (consp file-name-history)
- (equal (car file-name-history) val1))
- (setq file-name-history
- (cons val1
- (if history-delete-duplicates
- (delete val1 file-name-history)
- file-name-history)))))))
- val)))))
+ (unless (and (consp file-name-history)
+ (equal (car file-name-history) val1))
+ (setq file-name-history
+ (cons val1
+ (if history-delete-duplicates
+ (delete val1 file-name-history)
+ file-name-history)))))))
+ val))))
(defun internal-complete-buffer-except (&optional buffer)
"Perform completion on all buffers excluding BUFFER.
BUFFER nil or omitted means use the current buffer.
Like `internal-complete-buffer', but removes BUFFER from the completion list."
- (lexical-let ((except (if (stringp buffer) buffer (buffer-name buffer))))
+ (let ((except (if (stringp buffer) buffer (buffer-name buffer))))
(apply-partially 'completion-table-with-predicate
'internal-complete-buffer
(lambda (name)
@@ -1657,13 +1916,13 @@ Like `internal-complete-buffer', but removes BUFFER from the completion list."
;;; Old-style completion, used in Emacs-21 and Emacs-22.
-(defun completion-emacs21-try-completion (string table pred point)
+(defun completion-emacs21-try-completion (string table pred _point)
(let ((completion (try-completion string table pred)))
(if (stringp completion)
(cons completion (length completion))
completion)))
-(defun completion-emacs21-all-completions (string table pred point)
+(defun completion-emacs21-all-completions (string table pred _point)
(completion-hilit-commonality
(all-completions string table pred)
(length string)
@@ -1713,11 +1972,16 @@ 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))
- (afterpoint (substring string point))
- (bounds (completion-boundaries beforepoint table pred afterpoint)))
+ (let* ((beforepoint (substring string 0 point))
+ (afterpoint (substring string point))
+ (bounds (completion-boundaries beforepoint table pred afterpoint)))
(if (zerop (cdr bounds))
;; `try-completion' may return a subtly different result
;; than `all+merge', so try to use it whenever possible.
@@ -1728,30 +1992,28 @@ Return the new suffix."
(concat completion
(completion--merge-suffix completion point afterpoint))
(length completion))))
- (lexical-let*
- ((suffix (substring afterpoint (cdr bounds)))
- (prefix (substring beforepoint 0 (car bounds)))
- (pattern (delete
- "" (list (substring beforepoint (car bounds))
- 'point
- (substring afterpoint 0 (cdr bounds)))))
- (all (completion-pcm--all-completions prefix pattern table pred)))
+ (let* ((suffix (substring afterpoint (cdr bounds)))
+ (prefix (substring beforepoint 0 (car bounds)))
+ (pattern (delete
+ "" (list (substring beforepoint (car bounds))
+ 'point
+ (substring afterpoint 0 (cdr bounds)))))
+ (all (completion-pcm--all-completions prefix pattern table pred)))
(if minibuffer-completing-file-name
(setq all (completion-pcm--filename-try-filter all)))
(completion-pcm--merge-try pattern all prefix suffix)))))
(defun completion-basic-all-completions (string table pred point)
- (lexical-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)))
- (pattern (delete
- "" (list (substring beforepoint (car bounds))
- 'point
- (substring afterpoint 0 (cdr bounds)))))
- (all (completion-pcm--all-completions prefix pattern table pred)))
+ (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)))
+ (pattern (delete
+ "" (list (substring beforepoint (car bounds))
+ 'point
+ (substring afterpoint 0 (cdr bounds)))))
+ (all (completion-pcm--all-completions prefix pattern table pred)))
(completion-hilit-commonality all point (car bounds))))
;;; Partial-completion-mode style completion.
@@ -1783,6 +2045,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.
@@ -1795,24 +2065,25 @@ 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)))
(append (completion-pcm--string->pattern prefix)
'(point)
(completion-pcm--string->pattern suffix)))
- (let ((pattern nil)
- (p 0)
- (p0 0))
+ (let* ((pattern nil)
+ (p 0)
+ (p0 p))
(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
@@ -1838,11 +2109,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.
@@ -1906,13 +2176,12 @@ POINT is a position inside STRING.
FILTER is a function applied to the return value, that can be used, e.g. to
filter out additional entries (because TABLE migth not obey PRED)."
(unless filter (setq filter 'identity))
- (lexical-let*
- ((beforepoint (substring string 0 point))
- (afterpoint (substring string point))
- (bounds (completion-boundaries beforepoint table pred afterpoint))
- (prefix (substring beforepoint 0 (car bounds)))
- (suffix (substring afterpoint (cdr bounds)))
- firsterror)
+ (let* ((beforepoint (substring string 0 point))
+ (afterpoint (substring string point))
+ (bounds (completion-boundaries beforepoint table pred afterpoint))
+ (prefix (substring beforepoint 0 (car bounds)))
+ (suffix (substring afterpoint (cdr bounds)))
+ firsterror)
(setq string (substring string (car bounds) (+ point (cdr bounds))))
(let* ((relpoint (- point (car bounds)))
(pattern (completion-pcm--string->pattern string relpoint))
@@ -1927,7 +2196,7 @@ filter out additional entries (because TABLE migth not obey PRED)."
;; The prefix has no completions at all, so we should try and fix
;; that first.
(let ((substring (substring prefix 0 -1)))
- (destructuring-bind (subpat suball subprefix subsuffix)
+ (destructuring-bind (subpat suball subprefix _subsuffix)
(completion-pcm--find-all-completions
substring table pred (length substring) filter)
(let ((sep (aref prefix (1- (length prefix))))
@@ -1992,12 +2261,23 @@ filter out additional entries (because TABLE migth not obey PRED)."
(list pattern all prefix suffix)))))
(defun completion-pcm-all-completions (string table pred point)
- (destructuring-bind (pattern all &optional prefix suffix)
+ (destructuring-bind (pattern all &optional prefix _suffix)
(completion-pcm--find-all-completions string table pred point)
(when all
(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
@@ -2059,17 +2339,26 @@ 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)))))
(defun completion-pcm--pattern->string (pattern)
(mapconcat (lambda (x) (cond
- ((stringp x) x)
- ((eq x 'star) "*")
- ((eq x 'any) "")
- ((eq x 'point) "")))
+ ((stringp x) x)
+ ((eq x 'star) "*")
+ (t ""))) ;any, point, prefix.
pattern
""))
@@ -2085,7 +2374,7 @@ filter out additional entries (because TABLE migth not obey PRED)."
;; second alternative.
(defun completion-pcm--filename-try-filter (all)
"Filter to adjust `all' file completion to the behavior of `try'."
- (when all
+ (when all
(let ((try ())
(re (concat "\\(?:\\`\\.\\.?/\\|"
(regexp-opt completion-ignored-extensions)
@@ -2103,22 +2392,23 @@ filter out additional entries (because TABLE migth not obey PRED)."
(equal (completion-pcm--pattern->string pattern) (car all)))
t)
(t
- (let* ((mergedpat (completion-pcm--merge-completions all pattern))
- ;; `mergedpat' is in reverse order. Place new point (by
- ;; order of preference) either at the old point, or at
- ;; the last place where there's something to choose, or
- ;; at the very end.
- (pointpat (or (memq 'point mergedpat)
- (memq 'any mergedpat)
- (memq 'star mergedpat)
- mergedpat))
- ;; New pos from the start.
- (newpos (length (completion-pcm--pattern->string pointpat)))
- ;; Do it afterwards because it changes `pointpat' by sideeffect.
- (merged (completion-pcm--pattern->string (nreverse mergedpat))))
+ (let* ((mergedpat (completion-pcm--merge-completions all pattern))
+ ;; `mergedpat' is in reverse order. Place new point (by
+ ;; order of preference) either at the old point, or at
+ ;; the last place where there's something to choose, or
+ ;; at the very end.
+ (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)))
+ ;; Do it afterwards because it changes `pointpat' by sideeffect.
+ (merged (completion-pcm--pattern->string (nreverse mergedpat))))
(setq suffix (completion--merge-suffix merged newpos suffix))
- (cons (concat prefix merged suffix) (+ newpos (length prefix)))))))
+ (cons (concat prefix merged suffix) (+ newpos (length prefix)))))))
(defun completion-pcm-try-completion (string table pred point)
(destructuring-bind (pattern all prefix suffix)
@@ -2128,7 +2418,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)
@@ -2159,12 +2480,12 @@ filter out additional entries (because TABLE migth not obey PRED)."
(concat (substring str 0 (car bounds))
(mapconcat 'string (substring str (car bounds)) sep))))))))
-(defun completion-initials-all-completions (string table pred point)
+(defun completion-initials-all-completions (string table pred _point)
(let ((newstr (completion-initials-expand string table pred)))
(when newstr
(completion-pcm-all-completions newstr table pred (length newstr)))))
-(defun completion-initials-try-completion (string table pred point)
+(defun completion-initials-try-completion (string table pred _point)
(let ((newstr (completion-initials-expand string table pred)))
(when newstr
(completion-pcm-try-completion newstr table pred (length newstr)))))
@@ -2183,5 +2504,4 @@ filter out additional entries (because TABLE migth not obey PRED)."
(provide 'minibuffer)
-;; arch-tag: ef8a0a15-1080-4790-a754-04017c02f08f
;;; minibuffer.el ends here
diff --git a/lisp/misc.el b/lisp/misc.el
index 45f45f5500c..e50b5b38c75 100644
--- a/lisp/misc.el
+++ b/lisp/misc.el
@@ -1,10 +1,10 @@
-;;; misc.el --- some nonstandard basic editing commands for Emacs
+;;; misc.el --- some nonstandard editing and utility commands for Emacs
-;; Copyright (C) 1989, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1989, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: convenience
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -25,6 +25,9 @@
;;; Code:
+(eval-when-compile
+ (require 'tabulated-list))
+
(defun copy-from-above-command (&optional arg)
"Copy characters from previous nonblank line, starting just above point.
Copy ARG characters, but not past the end of that line.
@@ -53,7 +56,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)))
@@ -129,7 +132,59 @@ variation of `C-x M-c M-butterfly' from url `http://xkcd.com/378/'."
(message "Well, then go to xkcd.com!")
(browse-url "http://xkcd.com/378/")))
+;; A command to list dynamically loaded libraries. This useful in
+;; environments where dynamic-library-alist is used, i.e., Windows
+
+(defvar list-dynamic-libraries--loaded-only-p)
+(make-variable-buffer-local 'list-dynamic-libraries--loaded-only-p)
+
+(defun list-dynamic-libraries--refresh ()
+ "Recompute the list of dynamic libraries.
+Internal use only."
+ (setq tabulated-list-format ; recomputed because column widths can change
+ (let ((max-id-len 0) (max-name-len 0))
+ (dolist (lib dynamic-library-alist)
+ (let ((id-len (length (symbol-name (car lib))))
+ (name-len (apply 'max (mapcar 'length (cdr lib)))))
+ (when (> id-len max-id-len) (setq max-id-len id-len))
+ (when (> name-len max-name-len) (setq max-name-len name-len))))
+ (vector (list "Library" (1+ max-id-len) t)
+ (list "Loaded from" (1+ max-name-len) t)
+ (list "Candidate names" 0 t))))
+ (setq tabulated-list-entries nil)
+ (dolist (lib dynamic-library-alist)
+ (let* ((id (car lib))
+ (from (get id :loaded-from)))
+ (when (or from
+ (not list-dynamic-libraries--loaded-only-p))
+ (push (list id (vector (symbol-name id)
+ (or from "")
+ (mapconcat 'identity (cdr lib) ", ")))
+ tabulated-list-entries)))))
+
+;;;###autoload
+(defun list-dynamic-libraries (&optional loaded-only-p buffer)
+ "Display a list of all dynamic libraries known to Emacs.
+\(These are the libraries listed in `dynamic-library-alist'.)
+If optional argument LOADED-ONLY-P (interactively, prefix arg)
+is non-nil, only libraries already loaded are listed.
+Optional argument BUFFER specifies a buffer to use, instead of
+\"*Dynamic Libraries*\".
+The return value is always nil."
+ (interactive "P")
+ (unless (bufferp buffer)
+ (setq buffer (get-buffer-create "*Dynamic Libraries*")))
+ (with-current-buffer buffer
+ (tabulated-list-mode)
+ (setq tabulated-list-sort-key (cons "Library" nil))
+ (add-hook 'tabulated-list-revert-hook 'list-dynamic-libraries--refresh nil t)
+ (tabulated-list-init-header)
+ (setq list-dynamic-libraries--loaded-only-p loaded-only-p)
+ (list-dynamic-libraries--refresh)
+ (tabulated-list-print))
+ (display-buffer buffer)
+ nil)
+
(provide 'misc)
-;; arch-tag: 908f7884-c19e-4388-920c-9cfa425e449b
;;; misc.el ends here
diff --git a/lisp/misearch.el b/lisp/misearch.el
index 5d4d3ef49c1..c533562f073 100644
--- a/lisp/misearch.el
+++ b/lisp/misearch.el
@@ -1,6 +1,6 @@
;;; misearch.el --- isearch extensions for multi-buffer search
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Juri Linkov <juri@jurta.org>
;; Keywords: matching
@@ -201,7 +201,7 @@ search status stack."
`(lambda (cmd)
(multi-isearch-pop-state cmd ,(current-buffer))))
-(defun multi-isearch-pop-state (cmd buffer)
+(defun multi-isearch-pop-state (_cmd buffer)
"Restore the multiple buffers search state.
Switch to the buffer restored from the search status stack."
(unless (equal buffer (current-buffer))
@@ -224,6 +224,8 @@ set in `multi-isearch-buffers' or `multi-isearch-buffers-regexp'."
(car buffers)
(cadr (member buffer buffers)))))
+(defvar ido-ignore-item-temp-list) ; from ido.el
+
(defun multi-isearch-read-buffers ()
"Return a list of buffers specified interactively, one by one."
;; Most code from `multi-occur'.
@@ -378,5 +380,4 @@ whose file names match the specified wildcard."
(provide 'multi-isearch)
-;; arch-tag: a6d38ffa-4d14-4e39-8ac6-46af9d6a6773
;;; misearch.el ends here
diff --git a/lisp/mouse-copy.el b/lisp/mouse-copy.el
index f600a849ce7..92fbdeb74e0 100644
--- a/lisp/mouse-copy.el
+++ b/lisp/mouse-copy.el
@@ -1,7 +1,6 @@
;;; mouse-copy.el --- one-click text copy and move
-;; Copyright (C) 1996, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 2001-2011 Free Software Foundation, Inc.
;; Author: John Heidemann <johnh@ISI.EDU>
;; Keywords: mouse
@@ -222,5 +221,4 @@ by johnh@ficus.cs.ucla.edu."
(provide 'mouse-copy)
-;; arch-tag: 3d50293b-c089-4273-b412-4fc96a5f26ff
;;; mouse-copy.el ends here
diff --git a/lisp/mouse-drag.el b/lisp/mouse-drag.el
index 84a680bfcde..fb6c8b7470f 100644
--- a/lisp/mouse-drag.el
+++ b/lisp/mouse-drag.el
@@ -1,7 +1,6 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1997, 2001-2011 Free Software Foundation, Inc.
;; Author: John Heidemann <johnh@ISI.EDU>
;; Keywords: mouse
@@ -163,7 +162,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)
@@ -215,13 +214,10 @@ To test this function, evaluate:
(start-row (cdr (posn-col-row start-posn)))
(start-col (car (posn-col-row start-posn)))
(old-selected-window (selected-window))
- event end row mouse-delta scroll-delta
+ event end row scroll-delta
have-scrolled
- window-last-row
- col mouse-col-delta window-last-col
+ col
(scroll-col-delta 0)
- adjusted-mouse-col-delta
- adjusted-mouse-delta
;; be conservative about allowing horizontal scrolling
(col-scrolling-p (mouse-drag-should-do-col-scrolling)))
(select-window start-window)
@@ -276,10 +272,10 @@ To test this function, evaluate:
(start-row (cdr (posn-col-row start-posn)))
(start-col (car (posn-col-row start-posn)))
(old-selected-window (selected-window))
- event end row mouse-delta scroll-delta
+ event end row scroll-delta
have-scrolled
window-last-row
- col mouse-col-delta window-last-col
+ col window-last-col
(scroll-col-delta 0)
;; be conservative about allowing horizontal scrolling
(col-scrolling-p (mouse-drag-should-do-col-scrolling)))
@@ -326,5 +322,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 e870a2078ca..1f601377ad4 100644
--- a/lisp/mouse-sel.el
+++ b/lisp/mouse-sel.el
@@ -1,7 +1,6 @@
;;; mouse-sel.el --- multi-click selection support
-;; Copyright (C) 1993, 1994, 1995, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1995, 2001-2011 Free Software Foundation, Inc.
;; Author: Mike Williams <mdub@bigfoot.com>
;; Keywords: mouse
@@ -98,7 +97,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 +128,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 +287,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 +298,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 +313,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)))
@@ -555,7 +548,6 @@ See documentation for mouse-select-internal for more details."
(let* ((thing-symbol (mouse-sel-selection-thing selection))
(overlay (mouse-sel-selection-overlay selection))
(orig-window (selected-window))
- (orig-window-frame (window-frame orig-window))
(top (nth 1 (window-edges orig-window)))
(bottom (nth 3 (window-edges orig-window)))
(mark-active nil) ; inhibit normal region highlight
diff --git a/lisp/mouse.el b/lisp/mouse.el
index 628f900e886..124f84d7d73 100644
--- a/lisp/mouse.el
+++ b/lisp/mouse.el
@@ -1,10 +1,10 @@
;;; mouse.el --- window system-independent mouse support
-;; Copyright (C) 1993, 1994, 1995, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1995, 1999-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: hardware, mouse
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -41,10 +41,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
@@ -702,9 +705,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)))
@@ -777,13 +777,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)
@@ -909,33 +902,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
@@ -969,165 +943,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)
@@ -1228,8 +1183,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)
@@ -1267,74 +1221,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.
@@ -1369,9 +1255,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)
@@ -1392,15 +1276,32 @@ 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
+ ((eq system-type 'windows-nt)
+ ;; MS-Windows emulates PRIMARY in x-get-selection, but not
+ ;; in x-get-selection-value (the latter only accesses the
+ ;; clipboard). So try PRIMARY first, in case they selected
+ ;; something with the mouse in the current Emacs session.
+ (or (x-get-selection 'PRIMARY)
+ (x-get-selection-value)))
+ ((fboundp 'x-get-selection-value) ; MS-DOS and X.
+ ;; On X, x-get-selection-value supports more formats and
+ ;; encodings, so use it in preference to x-get-selection.
+ (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.
@@ -1408,15 +1309,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)
@@ -1454,100 +1353,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)
@@ -1627,9 +1516,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.
@@ -1697,7 +1583,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 ()
@@ -1723,117 +1609,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.
@@ -1864,6 +1732,8 @@ a large number if you prefer a mixed multitude. The default is 4."
("Outline" . "Text")
("\\(HT\\|SG\\|X\\|XHT\\)ML" . "SGML")
("log\\|diff\\|vc\\|cvs\\|Annotate" . "Version Control") ; "Change Management"?
+ ("Threads\\|Memory\\|Disassembly\\|Breakpoints\\|Frames\\|Locals\\|Registers\\|Inferior I/O\\|Debugger"
+ . "GDB")
("Lisp" . "Lisp")))
"How to group various major modes together in \\[mouse-buffer-menu].
Each element has the form (REGEXP . GROUPNAME).
@@ -2014,332 +1884,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")
@@ -2561,7 +2105,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)
@@ -2582,10 +2126,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
@@ -2605,11 +2145,4 @@ 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)
-
;;; mouse.el ends here
diff --git a/lisp/mpc.el b/lisp/mpc.el
index a3a648d98e7..b1e4d860cca 100644
--- a/lisp/mpc.el
+++ b/lisp/mpc.el
@@ -1,6 +1,6 @@
-;;; mpc.el --- A client for the Music Player Daemon -*- coding: utf-8 -*-
+;;; mpc.el --- A client for the Music Player Daemon -*- coding: utf-8; lexical-binding: t -*-
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: multimedia
@@ -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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -378,9 +341,7 @@ CMD can be a string which is passed as-is to MPD or a list of strings
which will be concatenated with proper quoting before passing them to MPD."
(let ((proc (mpc-proc)))
(if (and callback (not (process-get proc 'ready)))
- (lexical-let ((old (process-get proc 'callback))
- (callback callback)
- (cmd cmd))
+ (let ((old (process-get proc 'callback)))
(process-put proc 'callback
(lambda ()
(funcall old)
@@ -396,15 +357,14 @@ which will be concatenated with proper quoting before passing them to MPD."
(mapconcat 'mpc--proc-quote-string cmd " "))
"\n")))
(if callback
- (lexical-let ((buf (current-buffer))
- (callback callback))
+ ;; (let ((buf (current-buffer)))
(process-put proc 'callback
callback
;; (lambda ()
;; (funcall callback
;; (prog1 (current-buffer)
- ;; (set-buffer buf))))
- ))
+ ;; (set-buffer buf)))))
+ )
;; If `callback' is nil, we're executing synchronously.
(process-put proc 'callback 'ignore)
;; This returns the process's buffer.
@@ -439,8 +399,7 @@ which will be concatenated with proper quoting before passing them to MPD."
(defun mpc-proc-cmd-to-alist (cmd &optional callback)
(if callback
- (lexical-let ((buf (current-buffer))
- (callback callback))
+ (let ((buf (current-buffer)))
(mpc-proc-cmd cmd (lambda ()
(funcall callback (prog1 (mpc-proc-buf-to-alist
(current-buffer))
@@ -559,7 +518,7 @@ to call FUN for any change whatsoever.")
(defun mpc-status-refresh (&optional callback)
"Refresh `mpc-status'."
- (lexical-let ((cb callback))
+ (let ((cb callback))
(mpc-proc-cmd (mpc-proc-cmd-list '("status" "currentsong"))
(lambda ()
(mpc--status-callback)
@@ -620,6 +579,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 +600,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 nil
+ (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,8 +624,16 @@ 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
+ (condition-case nil
(mpc-proc-buf-to-alists
(mpc-proc-cmd (list "find" (symbol-name tag) value)))
(mpc-proc-error
@@ -675,7 +659,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 +727,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 +746,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
@@ -779,7 +771,7 @@ The songs are returned as alists."
(defun mpc-cmd-pause (&optional arg callback)
"Pause or resume playback of the queue of songs."
- (lexical-let ((cb callback))
+ (let ((cb callback))
(mpc-proc-cmd (list "pause" arg)
(lambda () (mpc-status-refresh) (if cb (funcall cb))))
(unless callback (mpc-proc-sync))))
@@ -801,7 +793,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.
@@ -843,7 +835,7 @@ If PLAYLIST is t or nil or missing, use the main playlist."
(puthash (cons 'Playlist playlist) nil mpc--find-memoize))))
(defun mpc-cmd-update (&optional arg callback)
- (lexical-let ((cb callback))
+ (let ((cb callback))
(mpc-proc-cmd (if arg (list "update" arg) "update")
(lambda () (mpc-status-refresh) (if cb (funcall cb))))
(unless callback (mpc-proc-sync))))
@@ -928,6 +920,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"
@@ -939,7 +935,7 @@ If PLAYLIST is t or nil or missing, use the main playlist."
(defun mpc-tempfiles-clean ()
(let ((live ()))
- (maphash (lambda (k v) (push v live)) mpc-tempfiles-reftable)
+ (maphash (lambda (_k v) (push v live)) mpc-tempfiles-reftable)
(dolist (f mpc-tempfiles)
(unless (member f live) (ignore-errors (delete-file f))))
(setq mpc-tempfiles live)))
@@ -1163,7 +1159,7 @@ If PLAYLIST is t or nil or missing, use the main playlist."
(mpc-status-mode))
(mpc-proc-buffer (mpc-proc) 'status buf))
(if (null songs-win) (pop-to-buffer buf)
- (let ((win (split-window songs-win 20 t)))
+ (let ((_win (split-window songs-win 20 t)))
(set-window-dedicated-p songs-win nil)
(set-window-buffer songs-win buf)
(set-window-dedicated-p songs-win 'soft)))))
@@ -1432,6 +1428,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 +1456,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 +1865,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 +1911,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))))
@@ -2337,8 +2347,7 @@ This is used so that they can be compared with `eq', which is needed for
(mpc-proc-cmd (list "seekid" songid time)
'mpc-status-refresh))))
(let ((status (mpc-cmd-status)))
- (lexical-let* ((songid (cdr (assq 'songid status)))
- (step step)
+ (let* ((songid (cdr (assq 'songid status)))
(time (if songid (string-to-number
(cdr (assq 'time status))))))
(let ((timer (run-with-timer
@@ -2375,17 +2384,14 @@ This is used so that they can be compared with `eq', which is needed for
(if mpc--faster-toggle-timer
(mpc--faster-stop)
(mpc-status-refresh) (mpc-proc-sync)
- (lexical-let* ((speedup speedup)
- songid ;The ID of the currently ffwd/rewinding song.
- songnb ;The position of that song in the playlist.
- songduration ;The duration of that song.
- songtime ;The time of the song last time we ran.
- oldtime ;The timeoftheday last time we ran.
- prevsongid) ;The song we're in the process leaving.
+ (let* (songid ;The ID of the currently ffwd/rewinding song.
+ songduration ;The duration of that song.
+ songtime ;The time of the song last time we ran.
+ oldtime ;The timeoftheday last time we ran.
+ prevsongid) ;The song we're in the process leaving.
(let ((fun
(lambda ()
- (let ((newsongid (cdr (assq 'songid mpc-status)))
- (newsongnb (cdr (assq 'song mpc-status))))
+ (let ((newsongid (cdr (assq 'songid mpc-status))))
(if (and (equal prevsongid newsongid)
(not (equal prevsongid songid)))
@@ -2436,8 +2442,7 @@ This is used so that they can be compared with `eq', which is needed for
(mpc-proc-cmd
(list "seekid" songid songtime)
'mpc-status-refresh)
- (mpc-proc-error (mpc-status-refresh)))))))
- (setq songnb newsongnb)))))
+ (mpc-proc-error (mpc-status-refresh)))))))))))
(setq mpc--faster-toggle-forward (> step 0))
(funcall fun) ;Initialize values.
(setq mpc--faster-toggle-timer
@@ -2447,13 +2452,13 @@ This is used so that they can be compared with `eq', which is needed for
(defvar mpc-faster-speedup 8)
-(defun mpc-ffwd (event)
+(defun mpc-ffwd (_event)
"Fast forward."
(interactive (list last-nonmenu-event))
;; (mpc--faster event 4.0 1)
(mpc--faster-toggle mpc-faster-speedup 1))
-(defun mpc-rewind (event)
+(defun mpc-rewind (_event)
"Fast rewind."
(interactive (list last-nonmenu-event))
;; (mpc--faster event 4.0 -1)
@@ -2597,5 +2602,4 @@ This is used so that they can be compared with `eq', which is needed for
(provide 'mpc)
-;; arch-tag: 4794b2f5-59e6-4f26-b695-650b3e002f37
;;; mpc.el ends here
diff --git a/lisp/msb.el b/lisp/msb.el
index 0517d8a5478..cbc953da98e 100644
--- a/lisp/msb.el
+++ b/lisp/msb.el
@@ -1,7 +1,6 @@
;;; msb.el --- customizable buffer-selection with multiple menus
-;; Copyright (C) 1993, 1994, 1995, 1997, 1998, 1999, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1995, 1997-2011 Free Software Foundation, Inc.
;; Author: Lars Lindberg <lars.lindberg@home.se>
;; Maintainer: FSF
@@ -365,6 +364,9 @@ This is instead of the groups in `msb-menu-cond'."
:set 'msb-custom-set
:group 'msb)
+(define-obsolete-variable-alias 'msb-after-load-hooks
+ 'msb-after-load-hook "24.1")
+
(defcustom msb-after-load-hook nil
"Hook run after the msb package has been loaded."
:type 'hook
@@ -397,8 +399,6 @@ Optional second argument MAXBUF is completely ignored."
(format "%s%s %s" modified read-only name)))
-(eval-when-compile (require 'dired))
-
;; `dired' can be called with a list of the form (directory file1 file2 ...)
;; which causes `dired-directory' to be in the same form.
(defun msb--dired-directory ()
@@ -1153,7 +1153,6 @@ different buffer menu using the function `msb'."
nil)
(provide 'msb)
-(eval-after-load "msb" '(run-hooks 'msb-after-load-hook 'msb-after-load-hooks))
+(run-hooks 'msb-after-load-hook)
-;; arch-tag: 403f9e82-b92e-4e7a-a797-5d6d9b76da36
;;; msb.el ends here
diff --git a/lisp/mwheel.el b/lisp/mwheel.el
index 98ab155e7be..4ead168b188 100644
--- a/lisp/mwheel.el
+++ b/lisp/mwheel.el
@@ -1,9 +1,9 @@
;;; mwheel.el --- Wheel mouse support
-;; Copyright (C) 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 2000-2011 Free Software Foundation, Inc.
;; Maintainer: William M. Perry <wmperry@gnu.org>
;; Keywords: mouse
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -246,6 +246,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 c009671ce7c..53d58a70d29 100644
--- a/lisp/net/ange-ftp.el
+++ b/lisp/net/ange-ftp.el
@@ -1,8 +1,6 @@
;;; ange-ftp.el --- transparent FTP support for GNU Emacs
-;; Copyright (C) 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1998,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1989-1996, 1998, 2000-2011 Free Software Foundation, Inc.
;; Author: Andy Norman (ange@hplb.hpl.hp.com)
;; Maintainer: FSF
@@ -676,6 +674,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 +720,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")
@@ -856,15 +856,11 @@ If nil, prompt the user for a password."
:type '(choice (const :tag "Default" nil)
string))
-(defcustom ange-ftp-binary-file-name-regexp
- (concat "TAGS\\'\\|\\.\\(?:"
- (eval-when-compile
- (regexp-opt '("z" "Z" "lzh" "arc" "zip" "zoo" "tar" "dvi"
- "ps" "elc" "gif" "gz" "taz" "tgz")))
- "\\|EXE\\(;[0-9]+\\)?\\|[zZ]-part-..\\)\\'")
+(defcustom ange-ftp-binary-file-name-regexp ""
"If a file matches this regexp then it is transferred in binary mode."
:group 'ange-ftp
- :type 'regexp)
+ :type 'regexp
+ :version "24.1")
(defcustom ange-ftp-gateway-host nil
"Name of host to use as gateway machine when local FTP isn't possible."
@@ -1733,7 +1729,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.
@@ -3211,11 +3210,7 @@ system TYPE.")
;; What we REALLY need here is a way to determine if the mode
;; of the transfer is irrelevant, i.e. we can use binary mode
;; regardless. Maybe a system-type to host-type lookup?
- (binary (or (ange-ftp-binary-file filename)
- (and (not (memq system-type
- '(ms-dos windows-nt)))
- (memq (ange-ftp-host-type host user)
- '(unix dumb-unix)))))
+ (binary (ange-ftp-binary-file filename))
(cmd (if append 'append 'put))
(abbr (ange-ftp-abbreviate-filename filename))
;; we need to reset `last-coding-system-used' to its
@@ -3287,9 +3282,7 @@ system TYPE.")
(user (nth 1 parsed))
(name (ange-ftp-quote-string (nth 2 parsed)))
(temp (ange-ftp-make-tmp-name host))
- (binary (or (ange-ftp-binary-file filename)
- (memq (ange-ftp-host-type host user)
- '(unix dumb-unix))))
+ (binary (ange-ftp-binary-file filename))
(abbr (ange-ftp-abbreviate-filename filename))
(coding-system-used last-coding-system-used)
size)
@@ -3503,8 +3496,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 +3516,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.
@@ -3670,11 +3664,7 @@ so return the size on the remote host exactly. See RFC 3659."
(t-name (and t-parsed (ange-ftp-quote-string (nth 2 t-parsed))))
(t-abbr (ange-ftp-abbreviate-filename newname filename))
(binary (or (ange-ftp-binary-file filename)
- (ange-ftp-binary-file newname)
- (and (memq (ange-ftp-host-type f-host f-user)
- '(unix dumb-unix))
- (memq (ange-ftp-host-type t-host t-user)
- '(unix dumb-unix)))))
+ (ange-ftp-binary-file newname)))
temp1
temp2)
@@ -3826,7 +3816,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
@@ -4066,7 +4057,7 @@ directory, so that Emacs will know its current contents."
(ange-ftp-get-files dir t))))
(defun ange-ftp-make-directory (dir &optional parents)
- (interactive (list (expand-file-name (read-file-name "Make directory: "))))
+ (interactive (list (expand-file-name (read-directory-name "Make directory: "))))
(if parents
(let ((parent (file-name-directory (directory-file-name dir))))
(or (file-exists-p parent)
@@ -4894,7 +4885,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 +5284,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 +5642,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 +5863,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 +6137,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 14d58cf4466..c1ec3f0ed13 100644
--- a/lisp/net/browse-url.el
+++ b/lisp/net/browse-url.el
@@ -1,7 +1,6 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-2011 Free Software Foundation, Inc.
;; Author: Denis Howe <dbh@doc.ic.ac.uk>
;; Maintainer: FSF
@@ -204,26 +203,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 +260,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 +321,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 +342,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 +615,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)
@@ -636,7 +647,6 @@ regarding its parameter treatment."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; URL input
-;;;###autoload
(defun browse-url-url-at-point ()
(let ((url (thing-at-point 'url)))
(set-text-properties 0 (length url) nil url)
@@ -752,11 +762,17 @@ 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."
(interactive)
- (browse-url-of-file (dired-get-filename)))
+ (let ((tem (dired-get-filename t t)))
+ (if tem
+ (browse-url-of-file (expand-file-name tem))
+ (error "No file on this line"))))
;;;###autoload
(defun browse-url-of-region (min max)
@@ -776,22 +792,32 @@ 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))
+ ;; Ensure that `default-directory' exists and is readable (b#6077).
+ (default-directory (if (and (file-directory-p default-directory)
+ (file-readable-p default-directory))
+ default-directory
+ (expand-file-name "~/"))))
;; 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 +825,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)
@@ -872,7 +898,6 @@ one showing the selected frame."
(and (not (equal display (getenv "DISPLAY")))
display)))
-;;;###autoload
(defun browse-url-default-browser (url &rest args)
"Find a suitable browser and ask it to load URL.
Default to the URL around or before point.
@@ -889,6 +914,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 +928,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.
@@ -1056,8 +1114,7 @@ URL in a new window."
browse-url-firefox-program
(append
browse-url-firefox-arguments
- (if (or (featurep 'dos-w32)
- (string-match "win32" system-configuration))
+ (if (memq system-type '(windows-nt ms-dos))
(list url)
(list "-remote"
(concat "openURL("
@@ -1347,6 +1404,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 +1428,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 +1501,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 +1600,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 941fdc09f1d..05c7af2a8c3 100644
--- a/lisp/net/dbus.el
+++ b/lisp/net/dbus.el
@@ -1,6 +1,6 @@
;;; dbus.el --- Elisp bindings for D-Bus.
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, hardware
@@ -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,19 @@ 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.
+
+The function returns a keyword, indicating the result of the
+operation. One of the following keywords is returned:
+
+`:released': Service has become the primary owner of the name.
+
+`:non-existent': Service name does not exist on this bus.
+
+`:not-owner': We are neither the primary owner nor waiting in the
+queue of this service."
+
(maphash
(lambda (key value)
(dolist (elt value)
@@ -197,9 +204,14 @@ SERVICE must be a known service name."
(puthash key (delete elt value) dbus-registered-objects-table)
(remhash key dbus-registered-objects-table))))))
dbus-registered-objects-table)
- (dbus-call-method
- bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus
- "ReleaseName" service))
+ (let ((reply (dbus-call-method
+ bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus
+ "ReleaseName" service)))
+ (case reply
+ (1 :released)
+ (2 :non-existent)
+ (3 :not-owner)
+ (t (signal 'dbus-error (list "Could not unregister service" service))))))
(defun dbus-call-method-non-blocking-handler (&rest args)
"Handler for reply messages of asynchronous D-Bus message calls.
@@ -243,7 +255,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 +364,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 +380,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 +446,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))
@@ -492,13 +506,14 @@ well formed."
;;; D-Bus registered names.
-(defun dbus-list-activatable-names ()
+(defun dbus-list-activatable-names (&optional bus)
"Return the D-Bus service names which can be activated as list.
-The result is a list of strings, which is `nil' when there are no
-activatable service names at all."
+If BUS is left nil, `:system' is assumed. The result is a list
+of strings, which is `nil' when there are no activatable service
+names at all."
(dbus-ignore-errors
(dbus-call-method
- :system dbus-service-dbus
+ (or bus :system) dbus-service-dbus
dbus-path-dbus dbus-interface-dbus "ListActivatableNames")))
(defun dbus-list-names (bus)
@@ -565,10 +580,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,20 +885,23 @@ 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 dont-register-service)
"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.
-
-PATH is the D-Bus object path SERVICE is registered. INTERFACE
-is the name of the interface used at PATH, PROPERTY is the name
-of the property of INTERFACE. ACCESS indicates, whether the
-property can be changed by other services via D-Bus. It must be
-either the symbol `:read' or `:readwrite'. VALUE is the initial
-value of the property, it can be of any valid type (see
+known name (See discussion of DONT-REGISTER-SERVICE below).
+
+PATH is the D-Bus object path SERVICE is registered (See
+discussion of DONT-REGISTER-SERVICE below). INTERFACE is the
+name of the interface used at PATH, PROPERTY is the name of the
+property of INTERFACE. ACCESS indicates, whether the property
+can be changed by other services via D-Bus. It must be either
+the symbol `:read' or `:readwrite'. VALUE is the initial value
+of the property, it can be of any valid type (see
`dbus-call-method' for details).
If PROPERTY already exists on PATH, it will be overwritten. For
@@ -892,29 +911,58 @@ 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'.
+
+When DONT-REGISTER-SERVICE is non-nil, the known name SERVICE is
+not registered. This means that other D-Bus clients have no way
+of noticing the newly registered property. When interfaces are
+constructed incrementally by adding single methods or properties
+at a time, DONT-REGISTER-SERVICE can be used to prevent other
+clients from discovering the still incomplete interface."
(unless (member access '(:read :readwrite))
(signal 'dbus-error (list "Access type invalid" access)))
;; Register SERVICE.
- (unless (member service (dbus-list-names bus))
+ (unless (or dont-register-service
+ (member service (dbus-list-names bus)))
(dbus-call-method
bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus
"RequestName" service 0))
- ;; Add the handler. We use `dbus-service-emacs' as service name, in
- ;; order to let unregister SERVICE despite of this default handler.
+ ;; Add handlers for the three property-related methods.
(dbus-register-method
- bus service path dbus-interface-properties "Get" 'dbus-property-handler)
+ bus service path dbus-interface-properties "Get"
+ 'dbus-property-handler 'dont-register)
(dbus-register-method
- bus service path dbus-interface-properties "GetAll" 'dbus-property-handler)
+ bus service path dbus-interface-properties "GetAll"
+ 'dbus-property-handler 'dont-register)
(dbus-register-method
- bus service path dbus-interface-properties "Set" 'dbus-property-handler)
+ bus service path dbus-interface-properties "Set"
+ 'dbus-property-handler 'dont-register)
+
+ ;; Register the name SERVICE with BUS.
+ (unless dont-register-service
+ (dbus-register-service bus service))
+
+ ;; 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 +972,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 +980,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 +1043,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 e65e5eaab32..af78ded4786 100644
--- a/lisp/net/dig.el
+++ b/lisp/net/dig.el
@@ -1,7 +1,6 @@
;;; dig.el --- Domain Name System dig interface
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Author: Simon Josefsson <simon@josefsson.org>
;; Keywords: DNS BIND dig comm
@@ -129,12 +128,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 +182,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 6e727edf339..3c1bd54acfd 100644
--- a/lisp/net/dns.el
+++ b/lisp/net/dns.el
@@ -1,7 +1,6 @@
;;; dns.el --- Domain Name Service lookups
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: network comm
@@ -101,7 +100,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 +134,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 +150,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 +185,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)
@@ -253,8 +252,8 @@ If TCP-P, the first two bytes of the package with be the length field."
(nreverse spec))))
(defun dns-read-int32 ()
- ;; Full 32 bit Integers can't be handled by Emacs. If we use
- ;; floats, it works.
+ ;; Full 32 bit Integers can't be handled by 32-bit Emacsen. If we
+ ;; use floats, it works.
(format "%.0f" (+ (* (dns-read-bytes 1) 16777216.0)
(dns-read-bytes 3))))
@@ -263,7 +262,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 +390,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 +437,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 8210ace5a8a..5847a2def64 100644
--- a/lisp/net/eudc-bob.el
+++ b/lisp/net/eudc-bob.el
@@ -1,11 +1,11 @@
;;; eudc-bob.el --- Binary Objects Support for EUDC
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 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.
@@ -365,5 +365,4 @@ display a button."
"Display a button for the JPEG DATA."
(eudc-bob-display-jpeg data nil))
-;; arch-tag: 8f1853df-c9b6-4c5a-bdb1-d94dbd651fb3
;;; eudc-bob.el ends here
diff --git a/lisp/net/eudc-export.el b/lisp/net/eudc-export.el
index 0a9b3d935e8..df3a2e04118 100644
--- a/lisp/net/eudc-export.el
+++ b/lisp/net/eudc-export.el
@@ -1,11 +1,11 @@
;;; eudc-export.el --- functions to export EUDC query results
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 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.
@@ -219,5 +219,4 @@ This function can only be called from a directory query result buffer."
(overlay-get (car (overlays-at (point))) 'eudc-record)
(eudc-insert-record-at-point-into-bbdb)))
-;; arch-tag: 8cbda7dc-3163-47e6-921c-6ec5083df2d7
;;; eudc-export.el ends here
diff --git a/lisp/net/eudc-hotlist.el b/lisp/net/eudc-hotlist.el
index 7411d08f955..fd0c56ed693 100644
--- a/lisp/net/eudc-hotlist.el
+++ b/lisp/net/eudc-hotlist.el
@@ -1,11 +1,11 @@
;;; eudc-hotlist.el --- hotlist management for EUDC
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 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.
@@ -32,9 +32,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 +177,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]
@@ -194,5 +193,4 @@ These are the special commands of this mode:
""
eudc-hotlist-menu))
-;; arch-tag: 9b633ab3-6a6e-4b46-b12e-d96739a7e0e8
;;; eudc-hotlist.el ends here
diff --git a/lisp/net/eudc-vars.el b/lisp/net/eudc-vars.el
index b01e2a0378a..d9985312f99 100644
--- a/lisp/net/eudc-vars.el
+++ b/lisp/net/eudc-vars.el
@@ -1,11 +1,11 @@
;;; eudc-vars.el --- Emacs Unified Directory Client
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 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 +38,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 +55,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 +66,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 +86,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 +106,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 +135,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 +163,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 +188,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 +202,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 +217,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 +248,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 +261,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 +282,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 +299,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 +322,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 +357,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',
@@ -405,5 +405,4 @@ Otherwise records must match queries exactly."
(provide 'eudc-vars)
-;; arch-tag: 80050575-b838-4246-8ebc-b2d7c5a2e482
;;; eudc-vars.el ends here
diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el
index b35d13c2086..8616c805f41 100644
--- a/lisp/net/eudc.el
+++ b/lisp/net/eudc.el
@@ -1,7 +1,6 @@
;;; eudc.el --- Emacs Unified Directory Client
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Oscar Figueiredo <oscar@cpe.fr>
;; Maintainer: Pavel Jank <Pavel@Janik.cz>
@@ -830,10 +829,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 +1291,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 c952bbd55ea..1dd0648f569 100644
--- a/lisp/net/eudcb-bbdb.el
+++ b/lisp/net/eudcb-bbdb.el
@@ -1,11 +1,11 @@
;;; eudcb-bbdb.el --- Emacs Unified Directory Client - BBDB Backend
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 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.
@@ -242,5 +242,4 @@ RETURN-ATTRS is a list of attributes to return, defaulting to
(provide 'eudcb-bbdb)
-;; arch-tag: 38276208-75de-4dbc-ba6f-8db684c32e0a
;;; eudcb-bbdb.el ends here
diff --git a/lisp/net/eudcb-ldap.el b/lisp/net/eudcb-ldap.el
index 75b40c1dcd1..14594409dfa 100644
--- a/lisp/net/eudcb-ldap.el
+++ b/lisp/net/eudcb-ldap.el
@@ -1,11 +1,11 @@
;;; eudcb-ldap.el --- Emacs Unified Directory Client - LDAP Backend
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 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.
@@ -207,5 +207,4 @@ attribute names are returned. Default to `person'"
(provide 'eudcb-ldap)
-;; arch-tag: 0f254dc0-7378-4fd4-ae26-18666184e96b
;;; eudcb-ldap.el ends here
diff --git a/lisp/net/eudcb-mab.el b/lisp/net/eudcb-mab.el
index 6277392289c..485ca5a0c06 100644
--- a/lisp/net/eudcb-mab.el
+++ b/lisp/net/eudcb-mab.el
@@ -1,11 +1,11 @@
;;; eudcb-mab.el --- Emacs Unified Directory Client - AddressBook backend
-;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2003-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@newartisans.com>
;; Maintainer: FSF
;; Keywords: comm
+;; Package: eudc
;; This file is part of GNU Emacs.
@@ -129,5 +129,4 @@ RETURN-ATTRS is a list of attributes to return, defaulting to
(provide 'eudcb-mab)
-;; arch-tag: 4bef8e65-f109-47c7-91b9-8a6ea3ed7bb1
;;; eudcb-mab.el ends here
diff --git a/lisp/net/eudcb-ph.el b/lisp/net/eudcb-ph.el
index 8d36daf34d3..9e7490106ed 100644
--- a/lisp/net/eudcb-ph.el
+++ b/lisp/net/eudcb-ph.el
@@ -1,11 +1,11 @@
;;; eudcb-ph.el --- Emacs Unified Directory Client - CCSO PH/QI Backend
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 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.
@@ -240,5 +240,4 @@ depending on RETURN-RESPONSE."
(provide 'eudcb-ph)
-;; arch-tag: 4365bbf5-af20-453e-b5b6-2e7118ebfcdb
;;; eudcb-ph.el ends here
diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el
new file mode 100644
index 00000000000..67d7b2d20d3
--- /dev/null
+++ b/lisp/net/gnutls.el
@@ -0,0 +1,184 @@
+;;; gnutls.el --- Support SSL/TLS connections through GnuTLS
+
+;; Copyright (C) 2010-2011 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. It should NOT
+;; be used directly, only through open-protocol-stream.
+
+;; Simple test:
+;;
+;; (open-gnutls-stream "tls" "tls-buffer" "yourserver.com" "https")
+;; (open-gnutls-stream "tls" "tls-buffer" "imap.gmail.com" "imaps")
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(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.
+
+Usage example:
+
+ \(with-temp-buffer
+ \(open-gnutls-stream \"tls\"
+ \(current-buffer)
+ \"your server goes here\"
+ \"imaps\"))
+
+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."
+ (gnutls-negotiate :process (open-network-stream name buffer host service)
+ :type 'gnutls-x509pki
+ :hostname host))
+
+(put 'gnutls-error
+ 'error-conditions
+ '(error gnutls-error))
+(put 'gnutls-error
+ 'error-message "GnuTLS error")
+
+(declare-function gnutls-boot "gnutls.c" (proc type proplist))
+(declare-function gnutls-errorp "gnutls.c" (error))
+
+(defun* gnutls-negotiate
+ (&rest spec
+ &key process type hostname priority-string
+ trustfiles crlfiles keylist verify-flags
+ verify-error verify-hostname-error
+ &allow-other-keys)
+ "Negotiate a SSL/TLS connection. Returns proc. Signals gnutls-error.
+
+Note arguments are passed CL style, :type TYPE instead of just TYPE.
+
+TYPE is `gnutls-x509pki' (default) or `gnutls-anon'. Use nil for the default.
+PROCESS is a process returned by `open-network-stream'.
+HOSTNAME is the remote hostname. It must be a valid string.
+PRIORITY-STRING is as per the GnuTLS docs, default is \"NORMAL\".
+TRUSTFILES is a list of CA bundles.
+CRLFILES is a list of CRL files.
+KEYLIST is an alist of (client key file, client cert file) pairs.
+
+When VERIFY-HOSTNAME-ERROR is not nil, an error will be raised
+when the hostname does not match the presented certificate's host
+name. The exact verification algorithm is a basic implementation
+of the matching described in RFC2818 (HTTPS), which takes into
+account wildcards, and the DNSName/IPAddress subject alternative
+name PKIX extension. See GnuTLS' gnutls_x509_crt_check_hostname
+for details. When VERIFY-HOSTNAME-ERROR is nil, only a warning
+will be issued.
+
+When VERIFY-ERROR is not nil, an error will be raised when the
+peer certificate verification fails as per GnuTLS'
+gnutls_certificate_verify_peers2. Otherwise, only warnings will
+be shown about the verification failure.
+
+VERIFY-FLAGS is a numeric OR of verification flags only for
+`gnutls-x509pki' connections. See GnuTLS' x509.h for details;
+here's a recent version of the list.
+
+ GNUTLS_VERIFY_DISABLE_CA_SIGN = 1,
+ GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT = 2,
+ GNUTLS_VERIFY_DO_NOT_ALLOW_SAME = 4,
+ GNUTLS_VERIFY_ALLOW_ANY_X509_V1_CA_CRT = 8,
+ GNUTLS_VERIFY_ALLOW_SIGN_RSA_MD2 = 16,
+ GNUTLS_VERIFY_ALLOW_SIGN_RSA_MD5 = 32,
+ GNUTLS_VERIFY_DISABLE_TIME_CHECKS = 64,
+ GNUTLS_VERIFY_DISABLE_TRUSTED_TIME_CHECKS = 128,
+ GNUTLS_VERIFY_DO_NOT_ALLOW_X509_V1_CA_CRT = 256
+
+It must be omitted, a number, or nil; if omitted or nil it
+defaults to GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT."
+ (let* ((type (or type 'gnutls-x509pki))
+ (default-trustfile "/etc/ssl/certs/ca-certificates.crt")
+ (trustfiles (or trustfiles
+ (when (file-exists-p default-trustfile)
+ (list default-trustfile))))
+ (priority-string (or priority-string
+ (cond
+ ((eq type 'gnutls-anon)
+ "NORMAL:+ANON-DH:!ARCFOUR-128")
+ ((eq type 'gnutls-x509pki)
+ "NORMAL"))))
+ (params `(:priority ,priority-string
+ :hostname ,hostname
+ :loglevel ,gnutls-log-level
+ :trustfiles ,trustfiles
+ :crlfiles ,crlfiles
+ :keylist ,keylist
+ :verify-flags ,verify-flags
+ :verify-error ,verify-error
+ :verify-hostname-error ,verify-hostname-error
+ :callbacks nil))
+ ret)
+
+ (gnutls-message-maybe
+ (setq ret (gnutls-boot process type params))
+ "boot: %s" params)
+
+ (when (gnutls-errorp ret)
+ ;; This is a error from the underlying C code.
+ (signal 'gnutls-error (list process ret)))
+
+ process))
+
+(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 49dbd97aca8..4e78a7d42c0 100644
--- a/lisp/net/goto-addr.el
+++ b/lisp/net/goto-addr.el
@@ -1,7 +1,6 @@
;;; goto-addr.el --- click to browse URL or to send to e-mail address
-;; Copyright (C) 1995, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 2000-2011 Free Software Foundation, Inc.
;; Author: Eric Ding <ericding@alum.mit.edu>
;; Maintainer: FSF
@@ -76,7 +75,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.
@@ -302,5 +301,4 @@ Also fontifies the buffer appropriately (see `goto-address-fontify-p' and
(provide 'goto-addr)
-;; arch-tag: ca47c505-5661-425d-a471-62bc6e75cf0a
;;; goto-addr.el ends here
diff --git a/lisp/net/hmac-def.el b/lisp/net/hmac-def.el
index 459d0b81779..5c8710afdbf 100644
--- a/lisp/net/hmac-def.el
+++ b/lisp/net/hmac-def.el
@@ -1,9 +1,9 @@
;;; hmac-def.el --- A macro for defining HMAC functions.
-;; Copyright (C) 1999, 2001, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2001, 2007-2011 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 c433d7004d8..a423cbeadd1 100644
--- a/lisp/net/hmac-md5.el
+++ b/lisp/net/hmac-md5.el
@@ -1,9 +1,9 @@
;;; hmac-md5.el --- Compute HMAC-MD5.
-;; Copyright (C) 1999, 2001, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2001, 2007-2011 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-hash.el b/lisp/net/imap-hash.el
deleted file mode 100644
index ebc90632cad..00000000000
--- a/lisp/net/imap-hash.el
+++ /dev/null
@@ -1,374 +0,0 @@
-;;; imap-hash.el --- Hashtable-like interface to an IMAP mailbox
-
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
-
-;; Author: Teodor Zlatanov <tzz@lifelogs.com>
-;; Keywords: mail
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This module provides hashtable-like functions on top of imap.el
-;; functionality. All the authentication is handled by auth-source so
-;; there are no authentication options here, only the server and
-;; mailbox names are needed.
-
-;; Create a IHT (imap-hash table) object with `imap-hash-make'. Then
-;; use it with `imap-hash-map' to map a function across all the
-;; messages. Use `imap-hash-get' and `imap-hash-rem' to operate on
-;; individual messages. See the tramp-imap.el library in Tramp if you
-;; need to see practical examples.
-
-;; This only works with IMAP4r1. Sorry to everyone without it, but
-;; the compatibility code is too annoying and it's 2009.
-
-;; TODO: Use SEARCH instead of FETCH when a test is specified. List
-;; available mailboxes. Don't select an invalid mailbox.
-
-;;; Code:
-
-(require 'assoc)
-(require 'imap)
-(require 'sendmail) ; for mail-header-separator
-(require 'message)
-(autoload 'auth-source-user-or-password "auth-source")
-
-;; retrieve these headers
-(defvar imap-hash-headers
- (append '(Subject From Date Message-Id References In-Reply-To Xref)))
-
-;; from nnheader.el
-(defsubst imap-hash-remove-cr-followed-by-lf ()
- (goto-char (point-max))
- (while (search-backward "\r\n" nil t)
- (delete-char 1)))
-
-;; from nnheader.el
-(defun imap-hash-ms-strip-cr (&optional string)
- "Strip ^M from the end of all lines in current buffer or STRING."
- (if string
- (with-temp-buffer
- (insert string)
- (imap-hash-remove-cr-followed-by-lf)
- (buffer-string))
- (save-excursion
- (imap-hash-remove-cr-followed-by-lf))))
-
-(defun imap-hash-make (server port mailbox &optional user password ssl)
- "Make a new imap-hash object using SERVER, PORT, and MAILBOX.
-USER, PASSWORD and SSL are optional.
-The test is set to t, meaning all messages are considered."
- (when (and server port mailbox)
- (list :server server :port port :mailbox mailbox
- :ssl ssl :user user :password password
- :test t)))
-
-(defun imap-hash-p (iht)
- "Check whether IHT is a valid imap-hash."
- (and
- (imap-hash-server iht)
- (imap-hash-port iht)
- (imap-hash-mailbox iht)
- (imap-hash-test iht)))
-
-(defmacro imap-hash-gather (uid)
- `(imap-message-get ,uid 'BODYDETAIL))
-
-(defmacro imap-hash-data-body (details)
- `(nth 2 (nth 1 ,details)))
-
-(defmacro imap-hash-data-headers (details)
- `(nth 2 (nth 0 ,details)))
-
-(defun imap-hash-get (key iht &optional refetch)
- "Get the value for KEY in the imap-hash IHT.
-Requires either `imap-hash-fetch' to be called beforehand
-\(e.g. by `imap-hash-map'), or REFETCH to be t.
-Returns a list of the headers (an alist, see `imap-hash-map') and
-the body of the message as a string.
-Also see `imap-hash-test'."
- (with-current-buffer (imap-hash-get-buffer iht)
- (when refetch
- (imap-hash-fetch iht nil key))
- (let ((details (imap-hash-gather key)))
- (list
- (imap-hash-get-headers
- (imap-hash-data-headers details))
- (imap-hash-get-body
- (imap-hash-data-body details))))))
-
-(defun imap-hash-put (value iht &optional key)
- "Put VALUE in the imap-hash IHT. Return the new key.
-If KEY is given, removes it.
-VALUE can be a list of the headers (an alist, see `imap-hash-map')
-and the body of the message as a string. It can also be a uid,
-in which case `imap-hash-get' will be called to get the value.
-Also see `imap-hash-test'."
- (let ((server-buffer (imap-hash-get-buffer iht))
- (value (if (listp value) value (imap-hash-get value iht)))
- newuid)
- (when value
- (with-temp-buffer
- (funcall 'imap-hash-make-message
- (nth 0 value)
- (nth 1 value)
- nil)
- (setq newuid (nth 1 (imap-message-append
- (imap-hash-mailbox iht)
- (current-buffer) nil nil server-buffer)))
- (when key (imap-hash-rem key iht))))
- newuid))
-
-(defun imap-hash-make-message (headers body &optional overrides)
- "Make a message with HEADERS and BODY suitable for `imap-append',
-using `message-setup'.
-Look in the alist OVERRIDES for header overrides as per `imap-hash-headers'."
- ;; don't insert a signature no matter what
- (let (message-signature)
- (message-setup
- (append overrides headers))
- (message-generate-headers message-required-mail-headers)
- (message-remove-header "X-Draft-From")
- (message-goto-body)
- (insert (or (aget overrides 'body)
- body
- ""))
- (goto-char (point-min))
- ;; TODO: make this search better
- (if (search-forward mail-header-separator nil t)
- (delete-region (line-beginning-position) (line-end-position))
- (error "Could not find the body separator in the encoded message!"))))
-
-(defun imap-hash-rem (key iht)
- "Remove KEY in the imap-hash IHT.
-Also see `imap-hash-test'. Requires `imap-hash-fetch' to have
-been called and the imap-hash server buffer to be current,
-so it's best to use it inside `imap-hash-map'.
-The key will not be found on the next `imap-hash-map' call."
- (with-current-buffer (imap-hash-get-buffer iht)
- (imap-message-flags-add
- (imap-range-to-message-set (list key))
- "\\Deleted" 'silent)
- (imap-mailbox-expunge t)))
-
-(defun imap-hash-clear (iht)
- "Remove all keys in the imap-hash IHT.
-Also see `imap-hash-test'."
- (imap-hash-map (lambda (uid b c) (imap-hash-rem uid iht)) iht))
-
-(defun imap-hash-get-headers (text-headers)
- (with-temp-buffer
- (insert (or text-headers ""))
- (imap-hash-remove-cr-followed-by-lf)
- (mapcar (lambda (header)
- (cons header
- (message-fetch-field (format "%s" header))))
- imap-hash-headers)))
-
-(defun imap-hash-get-body (text)
- (with-temp-buffer
- (insert (or text ""))
- (imap-hash-remove-cr-followed-by-lf)
- (buffer-string)))
-
-(defun imap-hash-map (function iht &optional headers-only &rest messages)
- "Call FUNCTION for all entries in IHT and pass it the message uid,
-the headers (an alist, see `imap-hash-headers'), and the body
-contents as a string. If HEADERS-ONLY is not nil, the body will be nil.
-Returns results of evaluating, as would `mapcar'.
-If MESSAGES are given, iterate only over those UIDs.
-Also see `imap-hash-test'."
- (imap-hash-fetch iht headers-only)
- (let ((test (imap-hash-test iht)))
- (with-current-buffer (imap-hash-get-buffer iht)
- (delq nil
- (imap-message-map (lambda (message ignored-parameter)
- (let* ((details (imap-hash-gather message))
- (headers (imap-hash-data-headers details))
- (hlist (imap-hash-get-headers headers))
- (runit (cond
- ((stringp test)
- (string-match
- test
- (format "%s" (aget hlist 'Subject))))
- ((functionp test)
- (funcall test hlist))
- ;; otherwise, return test itself
- (t test))))
- ;;(debug message headers)
- (when runit
- (funcall function
- message
- (imap-hash-get-headers
- headers)
- (imap-hash-get-body
- (imap-hash-data-body details))))))
- "UID")))))
-
-(defun imap-hash-count (iht)
- "Count the number of messages in the imap-hash IHT.
-Also see `imap-hash-test'. It uses `imap-hash-map' so just use that
-function if you want to do more than count the elements."
- (length (imap-hash-map (lambda (a b c)) iht t)))
-
-(defalias 'imap-hash-size 'imap-hash-count)
-
-(defun imap-hash-test (iht)
- "Return the test used by `imap-hash-map' for IHT.
-When the test is t, any key will be a candidate.
-When the test is a string, messages will be filtered on that string as a
-regexp against the subject.
-When the test is a function, messages will be filtered with it.
-The function is passed the message headers (see `imap-hash-get-headers')."
- (plist-get iht :test))
-
-(defun imap-hash-server (iht)
- "Return the server used by the imap-hash IHT."
- (plist-get iht :server))
-
-(defun imap-hash-port (iht)
- "Return the port used by the imap-hash IHT."
- (plist-get iht :port))
-
-(defun imap-hash-ssl (iht)
- "Return the SSL need for the imap-hash IHT."
- (plist-get iht :ssl))
-
-(defun imap-hash-mailbox (iht)
- "Return the mailbox used by the imap-hash IHT."
- (plist-get iht :mailbox))
-
-(defun imap-hash-user (iht)
- "Return the username used by the imap-hash IHT."
- (plist-get iht :user))
-
-(defun imap-hash-password (iht)
- "Return the password used by the imap-hash IHT."
- (plist-get iht :password))
-
-(defun imap-hash-open-connection (iht)
- "Open the connection used for IMAP interactions with the imap-hash IHT."
- (let* ((server (imap-hash-server iht))
- (port (imap-hash-port iht))
- (ssl-need (imap-hash-ssl iht))
- (auth-need (not (and (imap-hash-user iht)
- (imap-hash-password iht))))
- ;; this will not be needed if auth-need is t
- (auth-info (when auth-need
- (auth-source-user-or-password
- '("login" "password")
- server port)))
- (auth-user (or (imap-hash-user iht)
- (nth 0 auth-info)))
- (auth-passwd (or (imap-hash-password iht)
- (nth 1 auth-info)))
- (imap-logout-timeout nil))
-
- ;; (debug "opening server: opened+state" (imap-opened) imap-state)
- ;; this is the only place where IMAP vs IMAPS matters
- (if (imap-open server port (if ssl-need 'ssl nil) nil (current-buffer))
- (progn
- ;; (debug "after opening server: opened+state" (imap-opened (current-buffer)) imap-state)
- ;; (debug "authenticating" auth-user auth-passwd)
- (if (not (imap-capability 'IMAP4rev1))
- (error "IMAP server does not support IMAP4r1, it won't work, sorry")
- (imap-authenticate auth-user auth-passwd)
- (imap-id)
- ;; (debug "after authenticating: opened+state" (imap-opened (current-buffer)) imap-state)
- (imap-opened (current-buffer))))
- (error "Could not open the IMAP buffer"))))
-
-(defun imap-hash-get-buffer (iht)
- "Get or create the connection buffer to be used for the imap-hash IHT."
- (let* ((name (imap-hash-buffer-name iht))
- (buffer (get-buffer name)))
- (if (and buffer (imap-opened buffer))
- buffer
- (when buffer (kill-buffer buffer))
- (with-current-buffer (get-buffer-create name)
- (setq buffer-undo-list t)
- (when (imap-hash-open-connection iht)
- (current-buffer))))))
-
-(defun imap-hash-buffer-name (iht)
- "Get the connection buffer to be used for the imap-hash IHT."
- (when (imap-hash-p iht)
- (let ((server (imap-hash-server iht))
- (port (imap-hash-port iht))
- (ssl-text (if (imap-hash-ssl iht) "SSL" "NoSSL")))
- (format "*imap-hash/%s:%s:%s*" server port ssl-text))))
-
-(defun imap-hash-fetch (iht &optional headers-only &rest messages)
- "Fetch all the messages for imap-hash IHT.
-Get only the headers if HEADERS-ONLY is not nil."
- (with-current-buffer (imap-hash-get-buffer iht)
- (let ((range (if messages
- (list
- (imap-range-to-message-set messages)
- (imap-range-to-message-set messages))
- '("1:*" . "1,*:*"))))
-
- ;; (with-current-buffer "*imap-debug*"
- ;; (erase-buffer))
- (imap-mailbox-unselect)
- (imap-mailbox-select (imap-hash-mailbox iht))
- ;; (debug "after selecting mailbox: opened+state" (imap-opened) imap-state)
- ;; (setq imap-message-data (make-vector imap-message-prime 0)
- (imap-fetch-safe range
- (concat (format "(UID RFC822.SIZE BODY %s "
- (if headers-only "" "BODY.PEEK[TEXT]"))
- (format "BODY.PEEK[HEADER.FIELDS %s])"
- imap-hash-headers))))))
-
-(provide 'imap-hash)
-;;; imap-hash.el ends here
-
-;; ignore, for testing only
-
-;;; (setq iht (imap-hash-make "yourhosthere.com" "imap" "INBOX.test"))
-;;; (setq iht (imap-hash-make "yourhosthere.com" "imap" "test"))
-;;; (imap-hash-make "server1" "INBOX.mailbox2")
-;;; (imap-hash-p iht)
-;;; (imap-hash-get 35 iht)
-;;; (imap-hash-get 38 iht)
-;;; (imap-hash-get 37 iht t)
-;;; (mapc (lambda (buffer) (with-current-buffer buffer (erase-buffer))) '("*imap-debug*" "*imap-log*"))
-;;; (imap-hash-put (imap-hash-get 5 iht) iht)
-;;; (with-current-buffer (imap-hash-get-buffer iht) (let ((uid (imap-hash-put (imap-hash-get 5 iht) iht))) (imap-hash-put uid iht uid)))
-;;; (imap-hash-put (imap-hash-get 35 iht) iht)
-;;; (imap-hash-make-message '((Subject . "normal")) "normal body")
-;;; (imap-hash-make-message '((Subject . "old")) "old body" '((Subject . "new")))
-;;; (imap-hash-make-message '((Subject . "old")) "old body" '((body . "new body")) (lambda (subject) (concat "overwrite-" subject)))
-;;; (imap-hash-make-message '((Subject . "old")) "old body" '((Subject . "change this")) (lambda (subject) (concat "overwrite-" subject)))
-;;; (imap-hash-make-message '((Subject . "Twelcome")) "body here" nil)
-;; (with-current-buffer (imap-hash-get-buffer iht) (imap-hash-rem (imap-hash-put (imap-hash-get 5 iht) iht) iht))
-;;; (kill-buffer (imap-hash-buffer-name iht))
-;;; (imap-hash-map 'debug iht)
-;;; (imap-hash-map 'debug iht t)
-;;;(tramp-imap-handle-file-inode "/imap:yourhosthere.com:/test/welcome")
-;;;(imap-hash-count iht)
-;;; (mapc (lambda (buffer) (with-current-buffer buffer (erase-buffer))) '("*imap-debug*" "*imap-log*"))
-;;; (kill-buffer (imap-hash-buffer-name iht))
-;;; this should always return t if the server is up, automatically reopening if needed
-;;; (imap-opened (imap-hash-get-buffer iht))
-;;; (imap-hash-buffer-name iht)
-;;; (with-current-buffer (imap-hash-get-buffer iht) (debug "mailbox data, auth and state" imap-mailbox-data imap-auth imap-state))
-;;;(tramp-imap-handle-file-inode "/imap:yourhosthere.com:/test/welcome")
-;;; (imap-hash-fetch iht nil)
-;;; (imap-hash-fetch iht t)
-;;; (imap-hash-fetch iht nil 1 2 3)
-;;; (imap-hash-fetch iht t 1 2 3)
-
-;; arch-tag: 071410ac-91dc-4e36-b892-18e057d639c5
diff --git a/lisp/net/imap.el b/lisp/net/imap.el
index 0a20eadffcf..f4af03f100f 100644
--- a/lisp/net/imap.el
+++ b/lisp/net/imap.el
@@ -1,7 +1,6 @@
;;; imap.el --- imap library
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Simon Josefsson <simon@josefsson.org>
;; Keywords: mail
@@ -139,6 +138,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")
@@ -211,7 +211,7 @@ until a successful connection is made."
:type '(repeat string))
(defcustom imap-process-connection-type nil
- "*Value for `process-connection-type' to use for Kerberos4, GSSAPI and SSL.
+ "*Value for `process-connection-type' to use for Kerberos4, GSSAPI, shell, and SSL.
The `process-connection-type' variable controls the type of device
used to communicate with subprocesses. Values are nil to use a
pipe, or t or `pty' to use a pty. The value has no effect if the
@@ -267,7 +267,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 +475,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 +515,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 +579,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 +649,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 +700,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 +734,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 +753,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))))
@@ -786,6 +770,7 @@ sure of changing the value of `foo'."
(let* ((port (or port imap-default-port))
(coding-system-for-read imap-coding-system-for-read)
(coding-system-for-write imap-coding-system-for-write)
+ (process-connection-type imap-process-connection-type)
(process (start-process
name buffer shell-file-name shell-command-switch
(format-spec
@@ -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 f1cc534ae85..a45cc5500c2 100644
--- a/lisp/net/ldap.el
+++ b/lisp/net/ldap.el
@@ -1,7 +1,6 @@
;;; ldap.el --- client interface to LDAP for Emacs
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Oscar Figueiredo <oscar@cpe.fr>
;; Maintainer: FSF
@@ -37,13 +36,15 @@
(require 'custom)
(eval-when-compile (require 'cl))
+(autoload 'auth-source-search "auth-source")
+
(defgroup ldap nil
"Lightweight Directory Access Protocol."
:version "21.1"
: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 +52,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 +69,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 +149,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)
@@ -481,7 +482,23 @@ Additional search parameters can be specified through
"Perform a search on a LDAP server.
SEARCH-PLIST is a property list describing the search request.
Valid keys in that list are:
- `host' is a string naming one or more (blank-separated) LDAP servers to
+
+ `auth-source', if non-nil, will use `auth-source-search' and
+will grab the :host, :secret, :base, and (:user or :binddn)
+tokens into the `host', `passwd', `base', and `binddn' parameters
+respectively if they are not provided in SEARCH-PLIST. So for
+instance *each* of these netrc lines has the same effect if you
+ask for the host \"ldapserver:2400\":
+
+ machine ldapserver:2400 login myDN secret myPassword base myBase
+ machine ldapserver:2400 binddn myDN secret myPassword port ldap
+ login myDN secret myPassword base myBase
+
+but if you have more than one in your netrc file, only the first
+matching one will be used. Note the \"port ldap\" part is NOT
+required.
+
+ `host' is a string naming one or more (blank-separated) LDAP servers
to try to connect to. Each host name may optionally be of the form HOST:PORT.
`filter' is a filter string for the search as described in RFC 1558.
`attributes' is a list of strings indicating which attributes to retrieve
@@ -501,19 +518,34 @@ not their associated values.
its distinguished name DN.
The function returns a list of matching entries. Each entry is itself
an alist of attribute/value pairs."
- (let ((buf (get-buffer-create " *ldap-search*"))
+ (let* ((buf (get-buffer-create " *ldap-search*"))
(bufval (get-buffer-create " *ldap-value*"))
(host (or (plist-get search-plist 'host)
ldap-default-host))
+ ;; find entries with port "ldap" that match the requested host if any
+ (asfound (when (plist-get search-plist 'auth-source)
+ (nth 0 (auth-source-search :host (or host t)
+ :create t))))
+ ;; if no host was requested, get it from the auth-source entry
+ (host (or host (plist-get asfound :host)))
+ ;; get the password from the auth-source
+ (passwd (or (plist-get search-plist 'passwd)
+ (plist-get asfound :secret)))
+ ;; convert the password from a function call if needed
+ (passwd (if (functionp passwd) (funcall passwd) passwd))
+ ;; get the binddn from the search-list or from the
+ ;; auth-source user or binddn tokens
+ (binddn (or (plist-get search-plist 'binddn)
+ (plist-get asfound :user)
+ (plist-get asfound :binddn)))
+ (base (or (plist-get search-plist 'base)
+ (plist-get asfound :base)
+ ldap-default-base))
(filter (plist-get search-plist 'filter))
(attributes (plist-get search-plist 'attributes))
(attrsonly (plist-get search-plist 'attrsonly))
- (base (or (plist-get search-plist 'base)
- ldap-default-base))
(scope (plist-get search-plist 'scope))
- (binddn (plist-get search-plist 'binddn))
(auth (plist-get search-plist 'auth))
- (passwd (plist-get search-plist 'passwd))
(deref (plist-get search-plist 'deref))
(timelimit (plist-get search-plist 'timelimit))
(sizelimit (plist-get search-plist 'sizelimit))
@@ -556,14 +588,10 @@ an alist of attribute/value pairs."
(if (and sizelimit
(not (equal "" sizelimit)))
(setq arglist (nconc arglist (list (format "-z%s" sizelimit)))))
- (eval `(call-process ldap-ldapsearch-prog
- nil
- ;; Ignore stderr, which can corrupt results
- (list buf nil)
- nil
- ,@arglist
- ,@ldap-ldapsearch-args
- ,@filter))
+ (apply #'call-process ldap-ldapsearch-prog
+ ;; Ignore stderr, which can corrupt results
+ nil (list buf nil) nil
+ (append arglist ldap-ldapsearch-args filter))
(insert "\n")
(goto-char (point-min))
@@ -580,9 +608,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 ]+\
@@ -618,5 +644,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 a7c834b3b94..8c4bbb4a785 100644
--- a/lisp/net/mairix.el
+++ b/lisp/net/mairix.el
@@ -1,6 +1,6 @@
;;; mairix.el --- Mairix interface for Emacs
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: David Engster <dengste@eml.cc>
;; Keywords: mail searching
@@ -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)
@@ -948,4 +946,3 @@ Use cursor keys or C-n,C-p to select next/previous search.\n\n")
;;; mairix.el ends here
-;; arch-tag: 787ab678-fcd5-4c50-9295-01c2ee5124a6
diff --git a/lisp/net/net-utils.el b/lisp/net/net-utils.el
index f13b1348b88..d75b36051f0 100644
--- a/lisp/net/net-utils.el
+++ b/lisp/net/net-utils.el
@@ -1,7 +1,6 @@
;;; net-utils.el --- network functions
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Peter Breton <pbreton@cs.umb.edu>
;; Created: Sun Mar 16 1997
@@ -55,8 +54,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 +80,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."
@@ -492,6 +490,11 @@ If your system's ping continues until interrupted, you can try setting
(autoload 'comint-mode "comint" nil t)
+(defvar nslookup-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\t" 'comint-dynamic-complete)
+ map))
+
;; Using a derived mode gives us keymaps, hooks, etc.
(define-derived-mode nslookup-mode comint-mode "Nslookup"
"Major mode for interacting with the nslookup program."
@@ -501,8 +504,6 @@ If your system's ping continues until interrupted, you can try setting
(setq comint-prompt-regexp nslookup-prompt-regexp)
(setq comint-input-autoexpand t))
-(define-key nslookup-mode-map "\t" 'comint-dynamic-complete)
-
;;;###autoload
(defun dns-lookup-host (host)
"Lookup the DNS information for HOST (name or IP address)."
@@ -558,6 +559,12 @@ If your system's ping continues until interrupted, you can try setting
(list host)))
(pop-to-buffer buf)))
+(defvar ftp-mode-map
+ (let ((map (make-sparse-keymap)))
+ ;; Occasionally useful
+ (define-key map "\t" 'comint-dynamic-complete)
+ map))
+
(define-derived-mode ftp-mode comint-mode "FTP"
"Major mode for interacting with the ftp program."
(setq comint-prompt-regexp ftp-prompt-regexp)
@@ -573,9 +580,6 @@ If your system's ping continues until interrupted, you can try setting
(add-hook 'comint-output-filter-functions 'comint-watch-for-password-prompt
nil t)))
-;; Occasionally useful
-(define-key ftp-mode-map "\t" 'comint-dynamic-complete)
-
(defun smbclient (host service)
"Connect to SERVICE on HOST via SMB."
(interactive
@@ -889,5 +893,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 17fea10cf62..b04863b5fc0 100644
--- a/lisp/net/netrc.el
+++ b/lisp/net/netrc.el
@@ -1,9 +1,9 @@
;;; netrc.el --- .netrc parsing functionality
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
+;;
;; Modularized by Ted Zlatanov <tzz@lifelogs.com>
;; when it was part of Gnus.
@@ -33,45 +33,44 @@
;;; .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)
- (defalias 'netrc-bound-and-true-p 'bound-and-true-p)
- (defmacro netrc-bound-and-true-p (var)
- "Return the value of symbol VAR if it is bound, else nil."
- `(and (boundp (quote ,var)) ,var))))
-
(defgroup netrc nil
"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)
+(defvar netrc-cache nil)
+
+(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)
+ ;; We got already parsed contents; just return it.
file
(when (file-exists-p file)
(with-temp-buffer
(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))
+ (if (and netrc-cache
+ (equal (car netrc-cache) (nth 5 (file-attributes file))))
+ (insert (base64-decode-string (rot13-string (cdr netrc-cache))))
+ (insert-file-contents file)
+ (when (string-match "\\.gpg\\'" file)
+ ;; Store the contents of the file heavily encrypted in memory.
+ (setq netrc-cache (cons (nth 5 (file-attributes file))
+ (rot13-string
+ (base64-encode-string
+ (buffer-string)))))))
(goto-char (point-min))
;; Go through the file, line by line.
(while (not (eobp))
@@ -131,19 +130,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 +162,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 +223,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/network-stream.el b/lisp/net/network-stream.el
new file mode 100644
index 00000000000..61e4630906d
--- /dev/null
+++ b/lisp/net/network-stream.el
@@ -0,0 +1,292 @@
+;;; network-stream.el --- open network processes, possibly with encryption
+
+;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Keywords: network
+
+;; 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 provides the function `open-network-stream', which provides a
+;; higher-level interface for opening TCP network processes than the built-in
+;; function `make-network-process'. In addition to plain connections, it
+;; supports TLS/SSL and STARTTLS connections.
+
+;; Usage example:
+
+;; (open-network-stream
+;; "*nnimap*" buffer address port
+;; :type 'network
+;; :capability-command "1 CAPABILITY\r\n"
+;; :success " OK "
+;; :starttls-function
+;; (lambda (capabilities)
+;; (if (not (string-match "STARTTLS" capabilities))
+;; nil
+;; "1 STARTTLS\r\n")))
+
+;;; Code:
+
+(require 'tls)
+(require 'starttls)
+
+(declare-function gnutls-negotiate "gnutls" t t) ; defun*
+
+;;;###autoload
+(defun open-network-stream (name buffer host service &rest parameters)
+ "Open a TCP connection to HOST, optionally with encryption.
+Normally, return a network process object; with a non-nil
+:return-list parameter, return a list instead (see below).
+Input and output work as for subprocesses; `delete-process'
+closes it.
+
+NAME is the name for the process. It is modified if necessary to
+ make it unique.
+BUFFER is a buffer or buffer name to associate with the process.
+ Process output goes at end of that buffer. BUFFER may be nil,
+ meaning that the process is not associated with any buffer.
+HOST is the name or IP address of the host to connect to.
+SERVICE is the name of the service desired, or an integer specifying
+ a port number to connect to.
+
+The remaining PARAMETERS should be a sequence of keywords and
+values:
+
+:type specifies the connection type, one of the following:
+ nil or `network'
+ -- Begin with an ordinary network connection, and if
+ the parameters :success and :capability-command
+ are also supplied, try to upgrade to an encrypted
+ connection via STARTTLS. Even if that
+ fails (e.g. if HOST does not support TLS), retain
+ an unencrypted connection.
+ `plain' -- An ordinary, unencrypted network connection.
+ `starttls' -- Begin with an ordinary connection, and try
+ upgrading via STARTTLS. If that fails for any
+ reason, drop the connection; in that case the
+ returned object is a killed process.
+ `tls' -- A TLS connection.
+ `ssl' -- Equivalent to `tls'.
+ `shell' -- A shell connection.
+
+:return-list specifies this function's return value.
+ If omitted or nil, return a process object. A non-nil means to
+ return (PROC . PROPS), where PROC is a process object and PROPS
+ is a plist of connection properties, with these keywords:
+ :greeting -- the greeting returned by HOST (a string), or nil.
+ :capabilities -- a string representing HOST's capabilities,
+ or nil if none could be found.
+ :type -- the resulting connection type; `plain' (unencrypted)
+ or `tls' (TLS-encrypted).
+
+:end-of-command specifies a regexp matching the end of a command.
+
+:success specifies a regexp matching a message indicating a
+ successful STARTTLS negotiation. For instance, the default
+ should be \"^3\" for an NNTP connection.
+
+:capability-command specifies a command used to query the HOST
+ for its capabilities. For instance, for IMAP this should be
+ \"1 CAPABILITY\\r\\n\".
+
+:starttls-function specifies a function for handling STARTTLS.
+ This function should take one parameter, the response to the
+ capability command, and should return the command to switch on
+ STARTTLS if the server supports STARTTLS, and nil otherwise.
+
+:nowait is a boolean that says the connection should be made
+asynchronously, if possible."
+ (unless (featurep 'make-network-process)
+ (error "Emacs was compiled without networking support"))
+ (let ((type (plist-get parameters :type))
+ (return-list (plist-get parameters :return-list)))
+ (if (and (not return-list)
+ (or (eq type 'plain)
+ (and (memq type '(nil network))
+ (not (and (plist-get parameters :success)
+ (plist-get parameters :capability-command))))))
+ ;; The simplest case: wrapper around `make-network-process'.
+ (make-network-process :name name :buffer buffer
+ :host host :service service
+ :nowait (plist-get parameters :nowait))
+ (let ((work-buffer (or buffer
+ (generate-new-buffer " *stream buffer*")))
+ (fun (cond ((eq type 'plain) 'network-stream-open-plain)
+ ((memq type '(nil network starttls))
+ 'network-stream-open-starttls)
+ ((memq type '(tls ssl)) 'network-stream-open-tls)
+ ((eq type 'shell) 'network-stream-open-shell)
+ (t (error "Invalid connection type %s" type))))
+ result)
+ (unwind-protect
+ (setq result (funcall fun name work-buffer host service parameters))
+ (unless buffer
+ (and (processp (car result))
+ (set-process-buffer (car result) nil))
+ (kill-buffer work-buffer)))
+ (if return-list
+ (list (car result)
+ :greeting (nth 1 result)
+ :capabilities (nth 2 result)
+ :type (nth 3 result))
+ (car result))))))
+
+;;;###autoload
+(defalias 'open-protocol-stream 'open-network-stream)
+
+(defun network-stream-open-plain (name buffer host service parameters)
+ (let ((start (with-current-buffer buffer (point)))
+ (stream (make-network-process :name name :buffer buffer
+ :host host :service service
+ :nowait (plist-get parameters :nowait))))
+ (list stream
+ (network-stream-get-response stream start
+ (plist-get parameters :end-of-command))
+ nil
+ 'plain)))
+
+(defun network-stream-open-starttls (name buffer host service parameters)
+ (let* ((start (with-current-buffer buffer (point)))
+ (require-tls (eq (plist-get parameters :type) 'starttls))
+ (starttls-function (plist-get parameters :starttls-function))
+ (success-string (plist-get parameters :success))
+ (capability-command (plist-get parameters :capability-command))
+ (eoc (plist-get parameters :end-of-command))
+ ;; Return (STREAM GREETING CAPABILITIES RESULTING-TYPE)
+ (stream (make-network-process :name name :buffer buffer
+ :host host :service service))
+ (greeting (network-stream-get-response stream start eoc))
+ (capabilities (network-stream-command stream capability-command eoc))
+ (resulting-type 'plain)
+ starttls-command)
+
+ ;; If we have built-in STARTTLS support, try to upgrade the
+ ;; connection.
+ (when (and (or (fboundp 'open-gnutls-stream)
+ (and require-tls
+ (executable-find "gnutls-cli")))
+ capabilities success-string starttls-function
+ (setq starttls-command
+ (funcall starttls-function capabilities)))
+ ;; If using external STARTTLS, drop this connection and start
+ ;; anew with `starttls-open-stream'.
+ (unless (fboundp 'open-gnutls-stream)
+ (delete-process stream)
+ (setq start (with-current-buffer buffer (point-max)))
+ (let* ((starttls-use-gnutls t)
+ (starttls-extra-arguments
+ (if require-tls
+ starttls-extra-arguments
+ ;; For opportunistic TLS upgrades, we don't really
+ ;; care about the identity of the peer.
+ (cons "--insecure" starttls-extra-arguments))))
+ (setq stream (starttls-open-stream name buffer host service)))
+ (network-stream-get-response stream start eoc))
+ (when (string-match success-string
+ (network-stream-command stream starttls-command eoc))
+ ;; The server said it was OK to begin STARTTLS negotiations.
+ (if (fboundp 'open-gnutls-stream)
+ (gnutls-negotiate :process stream :hostname host)
+ (unless (starttls-negotiate stream)
+ (delete-process stream)))
+ (if (memq (process-status stream) '(open run))
+ (setq resulting-type 'tls)
+ ;; We didn't successfully negotiate STARTTLS; if TLS
+ ;; isn't demanded, reopen an unencrypted connection.
+ (unless require-tls
+ (setq stream
+ (make-network-process :name name :buffer buffer
+ :host host :service service))
+ (network-stream-get-response stream start eoc)))
+ ;; Re-get the capabilities, which may have now changed.
+ (setq capabilities
+ (network-stream-command stream capability-command eoc))))
+
+ ;; If TLS is mandatory, close the connection if it's unencrypted.
+ (and require-tls
+ (eq resulting-type 'plain)
+ (delete-process stream))
+ ;; Return value:
+ (list stream greeting capabilities resulting-type)))
+
+(defun network-stream-command (stream command eoc)
+ (when command
+ (let ((start (with-current-buffer (process-buffer stream) (point-max))))
+ (process-send-string stream command)
+ (network-stream-get-response stream start eoc))))
+
+(defun network-stream-get-response (stream start end-of-command)
+ (when end-of-command
+ (with-current-buffer (process-buffer stream)
+ (save-excursion
+ (goto-char start)
+ (while (and (memq (process-status stream) '(open run))
+ (not (re-search-forward end-of-command nil t)))
+ (accept-process-output stream 0 50)
+ (goto-char start))
+ ;; Return the data we got back, or nil if the process died.
+ (unless (= start (point))
+ (buffer-substring start (point)))))))
+
+(defun network-stream-open-tls (name buffer host service parameters)
+ (with-current-buffer buffer
+ (let* ((start (point-max))
+ (use-builtin-gnutls (fboundp 'open-gnutls-stream))
+ (stream
+ (funcall (if use-builtin-gnutls
+ 'open-gnutls-stream
+ 'open-tls-stream)
+ name buffer host service))
+ (eoc (plist-get parameters :end-of-command)))
+ (if (null stream)
+ (list nil nil nil 'plain)
+ ;; If we're using tls.el, we have to delete the output from
+ ;; openssl/gnutls-cli.
+ (when (and (null use-builtin-gnutls) eoc)
+ (network-stream-get-response stream start eoc)
+ (goto-char (point-min))
+ (when (re-search-forward eoc nil t)
+ (goto-char (match-beginning 0))
+ (delete-region (point-min) (line-beginning-position))))
+ (let* ((capability-command (plist-get parameters :capability-command)))
+ (list stream
+ (network-stream-get-response stream start eoc)
+ (network-stream-command stream capability-command eoc)
+ 'tls))))))
+
+(defun network-stream-open-shell (name buffer host service parameters)
+ (require 'format-spec)
+ (let* ((capability-command (plist-get parameters :capability-command))
+ (eoc (plist-get parameters :end-of-command))
+ (start (with-current-buffer buffer (point)))
+ (stream (let ((process-connection-type nil))
+ (start-process name buffer shell-file-name
+ shell-command-switch
+ (format-spec
+ (plist-get parameters :shell-command)
+ (format-spec-make
+ ?s host
+ ?p service))))))
+ (list stream
+ (network-stream-get-response stream start eoc)
+ (network-stream-command stream capability-command eoc)
+ 'plain)))
+
+(provide 'network-stream)
+
+;;; network-stream.el ends here
diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el
index 677a7c12780..039d709770e 100644
--- a/lisp/net/newst-backend.el
+++ b/lisp/net/newst-backend.el
@@ -1,13 +1,13 @@
;;; newst-backend.el --- Retrieval backend for newsticker.
-;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2003-2011 Free Software Foundation, Inc.
;; Author: Ulf Jasper <ulf.jasper@web.de>
;; Filename: newst-backend.el
;; URL: http://www.nongnu.org/newsticker
;; Keywords: News, RSS, Atom
;; Time-stamp: "6. Dezember 2009, 19:15:32 (ulf)"
+;; Package: newsticker
;; ======================================================================
@@ -2352,5 +2352,4 @@ This function is suited for adding it to `newsticker-new-item-functions'."
(provide 'newst-backend)
-;; arch-tag: 0e37b658-56e9-49ab-90f9-f2df57e1a659
;;; newst-backend.el ends here
diff --git a/lisp/net/newst-plainview.el b/lisp/net/newst-plainview.el
index 5bf56bd9d7a..cd662cb1784 100644
--- a/lisp/net/newst-plainview.el
+++ b/lisp/net/newst-plainview.el
@@ -1,12 +1,12 @@
;;; newst-plainview.el --- Single buffer frontend for newsticker.
-;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2003-2011 Free Software Foundation, Inc.
;; Author: Ulf Jasper <ulf.jasper@web.de>
;; Filename: newst-plainview.el
;; URL: http://www.nongnu.org/newsticker
;; Time-stamp: "6. Dezember 2009, 19:17:02 (ulf)"
+;; Package: newsticker
;; ======================================================================
@@ -378,6 +378,107 @@ images."
;;; Newsticker mode
;; ======================================================================
+
+;; newsticker menu
+(defvar newsticker-menu
+ (let ((map (make-sparse-keymap "Newsticker")))
+
+ (define-key map [newsticker-browse-url]
+ '("Browse URL for item at point" . newsticker-browse-url))
+ (define-key map [newsticker-separator-1]
+ '("--"))
+ (define-key map [newsticker-buffer-update]
+ '("Update buffer" . newsticker-buffer-update))
+ (define-key map [newsticker-separator-2]
+ '("--"))
+ (define-key map [newsticker-get-all-news]
+ '("Get news from all feeds" . newsticker-get-all-news))
+ (define-key map [newsticker-get-news-at-point]
+ '("Get news from feed at point" . newsticker-get-news-at-point))
+ (define-key map [newsticker-separator-3]
+ '("--"))
+ (define-key map [newsticker-mark-all-items-as-read]
+ '("Mark all items as read" . newsticker-mark-all-items-as-read))
+ (define-key map [newsticker-mark-all-items-at-point-as-read]
+ '("Mark all items in feed at point as read" .
+ newsticker-mark-all-items-at-point-as-read))
+ (define-key map [newsticker-mark-item-at-point-as-read]
+ '("Mark item at point as read" .
+ newsticker-mark-item-at-point-as-read))
+ (define-key map [newsticker-mark-item-at-point-as-immortal]
+ '("Toggle immortality for item at point" .
+ newsticker-mark-item-at-point-as-immortal))
+ (define-key map [newsticker-separator-4]
+ '("--"))
+ (define-key map [newsticker-toggle-auto-narrow-to-item]
+ '("Narrow to single item" . newsticker-toggle-auto-narrow-to-item))
+ (define-key map [newsticker-toggle-auto-narrow-to-feed]
+ '("Narrow to single news feed" . newsticker-toggle-auto-narrow-to-feed))
+ (define-key map [newsticker-hide-old-items]
+ '("Hide old items" . newsticker-hide-old-items))
+ (define-key map [newsticker-show-old-items]
+ '("Show old items" . newsticker-show-old-items))
+ (define-key map [newsticker-next-item]
+ '("Go to next item" . newsticker-next-item))
+ (define-key map [newsticker-previous-item]
+ '("Go to previous item" . newsticker-previous-item))
+ map))
+
+(defvar newsticker-mode-map
+ (let ((map (make-keymap)))
+ (define-key map "sO" 'newsticker-show-old-items)
+ (define-key map "hO" 'newsticker-hide-old-items)
+ (define-key map "sa" 'newsticker-show-all-desc)
+ (define-key map "ha" 'newsticker-hide-all-desc)
+ (define-key map "sf" 'newsticker-show-feed-desc)
+ (define-key map "hf" 'newsticker-hide-feed-desc)
+ (define-key map "so" 'newsticker-show-old-item-desc)
+ (define-key map "ho" 'newsticker-hide-old-item-desc)
+ (define-key map "sn" 'newsticker-show-new-item-desc)
+ (define-key map "hn" 'newsticker-hide-new-item-desc)
+ (define-key map "se" 'newsticker-show-entry)
+ (define-key map "he" 'newsticker-hide-entry)
+ (define-key map "sx" 'newsticker-show-extra)
+ (define-key map "hx" 'newsticker-hide-extra)
+
+ (define-key map " " 'scroll-up)
+ (define-key map "q" 'newsticker-close-buffer)
+ (define-key map "p" 'newsticker-previous-item)
+ (define-key map "P" 'newsticker-previous-new-item)
+ (define-key map "F" 'newsticker-previous-feed)
+ (define-key map "\t" 'newsticker-next-item)
+ (define-key map "n" 'newsticker-next-item)
+ (define-key map "N" 'newsticker-next-new-item)
+ (define-key map "f" 'newsticker-next-feed)
+ (define-key map "M" 'newsticker-mark-all-items-as-read)
+ (define-key map "m"
+ 'newsticker-mark-all-items-at-point-as-read-and-redraw)
+ (define-key map "o"
+ 'newsticker-mark-item-at-point-as-read)
+ (define-key map "O"
+ 'newsticker-mark-all-items-at-point-as-read)
+ (define-key map "G" 'newsticker-get-all-news)
+ (define-key map "g" 'newsticker-get-news-at-point)
+ (define-key map "u" 'newsticker-buffer-update)
+ (define-key map "U" 'newsticker-buffer-force-update)
+ (define-key map "a" 'newsticker-add-url)
+
+ (define-key map "i"
+ 'newsticker-mark-item-at-point-as-immortal)
+
+ (define-key map "xf"
+ 'newsticker-toggle-auto-narrow-to-feed)
+ (define-key map "xi"
+ 'newsticker-toggle-auto-narrow-to-item)
+
+ ;; Bind menu to mouse.
+ (define-key map [down-mouse-3] newsticker-menu)
+ ;; Put menu in menu-bar.
+ (define-key map [menu-bar Newsticker]
+ (cons "Newsticker" newsticker-menu))
+
+ map))
+
(define-derived-mode newsticker-mode fundamental-mode
"NewsTicker"
"Viewing news feeds in Emacs."
@@ -414,114 +515,16 @@ images."
(add-to-invisibility-spec 'extra))
(newsticker--buffer-set-uptodate nil))
-;; refine its mode-map
-(define-key newsticker-mode-map "sO" 'newsticker-show-old-items)
-(define-key newsticker-mode-map "hO" 'newsticker-hide-old-items)
-(define-key newsticker-mode-map "sa" 'newsticker-show-all-desc)
-(define-key newsticker-mode-map "ha" 'newsticker-hide-all-desc)
-(define-key newsticker-mode-map "sf" 'newsticker-show-feed-desc)
-(define-key newsticker-mode-map "hf" 'newsticker-hide-feed-desc)
-(define-key newsticker-mode-map "so" 'newsticker-show-old-item-desc)
-(define-key newsticker-mode-map "ho" 'newsticker-hide-old-item-desc)
-(define-key newsticker-mode-map "sn" 'newsticker-show-new-item-desc)
-(define-key newsticker-mode-map "hn" 'newsticker-hide-new-item-desc)
-(define-key newsticker-mode-map "se" 'newsticker-show-entry)
-(define-key newsticker-mode-map "he" 'newsticker-hide-entry)
-(define-key newsticker-mode-map "sx" 'newsticker-show-extra)
-(define-key newsticker-mode-map "hx" 'newsticker-hide-extra)
-
-(define-key newsticker-mode-map " " 'scroll-up)
-(define-key newsticker-mode-map "q" 'newsticker-close-buffer)
-(define-key newsticker-mode-map "p" 'newsticker-previous-item)
-(define-key newsticker-mode-map "P" 'newsticker-previous-new-item)
-(define-key newsticker-mode-map "F" 'newsticker-previous-feed)
-(define-key newsticker-mode-map "\t" 'newsticker-next-item)
-(define-key newsticker-mode-map "n" 'newsticker-next-item)
-(define-key newsticker-mode-map "N" 'newsticker-next-new-item)
-(define-key newsticker-mode-map "f" 'newsticker-next-feed)
-(define-key newsticker-mode-map "M" 'newsticker-mark-all-items-as-read)
-(define-key newsticker-mode-map "m"
- 'newsticker-mark-all-items-at-point-as-read-and-redraw)
-(define-key newsticker-mode-map "o"
- 'newsticker-mark-item-at-point-as-read)
-(define-key newsticker-mode-map "O"
- 'newsticker-mark-all-items-at-point-as-read)
-(define-key newsticker-mode-map "G" 'newsticker-get-all-news)
-(define-key newsticker-mode-map "g" 'newsticker-get-news-at-point)
-(define-key newsticker-mode-map "u" 'newsticker-buffer-update)
-(define-key newsticker-mode-map "U" 'newsticker-buffer-force-update)
-(define-key newsticker-mode-map "a" 'newsticker-add-url)
-
-(define-key newsticker-mode-map "i"
- 'newsticker-mark-item-at-point-as-immortal)
-
-(define-key newsticker-mode-map "xf"
- 'newsticker-toggle-auto-narrow-to-feed)
-(define-key newsticker-mode-map "xi"
- 'newsticker-toggle-auto-narrow-to-item)
-
;; maps for the clickable portions
-(defvar newsticker--url-keymap (make-sparse-keymap)
+(defvar newsticker--url-keymap
+ (let ((map (make-sparse-keymap)))
+ (define-key map [mouse-1] 'newsticker-mouse-browse-url)
+ (define-key map [mouse-2] 'newsticker-mouse-browse-url)
+ (define-key map "\n" 'newsticker-browse-url)
+ (define-key map "\C-m" 'newsticker-browse-url)
+ (define-key map [(control return)] 'newsticker-handle-url)
+ map)
"Key map for click-able headings in the newsticker buffer.")
-(define-key newsticker--url-keymap [mouse-1]
- 'newsticker-mouse-browse-url)
-(define-key newsticker--url-keymap [mouse-2]
- 'newsticker-mouse-browse-url)
-(define-key newsticker--url-keymap "\n"
- 'newsticker-browse-url)
-(define-key newsticker--url-keymap "\C-m"
- 'newsticker-browse-url)
-(define-key newsticker--url-keymap [(control return)]
- 'newsticker-handle-url)
-
-;; newsticker menu
-(defvar newsticker-menu (make-sparse-keymap "Newsticker"))
-
-(define-key newsticker-menu [newsticker-browse-url]
- '("Browse URL for item at point" . newsticker-browse-url))
-(define-key newsticker-menu [newsticker-separator-1]
- '("--"))
-(define-key newsticker-menu [newsticker-buffer-update]
- '("Update buffer" . newsticker-buffer-update))
-(define-key newsticker-menu [newsticker-separator-2]
- '("--"))
-(define-key newsticker-menu [newsticker-get-all-news]
- '("Get news from all feeds" . newsticker-get-all-news))
-(define-key newsticker-menu [newsticker-get-news-at-point]
- '("Get news from feed at point" . newsticker-get-news-at-point))
-(define-key newsticker-menu [newsticker-separator-3]
- '("--"))
-(define-key newsticker-menu [newsticker-mark-all-items-as-read]
- '("Mark all items as read" . newsticker-mark-all-items-as-read))
-(define-key newsticker-menu [newsticker-mark-all-items-at-point-as-read]
- '("Mark all items in feed at point as read" .
- newsticker-mark-all-items-at-point-as-read))
-(define-key newsticker-menu [newsticker-mark-item-at-point-as-read]
- '("Mark item at point as read" .
- newsticker-mark-item-at-point-as-read))
-(define-key newsticker-menu [newsticker-mark-item-at-point-as-immortal]
- '("Toggle immortality for item at point" .
- newsticker-mark-item-at-point-as-immortal))
-(define-key newsticker-menu [newsticker-separator-4]
- '("--"))
-(define-key newsticker-menu [newsticker-toggle-auto-narrow-to-item]
- '("Narrow to single item" . newsticker-toggle-auto-narrow-to-item))
-(define-key newsticker-menu [newsticker-toggle-auto-narrow-to-feed]
- '("Narrow to single news feed" . newsticker-toggle-auto-narrow-to-feed))
-(define-key newsticker-menu [newsticker-hide-old-items]
- '("Hide old items" . newsticker-hide-old-items))
-(define-key newsticker-menu [newsticker-show-old-items]
- '("Show old items" . newsticker-show-old-items))
-(define-key newsticker-menu [newsticker-next-item]
- '("Go to next item" . newsticker-next-item))
-(define-key newsticker-menu [newsticker-previous-item]
- '("Go to previous item" . newsticker-previous-item))
-
-;; bind menu to mouse
-(define-key newsticker-mode-map [down-mouse-3] newsticker-menu)
-;; Put menu in menu-bar
-(define-key newsticker-mode-map [menu-bar Newsticker]
- (cons "Newsticker" newsticker-menu))
;; ======================================================================
@@ -1799,5 +1802,4 @@ Take care: end of item is at the end of its last line!"
(provide 'newst-plainview)
-;; arch-tag: 4e48b683-d48b-48dd-a13e-fe45baf41184
;;; newst-plainview.el ends here
diff --git a/lisp/net/newst-reader.el b/lisp/net/newst-reader.el
index 75f20f9b73a..dd076bcf4f0 100644
--- a/lisp/net/newst-reader.el
+++ b/lisp/net/newst-reader.el
@@ -1,12 +1,12 @@
;;; newst-reader.el --- Generic RSS reader functions.
-;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2003-2011 Free Software Foundation, Inc.
;; Author: Ulf Jasper <ulf.jasper@web.de>
;; Filename: newst-reader.el
;; URL: http://www.nongnu.org/newsticker
;; Time-stamp: "6. Dezember 2009, 19:16:38 (ulf)"
+;; Package: newsticker
;; ======================================================================
@@ -1180,5 +1180,4 @@ static char * visit_xpm[] = {
(provide 'newst-reader)
-;; arch-tag: c604b701-bdf1-4fc1-8d05-5fabd1939533
;;; newst-reader.el ends here
diff --git a/lisp/net/newst-ticker.el b/lisp/net/newst-ticker.el
index 15fd13624be..cb82bb74048 100644
--- a/lisp/net/newst-ticker.el
+++ b/lisp/net/newst-ticker.el
@@ -1,13 +1,13 @@
;; newst-ticker.el --- modeline ticker for newsticker.
-;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2003-2011 Free Software Foundation, Inc.
;; Author: Ulf Jasper <ulf.jasper@web.de>
;; Filename: newst-ticker.el
;; URL: http://www.nongnu.org/newsticker
;; Keywords: News, RSS, Atom
;; Time-stamp: "6. Dezember 2009, 19:16:00 (ulf)"
+;; Package: newsticker
;; ======================================================================
@@ -289,5 +289,4 @@ running already."
(provide 'newst-ticker)
-;; arch-tag: faee3ebb-749b-4935-9835-7f36d4b700f0
;;; newst-ticker.el ends here
diff --git a/lisp/net/newst-treeview.el b/lisp/net/newst-treeview.el
index 8afe22a7904..58d86b23946 100644
--- a/lisp/net/newst-treeview.el
+++ b/lisp/net/newst-treeview.el
@@ -1,6 +1,6 @@
;;; newst-treeview.el --- Treeview frontend for newsticker.
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Ulf Jasper <ulf.jasper@web.de>
;; Filename: newst-treeview.el
@@ -8,6 +8,7 @@
;; Created: 2007
;; Keywords: News, RSS, Atom
;; Time-stamp: "6. Dezember 2009, 19:17:28 (ulf)"
+;; Package: newsticker
;; ======================================================================
@@ -2075,5 +2076,4 @@ POS gives the position where EVENT occurred."
(provide 'newst-treeview)
-;; arch-tag: 5dbaff48-1f3e-4fc6-8ebd-e966fc90d2d4
;;; newst-treeview.el ends here
diff --git a/lisp/net/newsticker.el b/lisp/net/newsticker.el
index 2f6897d64f4..3a2cf3f04f7 100644
--- a/lisp/net/newsticker.el
+++ b/lisp/net/newsticker.el
@@ -1,7 +1,6 @@
;;; newsticker.el --- A Newsticker for Emacs.
-;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2003-2011 Free Software Foundation, Inc.
;; Author: Ulf Jasper <ulf.jasper@web.de>
;; Filename: newsticker.el
@@ -9,6 +8,7 @@
;; Created: 17. June 2003
;; Keywords: News, RSS, Atom
;; Time-stamp: "6. Dezember 2009, 19:15:18 (ulf)"
+;; Version: 1.99
;; ======================================================================
@@ -408,5 +408,4 @@
(provide 'newsticker)
-;; arch-tag: ab761dfa-67bc-4207-bc64-4307271dc381
;;; newsticker.el ends here
diff --git a/lisp/net/ntlm.el b/lisp/net/ntlm.el
index 10bcb19a93a..25e7a7b43de 100644
--- a/lisp/net/ntlm.el
+++ b/lisp/net/ntlm.el
@@ -1,6 +1,6 @@
;;; ntlm.el --- NTLM (NT LanManager) authentication support
-;; Copyright (C) 2001, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2007-2011 Free Software Foundation, Inc.
;; Author: Taro Kawagishi <tarok@transpulse.org>
;; Keywords: NTLM, SASL
@@ -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 11f68533864..c3da1707165 100644
--- a/lisp/net/quickurl.el
+++ b/lisp/net/quickurl.el
@@ -1,7 +1,6 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Dave Pearson <davep@davep.org>
;; Maintainer: Dave Pearson <davep@davep.org>
@@ -173,7 +172,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 +432,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,23 +505,21 @@ 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
(insert
(case type
- ('url (funcall quickurl-format-function url))
- ('naked-url (quickurl-url-url url))
- ('with-lookup (format "%s <URL:%s>"
+ (url (funcall quickurl-format-function url))
+ (naked-url (quickurl-url-url url))
+ (with-lookup (format "%s <URL:%s>"
(quickurl-url-keyword url)
(quickurl-url-url url)))
- ('with-desc (format "%S <URL:%s>"
+ (with-desc (format "%S <URL:%s>"
(quickurl-url-description url)
(quickurl-url-url url)))
- ('lookup (quickurl-url-keyword url)))))
+ (lookup (quickurl-url-keyword url)))))
(error "No URL details on that line"))
url))
@@ -544,5 +539,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 818128142f8..206ebc8997c 100644
--- a/lisp/net/rcirc.el
+++ b/lisp/net/rcirc.el
@@ -1,9 +1,10 @@
;;; rcirc.el --- default, simple IRC client.
-;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2005-2011 Free Software Foundation, Inc.
-;; Author: Ryan Yeske
-;; URL: http://www.nongnu.org/rcirc
+;; Author: Ryan Yeske <rcyeske@gmail.com>
+;; Maintainers: Ryan Yeske <rcyeske@gmail.com>,
+;; Deniz Dogan <deniz@dogan.se>
;; Keywords: comm
;; This file is part of GNU Emacs.
@@ -54,7 +55,10 @@
:group 'applications)
(defcustom rcirc-server-alist
- '(("irc.freenode.net" :channels ("#rcirc")))
+ '(("irc.freenode.net" :channels ("#rcirc")
+ ;; Don't use the TLS port by default, in case gnutls is not available.
+ ;; :port 7000 :encryption tls
+ ))
"An alist of IRC connections to establish when running `rcirc'.
Each element looks like (SERVER-NAME PARAMETERS).
@@ -94,14 +98,22 @@ used.
VALUE must be a list of strings describing which channels to join
when connecting to this server. If absent, no channels will be
-connected to automatically."
+connected to automatically.
+
+`:encryption'
+
+VALUE must be `plain' (the default) for unencrypted connections, or `tls'
+for connections using SSL/TLS."
:type '(alist :key-type string
- :value-type (plist :options ((:nick string)
- (:port integer)
- (:user-name string)
- (:password string)
- (:full-name string)
- (:channels (repeat string)))))
+ :value-type (plist :options
+ ((:nick string)
+ (:port integer)
+ (:user-name string)
+ (:password string)
+ (:full-name string)
+ (:channels (repeat string))
+ (:encryption (choice (const tls)
+ (const plain))))))
:group 'rcirc)
(defcustom rcirc-default-port 6667
@@ -114,15 +126,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)
@@ -203,12 +215,14 @@ The ARGUMENTS for each METHOD symbol are:
`nickserv': NICK PASSWORD [NICKSERV-NICK]
`chanserv': NICK CHANNEL PASSWORD
`bitlbee': NICK PASSWORD
+ `quakenet': ACCOUNT PASSWORD
Examples:
((\"freenode\" nickserv \"bob\" \"p455w0rd\")
(\"freenode\" chanserv \"bob\" \"#bobland\" \"passwd99\")
(\"bitlbee\" bitlbee \"robert\" \"sekrit\")
- (\"dal.net\" nickserv \"bob\" \"sekrit\" \"NickServ@services.dal.net\"))"
+ (\"dal.net\" nickserv \"bob\" \"sekrit\" \"NickServ@services.dal.net\")
+ (\"quakenet.org\" quakenet \"bobby\" \"sekrit\"))"
:type '(alist :key-type (string :tag "Server")
:value-type (choice (list :tag "NickServ"
(const nickserv)
@@ -222,7 +236,11 @@ Examples:
(list :tag "BitlBee"
(const bitlbee)
(string :tag "Nick")
- (string :tag "Password"))))
+ (string :tag "Password"))
+ (list :tag "QuakeNet"
+ (const quakenet)
+ (string :tag "Account")
+ (string :tag "Password"))))
:group 'rcirc)
(defcustom rcirc-auto-authenticate-flag t
@@ -231,6 +249,13 @@ See also `rcirc-authinfo'."
:type 'boolean
:group 'rcirc)
+(defcustom rcirc-authenticate-before-join t
+ "*Non-nil means authenticate to services before joining channels.
+Currently only works with NickServ on some networks."
+ :version "24.1"
+ :type 'boolean
+ :group 'rcirc)
+
(defcustom rcirc-prompt "> "
"Prompt string to use in IRC buffers.
@@ -281,6 +306,9 @@ Called with 5 arguments, PROCESS, SENDER, RESPONSE, TARGET and TEXT."
:type 'hook
:group 'rcirc)
+(defvar rcirc-authenticated-hook nil
+ "Hook run after successfully authenticated.")
+
(defcustom rcirc-always-use-server-buffer-flag nil
"Non-nil means messages without a channel target will go to the server buffer."
:type 'boolean
@@ -321,6 +349,16 @@ and the cdr part is used for encoding."
:type 'function
:group 'rcirc)
+(defcustom rcirc-nick-completion-format "%s: "
+ "Format string to use in nick completions.
+
+The format string is only used when completing at the beginning
+of a line. The string is passed as the first argument to
+`format' with the nickname as the second argument."
+ :version "24.1"
+ :type 'string
+ :group 'rcirc)
+
(defvar rcirc-nick nil)
(defvar rcirc-prompt-start-marker nil)
@@ -375,6 +413,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,22 +440,26 @@ 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
(plist-get server-plist
:channels)
" "))
- "[, ]+" t)))
-
- (when (= 0 (length password))
- (setq password nil))
-
- (rcirc-connect server port nick rcirc-default-user-name
+ "[, ]+" t))
+ (encryption
+ (intern (completing-read "Encryption (default plain): "
+ '("plain" "tls")
+ nil t nil nil "plain"))))
+ (rcirc-connect server port nick user-name
rcirc-default-full-name
- channels password))
+ channels password encryption))
;; connect to servers in `rcirc-server-alist'
(let (connected-servers)
(dolist (c rcirc-server-alist)
@@ -426,7 +471,8 @@ If ARG is non-nil, instead prompt for connection parameters."
(full-name (or (plist-get (cdr c) :full-name)
rcirc-default-full-name))
(channels (plist-get (cdr c) :channels))
- (password (plist-get (cdr c) :password)))
+ (password (plist-get (cdr c) :password))
+ (encryption (plist-get (cdr c) :encryption)))
(when server
(let (connected)
(dolist (p (rcirc-process-list))
@@ -435,7 +481,7 @@ If ARG is non-nil, instead prompt for connection parameters."
(if (not connected)
(condition-case e
(rcirc-connect server port nick user-name
- full-name channels password)
+ full-name channels password encryption)
(quit (message "Quit connecting to %s" server)))
(with-current-buffer (process-buffer connected)
(setq connected-servers
@@ -461,13 +507,14 @@ If ARG is non-nil, instead prompt for connection parameters."
(defvar rcirc-server nil) ; server provided by server
(defvar rcirc-server-name nil) ; server name given by 001 response
(defvar rcirc-timeout-timer nil)
+(defvar rcirc-user-authenticated nil)
(defvar rcirc-user-disconnect nil)
(defvar rcirc-connecting nil)
(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 encryption)
(save-excursion
(message "Connecting to %s..." server)
(let* ((inhibit-eol-conversion)
@@ -480,7 +527,9 @@ If ARG is non-nil, instead prompt for connection parameters."
(user-name (or user-name rcirc-default-user-name))
(full-name (or full-name rcirc-default-full-name))
(startup-channels startup-channels)
- (process (make-network-process :name server :host server :service port-number)))
+ (process (open-network-stream
+ server nil server port-number
+ :type (or encryption 'plain))))
;; set up process
(set-process-coding-system process 'raw-text 'raw-text)
(switch-to-buffer (rcirc-generate-new-buffer-name process nil))
@@ -488,40 +537,32 @@ If ARG is non-nil, instead prompt for connection parameters."
(rcirc-mode process nil)
(set-process-sentinel process 'rcirc-sentinel)
(set-process-filter process 'rcirc-filter)
- (make-local-variable 'rcirc-process)
- (setq rcirc-process process)
- (make-local-variable 'rcirc-server)
- (setq rcirc-server server)
- (make-local-variable 'rcirc-server-name)
- (setq rcirc-server-name server) ; update when we get 001 response
- (make-local-variable 'rcirc-buffer-alist)
- (setq rcirc-buffer-alist nil)
- (make-local-variable 'rcirc-nick-table)
- (setq rcirc-nick-table (make-hash-table :test 'equal))
- (make-local-variable 'rcirc-nick)
- (setq rcirc-nick nick)
- (make-local-variable 'rcirc-process-output)
- (setq rcirc-process-output nil)
- (make-local-variable 'rcirc-startup-channels)
- (setq rcirc-startup-channels startup-channels)
- (make-local-variable 'rcirc-last-server-message-time)
- (setq rcirc-last-server-message-time (current-time))
- (make-local-variable 'rcirc-timeout-timer)
- (setq rcirc-timeout-timer nil)
- (make-local-variable 'rcirc-user-disconnect)
- (setq rcirc-user-disconnect nil)
- (make-local-variable 'rcirc-connecting)
- (setq rcirc-connecting t)
+
+ (set (make-local-variable 'rcirc-process) process)
+ (set (make-local-variable 'rcirc-server) server)
+ (set (make-local-variable 'rcirc-server-name) server) ; Update when we get 001 response.
+ (set (make-local-variable 'rcirc-buffer-alist) nil)
+ (set (make-local-variable 'rcirc-nick-table)
+ (make-hash-table :test 'equal))
+ (set (make-local-variable 'rcirc-nick) nick)
+ (set (make-local-variable 'rcirc-process-output) nil)
+ (set (make-local-variable 'rcirc-startup-channels) startup-channels)
+ (set (make-local-variable 'rcirc-last-server-message-time)
+ (current-time))
+
+ (set (make-local-variable 'rcirc-timeout-timer) nil)
+ (set (make-local-variable 'rcirc-user-disconnect) nil)
+ (set (make-local-variable 'rcirc-user-authenticated) nil)
+ (set (make-local-variable 'rcirc-connecting) t)
(add-hook 'auto-save-hook 'rcirc-log-write)
;; identify
- (when password
+ (unless (zerop (length password))
(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
@@ -543,6 +584,11 @@ If ARG is non-nil, instead prompt for connection parameters."
`(with-current-buffer rcirc-server-buffer
,@body))
+(defun rcirc-float-time ()
+ (if (featurep 'xemacs)
+ (time-to-seconds (current-time))
+ (float-time)))
+
(defun rcirc-keepalive ()
"Send keep alive pings to active rcirc processes.
Kill processes that have not received a server message since the
@@ -551,13 +597,10 @@ last ping."
(mapc (lambda (process)
(with-rcirc-process-buffer process
(when (not rcirc-connecting)
- (rcirc-send-string process
- (format "PRIVMSG %s :\C-aKEEPALIVE %f\C-a"
- rcirc-nick
- (if (featurep 'xemacs)
- (time-to-seconds
- (current-time))
- (float-time)))))))
+ (rcirc-send-ctcp process
+ rcirc-nick
+ (format "KEEPALIVE %f"
+ (rcirc-float-time))))))
(rcirc-process-list))
;; no processes, clean up timer
(cancel-timer rcirc-keepalive-timer)
@@ -565,10 +608,7 @@ last ping."
(defun rcirc-handler-ctcp-KEEPALIVE (process target sender message)
(with-rcirc-process-buffer process
- (setq header-line-format (format "%f" (- (if (featurep 'xemacs)
- (time-to-seconds
- (current-time))
- (float-time))
+ (setq header-line-format (format "%f" (- (rcirc-float-time)
(string-to-number message))))))
(defvar rcirc-debug-buffer " *rcirc debug*")
@@ -691,16 +731,27 @@ Function is called with PROCESS, COMMAND, SENDER, ARGS and LINE.")
(mapconcat 'identity (cdr args) " ")
(not (member response rcirc-responses-no-activity))))
+(defun rcirc--connection-open-p (process)
+ (memq (process-status process) '(run open)))
+
(defun rcirc-send-string (process string)
"Send PROCESS a STRING plus a newline."
(let ((string (concat (encode-coding-string string rcirc-encode-coding-system)
"\n")))
- (unless (eq (process-status process) 'open)
+ (unless (rcirc--connection-open-p process)
(error "Network connection to %s is not open"
(process-name process)))
(rcirc-debug process string)
(process-send-string process string)))
+(defun rcirc-send-privmsg (process target string)
+ (rcirc-send-string process (format "PRIVMSG %s :%s" target string)))
+
+(defun rcirc-send-ctcp (process target request &optional args)
+ (let ((args (if args (concat " " args) "")))
+ (rcirc-send-privmsg process target
+ (format "\C-a%s%s\C-a" request args))))
+
(defun rcirc-buffer-process (&optional buffer)
"Return the process associated with channel BUFFER.
With no argument or nil as argument, use the current buffer."
@@ -771,88 +822,117 @@ 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'."
+ (and (rcirc-looking-at-input)
+ (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)
+ (unless (rcirc-looking-at-input)
+ (error "Point not located after rcirc prompt"))
(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
+ (and rcirc-completion-start
+ (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
+ (cond
+ ((= (aref completion 0) ?/) (concat completion " "))
+ ((= rcirc-completion-start rcirc-prompt-end-marker)
+ (format rcirc-nick-completion-format completion))
+ (t completion))))))
(defun set-rcirc-decode-coding-system (coding-system)
"Set the decode coding system used in this channel."
(interactive "zCoding system for incoming messages: ")
- (setq rcirc-decode-coding-system coding-system))
+ (set (make-local-variable 'rcirc-decode-coding-system) coding-system))
(defun set-rcirc-encode-coding-system (coding-system)
"Set the encode coding system used in this channel."
(interactive "zCoding system for outgoing messages: ")
- (setq rcirc-encode-coding-system coding-system))
-
-(defvar rcirc-mode-map (make-sparse-keymap)
+ (set (make-local-variable 'rcirc-encode-coding-system) coding-system))
+
+(defvar rcirc-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "RET") 'rcirc-send-input)
+ (define-key map (kbd "M-p") 'rcirc-insert-prev-input)
+ (define-key map (kbd "M-n") 'rcirc-insert-next-input)
+ (define-key map (kbd "TAB") 'rcirc-complete)
+ (define-key map (kbd "C-c C-b") 'rcirc-browse-url)
+ (define-key map (kbd "C-c C-c") 'rcirc-edit-multiline)
+ (define-key map (kbd "C-c C-j") 'rcirc-cmd-join)
+ (define-key map (kbd "C-c C-k") 'rcirc-cmd-kick)
+ (define-key map (kbd "C-c C-l") 'rcirc-toggle-low-priority)
+ (define-key map (kbd "C-c C-d") 'rcirc-cmd-mode)
+ (define-key map (kbd "C-c C-m") 'rcirc-cmd-msg)
+ (define-key map (kbd "C-c C-r") 'rcirc-cmd-nick) ; rename
+ (define-key map (kbd "C-c C-o") 'rcirc-omit-mode)
+ (define-key map (kbd "C-c C-p") 'rcirc-cmd-part)
+ (define-key map (kbd "C-c C-q") 'rcirc-cmd-query)
+ (define-key map (kbd "C-c C-t") 'rcirc-cmd-topic)
+ (define-key map (kbd "C-c C-n") 'rcirc-cmd-names)
+ (define-key map (kbd "C-c C-w") 'rcirc-cmd-whois)
+ (define-key map (kbd "C-c C-x") 'rcirc-cmd-quit)
+ (define-key map (kbd "C-c TAB") ; C-i
+ 'rcirc-toggle-ignore-buffer-activity)
+ (define-key map (kbd "C-c C-s") 'rcirc-switch-to-server-buffer)
+ (define-key map (kbd "C-c C-a") 'rcirc-jump-to-first-unread-line)
+ map)
"Keymap for rcirc mode.")
-(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 "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)
-(define-key rcirc-mode-map (kbd "C-c C-k") 'rcirc-cmd-kick)
-(define-key rcirc-mode-map (kbd "C-c C-l") 'rcirc-toggle-low-priority)
-(define-key rcirc-mode-map (kbd "C-c C-d") 'rcirc-cmd-mode)
-(define-key rcirc-mode-map (kbd "C-c C-m") 'rcirc-cmd-msg)
-(define-key rcirc-mode-map (kbd "C-c C-r") 'rcirc-cmd-nick) ; rename
-(define-key rcirc-mode-map (kbd "C-c C-o") 'rcirc-omit-mode)
-(define-key rcirc-mode-map (kbd "M-o") 'rcirc-omit-mode)
-(define-key rcirc-mode-map (kbd "C-c C-p") 'rcirc-cmd-part)
-(define-key rcirc-mode-map (kbd "C-c C-q") 'rcirc-cmd-query)
-(define-key rcirc-mode-map (kbd "C-c C-t") 'rcirc-cmd-topic)
-(define-key rcirc-mode-map (kbd "C-c C-n") 'rcirc-cmd-names)
-(define-key rcirc-mode-map (kbd "C-c C-w") 'rcirc-cmd-whois)
-(define-key rcirc-mode-map (kbd "C-c C-x") 'rcirc-cmd-quit)
-(define-key rcirc-mode-map (kbd "C-c TAB") ; C-i
- 'rcirc-toggle-ignore-buffer-activity)
-(define-key rcirc-mode-map (kbd "C-c C-s") 'rcirc-switch-to-server-buffer)
-(define-key rcirc-mode-map (kbd "C-c C-a") 'rcirc-jump-to-first-unread-line)
-
-(defvar rcirc-browse-url-map (make-sparse-keymap)
+(defvar rcirc-browse-url-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "RET") 'rcirc-browse-url-at-point)
+ (define-key map (kbd "<mouse-2>") 'rcirc-browse-url-at-mouse)
+ (define-key map [follow-link] 'mouse-face)
+ map)
"Keymap used for browsing URLs in `rcirc-mode'.")
-(define-key rcirc-browse-url-map (kbd "RET") 'rcirc-browse-url-at-point)
-(define-key rcirc-browse-url-map (kbd "<mouse-2>") 'rcirc-browse-url-at-mouse)
-(define-key rcirc-browse-url-map [follow-link] 'mouse-face)
-
(defvar rcirc-short-buffer-name nil
"Generated abbreviation to use to indicate buffer activity.")
@@ -870,6 +950,7 @@ Each element looks like (FILENAME . TEXT).")
This number is independent of the number of lines in the buffer.")
(defun rcirc-mode (process target)
+ ;; FIXME: Use define-derived-mode.
"Major mode for IRC channel buffers.
\\{rcirc-mode-map}"
@@ -879,27 +960,18 @@ This number is independent of the number of lines in the buffer.")
(setq major-mode 'rcirc-mode)
(setq mode-line-process nil)
- (make-local-variable 'rcirc-input-ring)
- (setq rcirc-input-ring (make-ring rcirc-input-ring-size))
- (make-local-variable 'rcirc-server-buffer)
- (setq rcirc-server-buffer (process-buffer process))
- (make-local-variable 'rcirc-target)
- (setq rcirc-target target)
- (make-local-variable 'rcirc-topic)
- (setq rcirc-topic nil)
- (make-local-variable 'rcirc-last-post-time)
- (setq rcirc-last-post-time (current-time))
- (make-local-variable 'fill-paragraph-function)
- (setq fill-paragraph-function 'rcirc-fill-paragraph)
- (make-local-variable 'rcirc-recent-quit-alist)
- (setq rcirc-recent-quit-alist nil)
- (make-local-variable 'rcirc-current-line)
- (setq rcirc-current-line 0)
-
- (make-local-variable 'rcirc-short-buffer-name)
- (setq rcirc-short-buffer-name nil)
- (make-local-variable 'rcirc-urls)
- (setq use-hard-newlines t)
+ (set (make-local-variable 'rcirc-input-ring)
+ (make-ring rcirc-input-ring-size))
+ (set (make-local-variable 'rcirc-server-buffer) (process-buffer process))
+ (set (make-local-variable 'rcirc-target) target)
+ (set (make-local-variable 'rcirc-topic) nil)
+ (set (make-local-variable 'rcirc-last-post-time) (current-time))
+ (set (make-local-variable 'fill-paragraph-function) 'rcirc-fill-paragraph)
+ (set (make-local-variable 'rcirc-recent-quit-alist) nil)
+ (set (make-local-variable 'rcirc-current-line) 0)
+
+ (set (make-local-variable 'rcirc-short-buffer-name) nil)
+ (set (make-local-variable 'rcirc-urls) t)
;; setup for omitting responses
(setq buffer-invisibility-spec '())
@@ -909,28 +981,23 @@ This number is independent of the number of lines in the buffer.")
?. 'font-lock-keyword-face)))
(make-vector 3 glyph)))
- (make-local-variable 'rcirc-decode-coding-system)
- (make-local-variable 'rcirc-encode-coding-system)
(dolist (i rcirc-coding-system-alist)
(let ((chan (if (consp (car i)) (caar i) (car i)))
(serv (if (consp (car i)) (cdar i) "")))
(when (and (string-match chan (or target ""))
(string-match serv (rcirc-server-name process)))
- (setq rcirc-decode-coding-system (if (consp (cdr i)) (cadr i) (cdr i))
- rcirc-encode-coding-system (if (consp (cdr i)) (cddr i) (cdr i))))))
+ (set (make-local-variable 'rcirc-decode-coding-system)
+ (if (consp (cdr i)) (cadr i) (cdr i)))
+ (set (make-local-variable 'rcirc-encode-coding-system)
+ (if (consp (cdr i)) (cddr i) (cdr i))))))
;; setup the prompt and markers
- (make-local-variable 'rcirc-prompt-start-marker)
- (setq rcirc-prompt-start-marker (make-marker))
- (set-marker rcirc-prompt-start-marker (point-max))
- (make-local-variable 'rcirc-prompt-end-marker)
- (setq rcirc-prompt-end-marker (make-marker))
- (set-marker rcirc-prompt-end-marker (point-max))
+ (set (make-local-variable 'rcirc-prompt-start-marker) (point-max-marker))
+ (set (make-local-variable 'rcirc-prompt-end-marker) (point-max-marker))
(rcirc-update-prompt)
(goto-char rcirc-prompt-end-marker)
- (make-local-variable 'overlay-arrow-position)
- (setq overlay-arrow-position (make-marker))
- (set-marker overlay-arrow-position nil)
+
+ (set (make-local-variable 'overlay-arrow-position) (make-marker))
;; if the user changes the major mode or kills the buffer, there is
;; cleanup work to do
@@ -945,7 +1012,10 @@ This number is independent of the number of lines in the buffer.")
rcirc-buffer-alist))))
(rcirc-update-short-buffer-names))
- (run-hooks 'rcirc-mode-hook))
+ (add-hook 'completion-at-point-functions
+ 'rcirc-completion-at-point nil 'local)
+
+ (run-mode-hooks 'rcirc-mode-hook))
(defun rcirc-update-prompt (&optional all)
"Reset the prompt string in the current buffer.
@@ -996,9 +1066,23 @@ If ALL is non-nil, update prompts in all IRC buffers."
(or (eq (aref target 0) ?#)
(eq (aref target 0) ?&))))
+(defcustom rcirc-log-directory "~/.emacs.d/rcirc-log"
+ "Directory to keep IRC logfiles."
+ :type 'directory
+ :group 'rcirc)
+
+(defcustom rcirc-log-flag nil
+ "Non-nil means log IRC activity to disk.
+Logfiles are kept in `rcirc-log-directory'."
+ :type 'boolean
+ :group 'rcirc)
+
(defun rcirc-kill-buffer-hook ()
"Part the channel when killing an rcirc buffer."
(when (eq major-mode 'rcirc-mode)
+ (when (and rcirc-log-flag
+ rcirc-log-directory)
+ (rcirc-log-write))
(rcirc-clean-up-buffer "Killed buffer")))
(defun rcirc-change-major-mode-hook ()
@@ -1009,7 +1093,7 @@ If ALL is non-nil, update prompts in all IRC buffers."
(let ((buffer (current-buffer)))
(rcirc-clear-activity buffer)
(when (and (rcirc-buffer-process)
- (eq (process-status (rcirc-buffer-process)) 'open))
+ (rcirc--connection-open-p (rcirc-buffer-process)))
(with-rcirc-server-buffer
(setq rcirc-buffer-alist
(rassq-delete-all buffer rcirc-buffer-alist)))
@@ -1136,6 +1220,8 @@ Create the buffer if it doesn't exist."
(concat command " :" args)))))))
(defvar rcirc-parent-buffer nil)
+(make-variable-buffer-local 'rcirc-parent-buffer)
+(put 'rcirc-parent-buffer 'permanent-local t)
(defvar rcirc-window-configuration nil)
(defun rcirc-edit-multiline ()
"Move current edit to a dedicated buffer."
@@ -1155,16 +1241,14 @@ Create the buffer if it doesn't exist."
(and (> pos 0) (goto-char pos))
(message "Type C-c C-c to return text to %s, or C-c C-k to cancel" parent))))
-(defvar rcirc-multiline-minor-mode-map (make-sparse-keymap)
+(defvar rcirc-multiline-minor-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "C-c C-c") 'rcirc-multiline-minor-submit)
+ (define-key map (kbd "C-x C-s") 'rcirc-multiline-minor-submit)
+ (define-key map (kbd "C-c C-k") 'rcirc-multiline-minor-cancel)
+ (define-key map (kbd "ESC ESC ESC") 'rcirc-multiline-minor-cancel)
+ map)
"Keymap for multiline mode in rcirc.")
-(define-key rcirc-multiline-minor-mode-map
- (kbd "C-c C-c") 'rcirc-multiline-minor-submit)
-(define-key rcirc-multiline-minor-mode-map
- (kbd "C-x C-s") 'rcirc-multiline-minor-submit)
-(define-key rcirc-multiline-minor-mode-map
- (kbd "C-c C-k") 'rcirc-multiline-minor-cancel)
-(define-key rcirc-multiline-minor-mode-map
- (kbd "ESC ESC ESC") 'rcirc-multiline-minor-cancel)
(define-minor-mode rcirc-multiline-minor-mode
"Minor mode for editing multiple lines in rcirc."
@@ -1173,8 +1257,6 @@ Create the buffer if it doesn't exist."
:keymap rcirc-multiline-minor-mode-map
:global nil
:group 'rcirc
- (make-local-variable 'rcirc-parent-buffer)
- (put 'rcirc-parent-buffer 'permanent-local t)
(setq fill-column rcirc-max-message-length))
(defun rcirc-multiline-minor-submit ()
@@ -1323,22 +1405,17 @@ is found by looking up RESPONSE in `rcirc-response-formats'."
(defvar rcirc-last-sender nil)
(make-variable-buffer-local 'rcirc-last-sender)
-(defcustom rcirc-log-directory "~/.emacs.d/rcirc-log"
- "Directory to keep IRC logfiles."
- :type 'directory
- :group 'rcirc)
-
-(defcustom rcirc-log-flag nil
- "Non-nil means log IRC activity to disk.
-Logfiles are kept in `rcirc-log-directory'."
- :type 'boolean
- :group 'rcirc)
-
(defcustom rcirc-omit-threshold 100
"Number of lines since last activity from a nick before `rcirc-omit-responses' are omitted."
: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 +1581,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
@@ -1653,13 +1737,39 @@ 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)
+(defvar rcirc-track-minor-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "C-c C-@") 'rcirc-next-active-buffer)
+ (define-key map (kbd "C-c C-SPC") 'rcirc-next-active-buffer)
+ map)
"Keymap for rcirc track minor mode.")
-(define-key rcirc-track-minor-mode-map (kbd "C-c C-@") 'rcirc-next-active-buffer)
-(define-key rcirc-track-minor-mode-map (kbd "C-c C-SPC") 'rcirc-next-active-buffer)
-
;;;###autoload
(define-minor-mode rcirc-track-minor-mode
"Global minor mode for tracking activity in rcirc buffers."
@@ -1730,6 +1840,8 @@ Uninteresting lines are those whose responses are listed in
(defun rcirc-switch-to-server-buffer ()
"Switch to the server buffer associated with current channel buffer."
(interactive)
+ (unless (buffer-live-p rcirc-server-buffer)
+ (error "No such buffer"))
(switch-to-buffer rcirc-server-buffer))
(defun rcirc-jump-to-first-unread-line ()
@@ -1968,16 +2080,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."
@@ -2007,14 +2121,19 @@ activity. Only run if the buffer is not visible and
(when (not existing-buffer)
(rcirc-cmd-whois nick))))
-(defun-rcirc-command join (channel)
- "Join CHANNEL."
- (interactive "sJoin channel: ")
- (let ((buffer (rcirc-get-buffer-create process
- (car (split-string channel)))))
- (rcirc-send-string process (concat "JOIN " channel))
+(defun-rcirc-command join (channels)
+ "Join CHANNELS.
+CHANNELS is a comma- or space-separated string of channel names."
+ (interactive "sJoin channels: ")
+ (let* ((split-channels (split-string channels "[ ,]" t))
+ (buffers (mapcar (lambda (ch)
+ (rcirc-get-buffer-create process ch))
+ split-channels))
+ (channels (mapconcat 'identity split-channels ",")))
+ (rcirc-send-string process (concat "JOIN " channels))
(when (not (eq (selected-window) (minibuffer-window)))
- (switch-to-buffer buffer))))
+ (dolist (b buffers) ;; order the new channel buffers in the buffer list
+ (switch-to-buffer b)))))
;; TODO: /part #channel reason, or consider removing #channel altogether
(defun-rcirc-command part (channel)
@@ -2103,17 +2222,22 @@ With a prefix arg, prompt for new topic."
(defun rcirc-cmd-ctcp (args &optional process target)
(if (string-match "^\\([^ ]+\\)\\s-+\\(.+\\)$" args)
- (let ((target (match-string 1 args))
- (request (match-string 2 args)))
- (rcirc-send-string process
- (format "PRIVMSG %s \C-a%s\C-a"
- target (upcase request))))
+ (let* ((target (match-string 1 args))
+ (request (upcase (match-string 2 args)))
+ (function (intern-soft (concat "rcirc-ctcp-sender-" request))))
+ (if (fboundp function) ;; use special function if available
+ (funcall function process target request)
+ (rcirc-send-ctcp process target request)))
(rcirc-print process (rcirc-nick process) "ERROR" nil
"usage: /ctcp NICK REQUEST")))
+(defun rcirc-ctcp-sender-PING (process target request)
+ "Send a CTCP PING message to TARGET."
+ (let ((timestamp (format "%.0f" (rcirc-float-time))))
+ (rcirc-send-ctcp process target "PING" timestamp)))
+
(defun rcirc-cmd-me (args &optional process target)
- (rcirc-send-string process (format "PRIVMSG %s :\C-aACTION %s\C-a"
- target args)))
+ (rcirc-send-ctcp process target "ACTION" args))
(defun rcirc-add-or-remove (set &rest elements)
(dolist (elt elements)
@@ -2328,10 +2452,30 @@ keywords when no KEYWORD is given."
(setq rcirc-server-name sender)
(setq rcirc-nick (car args))
(rcirc-update-prompt)
- (when rcirc-auto-authenticate-flag (rcirc-authenticate))
+ (if rcirc-auto-authenticate-flag
+ (if (and rcirc-authenticate-before-join
+ ;; We have to ensure that there's an authentication
+ ;; entry for that server. Else,
+ ;; rcirc-authenticated-hook won't be triggered, and
+ ;; autojoin won't happen at all.
+ (let (auth-required)
+ (dolist (s rcirc-authinfo auth-required)
+ (when (string-match (car s) rcirc-server-name)
+ (setq auth-required t)))))
+ (progn
+ (add-hook 'rcirc-authenticated-hook 'rcirc-join-channels-post-auth t t)
+ (rcirc-authenticate))
+ (rcirc-authenticate)
+ (rcirc-join-channels process rcirc-startup-channels))
+ (rcirc-join-channels process rcirc-startup-channels))))
+
+(defun rcirc-join-channels-post-auth (process)
+ "Join `rcirc-startup-channels' after authenticating."
+ (with-rcirc-process-buffer process
(rcirc-join-channels process rcirc-startup-channels)))
(defun rcirc-handler-PRIVMSG (process sender args text)
+ (rcirc-check-auth-status process sender args text)
(let ((target (if (rcirc-channel-p (car args))
(car args)
sender))
@@ -2344,6 +2488,7 @@ keywords when no KEYWORD is given."
(rcirc-put-nick-channel process sender target rcirc-current-line))))
(defun rcirc-handler-NOTICE (process sender args text)
+ (rcirc-check-auth-status process sender args text)
(let ((target (car args))
(message (cadr args)))
(if (string-match "^\C-a\\(.*\\)\C-a$" message)
@@ -2361,6 +2506,33 @@ keywords when no KEYWORD is given."
sender)))
message t))))
+(defun rcirc-check-auth-status (process sender args text)
+ "Check if the user just authenticated.
+If authenticated, runs `rcirc-authenticated-hook' with PROCESS as
+the only argument."
+ (with-rcirc-process-buffer process
+ (when (and (not rcirc-user-authenticated)
+ rcirc-authenticate-before-join
+ rcirc-auto-authenticate-flag)
+ (let ((target (car args))
+ (message (cadr args)))
+ (when (or
+ (and ;; nickserv
+ (string= sender "NickServ")
+ (string= target rcirc-nick)
+ (member message
+ (list
+ (format "You are now identified for \C-b%s\C-b." rcirc-nick)
+ "Password accepted - you are now recognized."
+ )))
+ (and ;; quakenet
+ (string= sender "Q")
+ (string= target rcirc-nick)
+ (string-match "\\`You are now logged in as .+\\.\\'" message)))
+ (setq rcirc-user-authenticated t)
+ (run-hook-with-args 'rcirc-authenticated-hook process)
+ (remove-hook 'rcirc-authenticated-hook 'rcirc-join-channels-post-auth t))))))
+
(defun rcirc-handler-WALLOPS (process sender args text)
(rcirc-print process sender "WALLOPS" sender (car args) t))
@@ -2373,7 +2545,10 @@ keywords when no KEYWORD is given."
(rcirc-elapsed-lines process sender channel)))
(when (and last-activity-lines
(< last-activity-lines rcirc-omit-threshold))
- (rcirc-last-line process sender channel)))))
+ (rcirc-last-line process sender channel))))
+ ;; reset mode-line-process in case joining a channel with an
+ ;; already open buffer (after getting kicked e.g.)
+ (setq mode-line-process nil))
(rcirc-print process sender "JOIN" channel "")
@@ -2507,6 +2682,20 @@ keywords when no KEYWORD is given."
(setq rcirc-nick-away-alist (cons (cons nick away-message)
rcirc-nick-away-alist))))))
+(defun rcirc-handler-317 (process sender args text)
+ "RPL_WHOISIDLE"
+ (let* ((nick (nth 1 args))
+ (idle-secs (string-to-number (nth 2 args)))
+ (idle-string
+ (if (< idle-secs most-positive-fixnum)
+ (format-seconds "%yy %dd %hh %mm %z%ss" idle-secs)
+ "a very long time"))
+ (signon-time (seconds-to-time (string-to-number (nth 3 args))))
+ (signon-string (format-time-string "%c" signon-time))
+ (message (format "%s idle for %s, signed on %s"
+ nick idle-string signon-string)))
+ (rcirc-print process sender "317" nil message t)))
+
(defun rcirc-handler-332 (process sender args text)
"RPL_TOPIC"
(let ((buffer (or (rcirc-get-buffer process (cadr args))
@@ -2552,10 +2741,13 @@ keywords when no KEYWORD is given."
(defun rcirc-handler-353 (process sender args text)
"RPL_NAMREPLY"
- (let ((channel (caddr args)))
+ (let ((channel (nth 2 args))
+ (names (or (nth 3 args) "")))
(mapc (lambda (nick)
(rcirc-put-nick-channel process nick channel))
- (split-string (cadddr args) " " t))
+ (split-string names " " t))
+ ;; create a temporary buffer to insert the names into
+ ;; rcirc-handler-366 (RPL_ENDOFNAMES) will handle it
(with-current-buffer (rcirc-get-temp-buffer-create process channel)
(goto-char (point-max))
(insert (car (last args)) " "))))
@@ -2566,7 +2758,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)
@@ -2587,26 +2780,33 @@ Passwords are stored in `rcirc-authinfo' (which see)."
(nick (caddr i))
(method (cadr i))
(args (cdddr i)))
- (when (and (string-match server rcirc-server)
- (string-match nick rcirc-nick))
- (cond ((equal method 'nickserv)
- (rcirc-send-string
- process
- (concat "PRIVMSG " (or (cadr args) "nickserv")
- " :identify " (car args))))
- ((equal method 'chanserv)
- (rcirc-send-string
- process
- (concat
- "PRIVMSG chanserv :identify "
- (car args) " " (cadr args))))
- ((equal method 'bitlbee)
- (rcirc-send-string
- process
- (concat "PRIVMSG &bitlbee :identify " (car args))))
- (t
- (message "No %S authentication method defined"
- method))))))))
+ (when (and (string-match server rcirc-server))
+ (if (and (memq method '(nickserv chanserv bitlbee))
+ (string-match nick rcirc-nick))
+ ;; the following methods rely on the user's nickname.
+ (case method
+ (nickserv
+ (rcirc-send-privmsg
+ process
+ (or (cadr args) "NickServ")
+ (concat "IDENTIFY " (car args))))
+ (chanserv
+ (rcirc-send-privmsg
+ process
+ "ChanServ"
+ (format "IDENTIFY %s %s" (car args) (cadr args))))
+ (bitlbee
+ (rcirc-send-privmsg
+ process
+ "&bitlbee"
+ (concat "IDENTIFY " (car args)))))
+ ;; quakenet authentication doesn't rely on the user's nickname.
+ ;; the variable `nick' here represents the Q account name.
+ (when (eq method 'quakenet)
+ (rcirc-send-privmsg
+ process
+ "Q@CServe.quakenet.org"
+ (format "AUTH %s %s" nick (car args))))))))))
(defun rcirc-handler-INVITE (process sender args text)
(rcirc-print process sender "INVITE" nil (mapconcat 'identity args " ") t))
@@ -2786,5 +2986,4 @@ Passwords are stored in `rcirc-authinfo' (which see)."
(provide 'rcirc)
-;; arch-tag: b471b7e8-6b5a-4399-b2c6-a3c78dfc8ffb
;;; rcirc.el ends here
diff --git a/lisp/net/rcompile.el b/lisp/net/rcompile.el
index 7408109922d..82df5b39c95 100644
--- a/lisp/net/rcompile.el
+++ b/lisp/net/rcompile.el
@@ -1,7 +1,6 @@
;;; rcompile.el --- run a compilation on a remote machine
-;; Copyright (C) 1993, 1994, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1994, 2001-2011 Free Software Foundation, Inc.
;; Author: Albert <alon@milcse.rtsg.mot.com>
;; Maintainer: FSF
@@ -75,7 +74,7 @@
(defcustom remote-compile-host nil
- "*Host for remote compilations."
+ "Host for remote compilations."
:type '(choice string (const nil))
:group 'remote-compile)
@@ -86,7 +85,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 +94,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)
@@ -178,5 +177,4 @@ See \\[compile]."
remote-compile-host
""))))))
-;; arch-tag: 2866a132-ece4-4ce9-9f91-ec147f803f73
;;; rcompile.el ends here
diff --git a/lisp/net/rlogin.el b/lisp/net/rlogin.el
index c7f86ba09b4..e2619e3bf79 100644
--- a/lisp/net/rlogin.el
+++ b/lisp/net/rlogin.el
@@ -1,7 +1,7 @@
;;; rlogin.el --- remote login interface
-;; Copyright (C) 1992, 1993, 1994, 1995, 1997, 1998, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992-1995, 1997-1998, 2001-2011
+;; Free Software Foundation, Inc.
;; Author: Noah Friedman
;; Maintainer: Noah Friedman <friedman@splode.com>
@@ -45,30 +45,25 @@
: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)
(defcustom rlogin-process-connection-type
- (save-match-data
- ;; Solaris 2.x `rlogin' will spew a bunch of ioctl error messages if
- ;; stdin isn't a tty.
- (cond ((and (boundp 'system-configuration)
- (stringp system-configuration)
- (string-match "-solaris2" system-configuration))
- t)
- (t nil)))
- "*If non-nil, use a pty for the local rlogin process.
+ ;; Solaris 2.x `rlogin' will spew a bunch of ioctl error messages if
+ ;; stdin isn't a tty.
+ (and (string-match-p "-solaris2" system-configuration) t)
+ "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 +74,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,31 +98,31 @@ 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."
:type '(choice (const nil) string)
:group 'rlogin)
-;; Initialize rlogin mode map.
-(defvar rlogin-mode-map '())
-(cond
- ((null rlogin-mode-map)
- (setq rlogin-mode-map (if (consp shell-mode-map)
- (cons 'keymap shell-mode-map)
- (copy-keymap shell-mode-map)))
- (define-key rlogin-mode-map "\C-c\C-c" 'rlogin-send-Ctrl-C)
- (define-key rlogin-mode-map "\C-c\C-d" 'rlogin-send-Ctrl-D)
- (define-key rlogin-mode-map "\C-c\C-z" 'rlogin-send-Ctrl-Z)
- (define-key rlogin-mode-map "\C-c\C-\\" 'rlogin-send-Ctrl-backslash)
- (define-key rlogin-mode-map "\C-d" 'rlogin-delchar-or-send-Ctrl-D)
- (define-key rlogin-mode-map "\C-i" 'rlogin-tab-or-complete)))
+(defvar rlogin-mode-map
+ (let ((map (if (consp shell-mode-map)
+ (cons 'keymap shell-mode-map)
+ (copy-keymap shell-mode-map))))
+ (define-key rlogin-mode-map "\C-c\C-c" 'rlogin-send-Ctrl-C)
+ (define-key rlogin-mode-map "\C-c\C-d" 'rlogin-send-Ctrl-D)
+ (define-key rlogin-mode-map "\C-c\C-z" 'rlogin-send-Ctrl-Z)
+ (define-key rlogin-mode-map "\C-c\C-\\" 'rlogin-send-Ctrl-backslash)
+ (define-key rlogin-mode-map "\C-d" 'rlogin-delchar-or-send-Ctrl-D)
+ (define-key rlogin-mode-map "\C-i" 'rlogin-tab-or-complete)
+ map)
+ "Keymap for `rlogin-mode'.")
+
;;;###autoload (add-hook 'same-window-regexps (purecopy "^\\*rlogin-.*\\*\\(\\|<[0-9]+>\\)"))
@@ -175,7 +170,6 @@ variable."
(read-from-minibuffer "rlogin arguments (hostname first): "
nil nil nil 'rlogin-history)
current-prefix-arg))
-
(let* ((process-connection-type rlogin-process-connection-type)
(args (if rlogin-explicit-args
(append (split-string input-args)
@@ -192,7 +186,6 @@ variable."
(buffer-name (if (string= user (user-login-name))
(format "*rlogin-%s*" host)
(format "*rlogin-%s@%s*" user host))))
-
(cond ((null buffer))
((stringp buffer)
(setq buffer-name buffer))
@@ -202,32 +195,26 @@ variable."
(setq buffer-name (format "%s<%d>" buffer-name buffer)))
(t
(setq buffer-name (generate-new-buffer-name buffer-name))))
-
(setq buffer (get-buffer-create buffer-name))
(pop-to-buffer buffer-name)
-
(unless (comint-check-proc buffer-name)
(comint-exec buffer buffer-name rlogin-program nil args)
-
(rlogin-mode)
-
(make-local-variable 'rlogin-host)
(setq rlogin-host host)
(make-local-variable 'rlogin-remote-user)
(setq rlogin-remote-user user)
-
- (condition-case ()
- (cond ((eq rlogin-directory-tracking-mode t)
- ;; Do this here, rather than calling the tracking mode
- ;; function, to avoid a gratuitous resync check; the default
- ;; should be the user's home directory, be it local or remote.
- (setq comint-file-name-prefix
- (concat "/" rlogin-remote-user "@" rlogin-host ":"))
- (cd-absolute comint-file-name-prefix))
- ((null rlogin-directory-tracking-mode))
- (t
- (cd-absolute (concat comint-file-name-prefix "~/"))))
- (error nil)))))
+ (ignore-errors
+ (cond ((eq rlogin-directory-tracking-mode t)
+ ;; Do this here, rather than calling the tracking mode
+ ;; function, to avoid a gratuitous resync check; the default
+ ;; should be the user's home directory, be it local or remote.
+ (setq comint-file-name-prefix
+ (concat "/" rlogin-remote-user "@" rlogin-host ":"))
+ (cd-absolute comint-file-name-prefix))
+ ((null rlogin-directory-tracking-mode))
+ (t
+ (cd-absolute (concat comint-file-name-prefix "~/"))))))))
(put 'rlogin-mode 'mode-class 'special)
@@ -249,7 +236,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)
@@ -302,8 +289,7 @@ local one share the same directories (through NFS)."
(process-send-string nil "\C-\\"))
(defun rlogin-delchar-or-send-Ctrl-D (arg)
- "\
-Delete ARG characters forward, or send a C-d to process if at end of buffer."
+ "Delete ARG characters forward, or send a C-d to process if at end of buffer."
(interactive "p")
(if (eobp)
(rlogin-send-Ctrl-D)
@@ -318,5 +304,4 @@ Delete ARG characters forward, or send a C-d to process if at end of buffer."
(provide 'rlogin)
-;; arch-tag: 6e20eabf-feda-40fa-ab40-0d156db447e4
;;; rlogin.el ends here
diff --git a/lisp/net/sasl-cram.el b/lisp/net/sasl-cram.el
index 4c6704ef3e4..153d2cafe29 100644
--- a/lisp/net/sasl-cram.el
+++ b/lisp/net/sasl-cram.el
@@ -1,10 +1,11 @@
;;; sasl-cram.el --- CRAM-MD5 module for the SASL client framework
-;; Copyright (C) 2000, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000, 2007-2011 Free Software Foundation, Inc.
;; 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 488f2320702..1c7d2f02d10 100644
--- a/lisp/net/sasl-digest.el
+++ b/lisp/net/sasl-digest.el
@@ -1,10 +1,11 @@
;;; sasl-digest.el --- DIGEST-MD5 module for the SASL client framework
-;; Copyright (C) 2000, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000, 2007-2011 Free Software Foundation, Inc.
;; 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 2577a337b71..d8b367ac8ad 100644
--- a/lisp/net/sasl-ntlm.el
+++ b/lisp/net/sasl-ntlm.el
@@ -1,11 +1,12 @@
;;; sasl-ntlm.el --- NTLM (NT Lan Manager) module for the SASL client framework
-;; Copyright (C) 2000, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000, 2007-2011 Free Software Foundation, Inc.
;; Author: Taro Kawagishi <tarok@transpulse.org>
;; 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 e78064a0a04..2c4da7986e7 100644
--- a/lisp/net/sasl.el
+++ b/lisp/net/sasl.el
@@ -1,6 +1,6 @@
;;; sasl.el --- SASL client framework
-;; Copyright (C) 2000, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000, 2007-2011 Free Software Foundation, Inc.
;; Author: Daiki Ueno <ueno@unixuser.org>
;; Keywords: SASL
@@ -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..89378497c36
--- /dev/null
+++ b/lisp/net/secrets.el
@@ -0,0 +1,868 @@
+;;; secrets.el --- Client interface to gnome-keyring and kwallet.
+
+;; Copyright (C) 2010-2011 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-delete-alias (alias)
+ "Delete ALIAS, referencing to a collection."
+ (dbus-call-method
+ :session secrets-service secrets-path
+ secrets-interface-service "SetAlias"
+ alias :object-path secrets-empty-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/snmp-mode.el b/lisp/net/snmp-mode.el
index 111fb4ea2f2..e9783d46ba8 100644
--- a/lisp/net/snmp-mode.el
+++ b/lisp/net/snmp-mode.el
@@ -1,7 +1,6 @@
;;; snmp-mode.el --- SNMP & SNMPv2 MIB major mode
-;; Copyright (C) 1995, 1998, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 1998, 2001-2011 Free Software Foundation, Inc.
;; Author: Paul D. Smith <psmith@BayNetworks.com>
;; Keywords: data
@@ -694,5 +693,4 @@ controls whether case is significant."
(provide 'snmp-mode)
-;; arch-tag: eb6cc0f9-1e47-4023-8625-bc9aae6c3527
;;; snmp-mode.el ends here
diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el
new file mode 100644
index 00000000000..9862332bf3f
--- /dev/null
+++ b/lisp/net/soap-client.el
@@ -0,0 +1,1752 @@
+;;;; soap-client.el -- Access SOAP web services from Emacs
+
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
+
+;; Author: Alexandru Harsanyi <AlexHarsanyi@gmail.com>
+;; Created: December, 2009
+;; Keywords: soap, web-services, comm, hypermedia
+;; Package: soap-client
+;; Homepage: http://code.google.com/p/emacs-soap-client
+
+;; 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:
+;;
+;; To use the SOAP client, you first need to load the WSDL document for the
+;; service you want to access, using `soap-load-wsdl-from-url'. A WSDL
+;; document describes the available operations of the SOAP service, how their
+;; parameters and responses are encoded. To invoke operations, you use the
+;; `soap-invoke' method passing it the WSDL, the service name, the operation
+;; you wish to invoke and any required parameters.
+;;
+;; Idealy, the service you want to access will have some documentation about
+;; the operations it supports. If it does not, you can try using
+;; `soap-inspect' to browse the WSDL document and see the available operations
+;; and their parameters.
+;;
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(require 'xml)
+(require 'warnings)
+(require 'url)
+(require 'url-http)
+(require 'url-util)
+(require 'mm-decode)
+
+(defsubst soap-warning (message &rest args)
+ "Display a warning MESSAGE with ARGS, using the 'soap-client warning type."
+ (display-warning 'soap-client (apply 'format message args) :warning))
+
+(defgroup soap-client nil
+ "Access SOAP web services from Emacs."
+ :group 'tools)
+
+;;;; Support for parsing XML documents with namespaces
+
+;; XML documents with namespaces are difficult to parse because the names of
+;; the nodes depend on what "xmlns" aliases have been defined in the document.
+;; To work with such documents, we introduce a translation layer between a
+;; "well known" namespace tag and the local namespace tag in the document
+;; being parsed.
+
+(defconst soap-well-known-xmlns
+ '(("apachesoap" . "http://xml.apache.org/xml-soap")
+ ("soapenc" . "http://schemas.xmlsoap.org/soap/encoding/")
+ ("wsdl" . "http://schemas.xmlsoap.org/wsdl/")
+ ("wsdlsoap" . "http://schemas.xmlsoap.org/wsdl/soap/")
+ ("xsd" . "http://www.w3.org/2001/XMLSchema")
+ ("xsi" . "http://www.w3.org/2001/XMLSchema-instance")
+ ("soap" . "http://schemas.xmlsoap.org/soap/envelope/")
+ ("soap12" . "http://schemas.xmlsoap.org/wsdl/soap12/")
+ ("http" . "http://schemas.xmlsoap.org/wsdl/http/")
+ ("mime" . "http://schemas.xmlsoap.org/wsdl/mime/"))
+ "A list of well known xml namespaces and their aliases.")
+
+(defvar soap-local-xmlns nil
+ "A list of local namespace aliases.
+This is a dynamically bound variable, controlled by
+`soap-with-local-xmlns'.")
+
+(defvar soap-default-xmlns nil
+ "The default XML namespaces.
+Names in this namespace will be unqualified. This is a
+dynamically bound variable, controlled by
+`soap-with-local-xmlns'")
+
+(defvar soap-target-xmlns nil
+ "The target XML namespace.
+New XSD elements will be defined in this namespace, unless they
+are fully qualified for a different namespace. This is a
+dynamically bound variable, controlled by
+`soap-with-local-xmlns'")
+
+(defun soap-wk2l (well-known-name)
+ "Return local variant of WELL-KNOWN-NAME.
+This is done by looking up the namespace in the
+`soap-well-known-xmlns' table and resolving the namespace to
+the local name based on the current local translation table
+`soap-local-xmlns'. See also `soap-with-local-xmlns'."
+ (let ((wk-name-1 (if (symbolp well-known-name)
+ (symbol-name well-known-name)
+ well-known-name)))
+ (cond
+ ((string-match "^\\(.*\\):\\(.*\\)$" wk-name-1)
+ (let ((ns (match-string 1 wk-name-1))
+ (name (match-string 2 wk-name-1)))
+ (let ((namespace (cdr (assoc ns soap-well-known-xmlns))))
+ (cond ((equal namespace soap-default-xmlns)
+ ;; Name is unqualified in the default namespace
+ (if (symbolp well-known-name)
+ (intern name)
+ name))
+ (t
+ (let* ((local-ns (car (rassoc namespace soap-local-xmlns)))
+ (local-name (concat local-ns ":" name)))
+ (if (symbolp well-known-name)
+ (intern local-name)
+ local-name)))))))
+ (t well-known-name))))
+
+(defun soap-l2wk (local-name)
+ "Convert LOCAL-NAME into a well known name.
+The namespace of LOCAL-NAME is looked up in the
+`soap-well-known-xmlns' table and a well known namespace tag is
+used in the name.
+
+nil is returned if there is no well-known namespace for the
+namespace of LOCAL-NAME."
+ (let ((l-name-1 (if (symbolp local-name)
+ (symbol-name local-name)
+ local-name))
+ namespace name)
+ (cond
+ ((string-match "^\\(.*\\):\\(.*\\)$" l-name-1)
+ (setq name (match-string 2 l-name-1))
+ (let ((ns (match-string 1 l-name-1)))
+ (setq namespace (cdr (assoc ns soap-local-xmlns)))
+ (unless namespace
+ (error "Soap-l2wk(%s): no namespace for alias %s" local-name ns))))
+ (t
+ (setq name l-name-1)
+ (setq namespace soap-default-xmlns)))
+
+ (if namespace
+ (let ((well-known-ns (car (rassoc namespace soap-well-known-xmlns))))
+ (if well-known-ns
+ (let ((well-known-name (concat well-known-ns ":" name)))
+ (if (symbol-name local-name)
+ (intern well-known-name)
+ well-known-name))
+ (progn
+ ;; (soap-warning "soap-l2wk(%s): namespace %s has no well-known tag"
+ ;; local-name namespace)
+ nil)))
+ ;; if no namespace is defined, just return the unqualified name
+ name)))
+
+
+(defun soap-l2fq (local-name &optional use-tns)
+ "Convert LOCAL-NAME into a fully qualified name.
+A fully qualified name is a cons of the namespace name and the
+name of the element itself. For example \"xsd:string\" is
+converted to \(\"http://www.w3.org/2001/XMLSchema\" . \"string\"\).
+
+The USE-TNS argument specifies what to do when LOCAL-NAME has no
+namespace tag. If USE-TNS is non-nil, the `soap-target-xmlns'
+will be used as the element's namespace, otherwise
+`soap-default-xmlns' will be used.
+
+This is needed because different parts of a WSDL document can use
+different namespace aliases for the same element."
+ (let ((local-name-1 (if (symbolp local-name)
+ (symbol-name local-name)
+ local-name)))
+ (cond ((string-match "^\\(.*\\):\\(.*\\)$" local-name-1)
+ (let ((ns (match-string 1 local-name-1))
+ (name (match-string 2 local-name-1)))
+ (let ((namespace (cdr (assoc ns soap-local-xmlns))))
+ (if namespace
+ (cons namespace name)
+ (error "Soap-l2fq(%s): unknown alias %s" local-name ns)))))
+ (t
+ (cons (if use-tns
+ soap-target-xmlns
+ soap-default-xmlns)
+ local-name)))))
+
+(defun soap-extract-xmlns (node &optional xmlns-table)
+ "Return a namespace alias table for NODE by extending XMLNS-TABLE."
+ (let (xmlns default-ns target-ns)
+ (dolist (a (xml-node-attributes node))
+ (let ((name (symbol-name (car a)))
+ (value (cdr a)))
+ (cond ((string= name "targetNamespace")
+ (setq target-ns value))
+ ((string= name "xmlns")
+ (setq default-ns value))
+ ((string-match "^xmlns:\\(.*\\)$" name)
+ (push (cons (match-string 1 name) value) xmlns)))))
+
+ (let ((tns (assoc "tns" xmlns)))
+ (cond ((and tns target-ns)
+ ;; If a tns alias is defined for this node, it must match
+ ;; the target namespace.
+ (unless (equal target-ns (cdr tns))
+ (soap-warning
+ "soap-extract-xmlns(%s): tns alias and targetNamespace mismatch"
+ (xml-node-name node))))
+ ((and tns (not target-ns))
+ (setq target-ns (cdr tns)))
+ ((and (not tns) target-ns)
+ ;; a tns alias was not defined in this node. See if the node has
+ ;; a "targetNamespace" attribute and add an alias to this. Note
+ ;; that we might override an existing tns alias in XMLNS-TABLE,
+ ;; but that is intended.
+ (push (cons "tns" target-ns) xmlns))))
+
+ (list default-ns target-ns (append xmlns xmlns-table))))
+
+(defmacro soap-with-local-xmlns (node &rest body)
+ "Install a local alias table from NODE and execute BODY."
+ (declare (debug (form &rest form)) (indent 1))
+ (let ((xmlns (make-symbol "xmlns")))
+ `(let ((,xmlns (soap-extract-xmlns ,node soap-local-xmlns)))
+ (let ((soap-default-xmlns (or (nth 0 ,xmlns) soap-default-xmlns))
+ (soap-target-xmlns (or (nth 1 ,xmlns) soap-target-xmlns))
+ (soap-local-xmlns (nth 2 ,xmlns)))
+ ,@body))))
+
+(defun soap-get-target-namespace (node)
+ "Return the target namespace of NODE.
+This is the namespace in which new elements will be defined."
+ (or (xml-get-attribute-or-nil node 'targetNamespace)
+ (cdr (assoc "tns" soap-local-xmlns))
+ soap-target-xmlns))
+
+(defun soap-xml-get-children1 (node child-name)
+ "Return the children of NODE named CHILD-NAME.
+This is the same as `xml-get-children', but CHILD-NAME can have
+namespace tag."
+ (let (result)
+ (dolist (c (xml-node-children node))
+ (when (and (consp c)
+ (soap-with-local-xmlns c
+ ;; We use `ignore-errors' here because we want to silently
+ ;; skip nodes for which we cannot convert them to a
+ ;; well-known name.
+ (eq (ignore-errors (soap-l2wk (xml-node-name c)))
+ child-name)))
+ (push c result)))
+ (nreverse result)))
+
+(defun soap-xml-get-attribute-or-nil1 (node attribute)
+ "Return the NODE's ATTRIBUTE, or nil if it does not exist.
+This is the same as `xml-get-attribute-or-nil', but ATTRIBUTE can
+be tagged with a namespace tag."
+ (catch 'found
+ (soap-with-local-xmlns node
+ (dolist (a (xml-node-attributes node))
+ ;; We use `ignore-errors' here because we want to silently skip
+ ;; attributes for which we cannot convert them to a well-known name.
+ (when (eq (ignore-errors (soap-l2wk (car a))) attribute)
+ (throw 'found (cdr a)))))))
+
+
+;;;; XML namespaces
+
+;; An element in an XML namespace, "things" stored in soap-xml-namespaces will
+;; be derived from this object.
+
+(defstruct soap-element
+ name
+ ;; The "well-known" namespace tag for the element. For example, while
+ ;; parsing XML documents, we can have different tags for the XMLSchema
+ ;; namespace, but internally all our XMLSchema elements will have the "xsd"
+ ;; tag.
+ namespace-tag)
+
+(defun soap-element-fq-name (element)
+ "Return a fully qualified name for ELEMENT.
+A fq name is the concatenation of the namespace tag and the
+element name."
+ (concat (soap-element-namespace-tag element)
+ ":" (soap-element-name element)))
+
+;; a namespace link stores an alias for an object in once namespace to a
+;; "target" object possibly in a different namespace
+
+(defstruct (soap-namespace-link (:include soap-element))
+ target)
+
+;; A namespace is a collection of soap-element objects under a name (the name
+;; of the namespace).
+
+(defstruct soap-namespace
+ (name nil :read-only t) ; e.g "http://xml.apache.org/xml-soap"
+ (elements (make-hash-table :test 'equal) :read-only t))
+
+(defun soap-namespace-put (element ns)
+ "Store ELEMENT in NS.
+Multiple elements with the same name can be stored in a
+namespace. When retrieving the element you can specify a
+discriminant predicate to `soap-namespace-get'"
+ (let ((name (soap-element-name element)))
+ (push element (gethash name (soap-namespace-elements ns)))))
+
+(defun soap-namespace-put-link (name target ns &optional replace)
+ "Store a link from NAME to TARGET in NS.
+An error will be signaled if an element by the same name is
+already present in NS, unless REPLACE is non nil.
+
+TARGET can be either a SOAP-ELEMENT or a string denoting an
+element name into another namespace.
+
+If NAME is nil, an element with the same name as TARGET will be
+added to the namespace."
+
+ (unless (and name (not (equal name "")))
+ ;; if name is nil, use TARGET as a name...
+ (cond ((soap-element-p target)
+ (setq name (soap-element-name target)))
+ ((consp target) ; a fq name: (namespace . name)
+ (setq name (cdr target)))
+ ((stringp target)
+ (cond ((string-match "^\\(.*\\):\\(.*\\)$" target)
+ (setq name (match-string 2 target)))
+ (t
+ (setq name target))))))
+
+ ;; by now, name should be valid
+ (assert (and name (not (equal name "")))
+ nil
+ "Cannot determine name for namespace link")
+ (push (make-soap-namespace-link :name name :target target)
+ (gethash name (soap-namespace-elements ns))))
+
+(defun soap-namespace-get (name ns &optional discriminant-predicate)
+ "Retrieve an element with NAME from the namespace NS.
+If multiple elements with the same name exist,
+DISCRIMINANT-PREDICATE is used to pick one of them. This allows
+storing elements of different types (like a message type and a
+binding) but the same name."
+ (assert (stringp name))
+ (let ((elements (gethash name (soap-namespace-elements ns))))
+ (cond (discriminant-predicate
+ (catch 'found
+ (dolist (e elements)
+ (when (funcall discriminant-predicate e)
+ (throw 'found e)))))
+ ((= (length elements) 1) (car elements))
+ ((> (length elements) 1)
+ (error
+ "Soap-namespace-get(%s): multiple elements, discriminant needed"
+ name))
+ (t
+ nil))))
+
+
+;;;; WSDL documents
+;;;;; WSDL document elements
+
+(defstruct (soap-basic-type (:include soap-element))
+ kind ; a symbol of: string, dateTime, long, int
+ )
+
+(defstruct soap-sequence-element
+ name type nillable? multiple?)
+
+(defstruct (soap-sequence-type (:include soap-element))
+ parent ; OPTIONAL WSDL-TYPE name
+ elements ; LIST of SOAP-SEQUCENCE-ELEMENT
+ )
+
+(defstruct (soap-array-type (:include soap-element))
+ element-type ; WSDL-TYPE of the array elements
+ )
+
+(defstruct (soap-message (:include soap-element))
+ parts ; ALIST of NAME => WSDL-TYPE name
+ )
+
+(defstruct (soap-operation (:include soap-element))
+ parameter-order
+ input ; (NAME . MESSAGE)
+ output ; (NAME . MESSAGE)
+ faults) ; a list of (NAME . MESSAGE)
+
+(defstruct (soap-port-type (:include soap-element))
+ operations) ; a namespace of operations
+
+;; A bound operation is an operation which has a soap action and a use
+;; method attached -- these are attached as part of a binding and we
+;; can have different bindings for the same operations.
+(defstruct soap-bound-operation
+ operation ; SOAP-OPERATION
+ soap-action ; value for SOAPAction HTTP header
+ use ; 'literal or 'encoded, see
+ ; http://www.w3.org/TR/wsdl#_soap:body
+ )
+
+(defstruct (soap-binding (:include soap-element))
+ port-type
+ (operations (make-hash-table :test 'equal) :readonly t))
+
+(defstruct (soap-port (:include soap-element))
+ service-url
+ binding)
+
+(defun soap-default-xsd-types ()
+ "Return a namespace containing some of the XMLSchema types."
+ (let ((ns (make-soap-namespace :name "http://www.w3.org/2001/XMLSchema")))
+ (dolist (type '("string" "dateTime" "boolean" "long" "int" "float"
+ "base64Binary" "anyType" "Array" "byte[]"))
+ (soap-namespace-put
+ (make-soap-basic-type :name type :kind (intern type))
+ ns))
+ ns))
+
+(defun soap-default-soapenc-types ()
+ "Return a namespace containing some of the SOAPEnc types."
+ (let ((ns (make-soap-namespace
+ :name "http://schemas.xmlsoap.org/soap/encoding/")))
+ (dolist (type '("string" "dateTime" "boolean" "long" "int" "float"
+ "base64Binary" "anyType" "Array" "byte[]"))
+ (soap-namespace-put
+ (make-soap-basic-type :name type :kind (intern type))
+ ns))
+ ns))
+
+(defun soap-type-p (element)
+ "Return t if ELEMENT is a SOAP data type (basic or complex)."
+ (or (soap-basic-type-p element)
+ (soap-sequence-type-p element)
+ (soap-array-type-p element)))
+
+
+;;;;; The WSDL document
+
+;; The WSDL data structure used for encoding/decoding SOAP messages
+(defstruct soap-wsdl
+ origin ; file or URL from which this wsdl was loaded
+ ports ; a list of SOAP-PORT instances
+ alias-table ; a list of namespace aliases
+ namespaces ; a list of namespaces
+ )
+
+(defun soap-wsdl-add-alias (alias name wsdl)
+ "Add a namespace ALIAS for NAME to the WSDL document."
+ (push (cons alias name) (soap-wsdl-alias-table wsdl)))
+
+(defun soap-wsdl-find-namespace (name wsdl)
+ "Find a namespace by NAME in the WSDL document."
+ (catch 'found
+ (dolist (ns (soap-wsdl-namespaces wsdl))
+ (when (equal name (soap-namespace-name ns))
+ (throw 'found ns)))))
+
+(defun soap-wsdl-add-namespace (ns wsdl)
+ "Add the namespace NS to the WSDL document.
+If a namespace by this name already exists in WSDL, individual
+elements will be added to it."
+ (let ((existing (soap-wsdl-find-namespace (soap-namespace-name ns) wsdl)))
+ (if existing
+ ;; Add elements from NS to EXISTING, replacing existing values.
+ (maphash (lambda (key value)
+ (dolist (v value)
+ (soap-namespace-put v existing)))
+ (soap-namespace-elements ns))
+ (push ns (soap-wsdl-namespaces wsdl)))))
+
+(defun soap-wsdl-get (name wsdl &optional predicate use-local-alias-table)
+ "Retrieve element NAME from the WSDL document.
+
+PREDICATE is used to differentiate between elements when NAME
+refers to multiple elements. A typical value for this would be a
+structure predicate for the type of element you want to retrieve.
+For example, to retrieve a message named \"foo\" when other
+elements named \"foo\" exist in the WSDL you could use:
+
+ (soap-wsdl-get \"foo\" WSDL 'soap-message-p)
+
+If USE-LOCAL-ALIAS-TABLE is not nil, `soap-local-xmlns` will be
+used to resolve the namespace alias."
+ (let ((alias-table (soap-wsdl-alias-table wsdl))
+ namespace element-name element)
+
+ (when (symbolp name)
+ (setq name (symbol-name name)))
+
+ (when use-local-alias-table
+ (setq alias-table (append soap-local-xmlns alias-table)))
+
+ (cond ((consp name) ; a fully qualified name, as returned by `soap-l2fq'
+ (setq element-name (cdr name))
+ (when (symbolp element-name)
+ (setq element-name (symbol-name element-name)))
+ (setq namespace (soap-wsdl-find-namespace (car name) wsdl))
+ (unless namespace
+ (error "Soap-wsdl-get(%s): unknown namespace: %s" name namespace)))
+
+ ((string-match "^\\(.*\\):\\(.*\\)$" name)
+ (setq element-name (match-string 2 name))
+
+ (let* ((ns-alias (match-string 1 name))
+ (ns-name (cdr (assoc ns-alias alias-table))))
+ (unless ns-name
+ (error "Soap-wsdl-get(%s): cannot find namespace alias %s"
+ name ns-alias))
+
+ (setq namespace (soap-wsdl-find-namespace ns-name wsdl))
+ (unless namespace
+ (error
+ "Soap-wsdl-get(%s): unknown namespace %s, referenced by alias %s"
+ name ns-name ns-alias))))
+ (t
+ (error "Soap-wsdl-get(%s): bad name" name)))
+
+ (setq element (soap-namespace-get
+ element-name namespace
+ (if predicate
+ (lambda (e)
+ (or (funcall 'soap-namespace-link-p e)
+ (funcall predicate e)))
+ nil)))
+
+ (unless element
+ (error "Soap-wsdl-get(%s): cannot find element" name))
+
+ (if (soap-namespace-link-p element)
+ ;; NOTE: don't use the local alias table here
+ (soap-wsdl-get (soap-namespace-link-target element) wsdl predicate)
+ element)))
+
+;;;;; Resolving references for wsdl types
+
+;; See `soap-wsdl-resolve-references', which is the main entry point for
+;; resolving references
+
+(defun soap-resolve-references-for-element (element wsdl)
+ "Resolve references in ELEMENT using the WSDL document.
+This is a generic function which invokes a specific function
+depending on the element type.
+
+If ELEMENT has no resolver function, it is silently ignored.
+
+All references are resolved in-place, that is the ELEMENT is
+updated."
+ (let ((resolver (get (aref element 0) 'soap-resolve-references)))
+ (when resolver
+ (funcall resolver element wsdl))))
+
+(defun soap-resolve-references-for-sequence-type (type wsdl)
+ "Resolve references for a sequence TYPE using WSDL document.
+See also `soap-resolve-references-for-element' and
+`soap-wsdl-resolve-references'"
+ (let ((parent (soap-sequence-type-parent type)))
+ (when (or (consp parent) (stringp parent))
+ (setf (soap-sequence-type-parent type)
+ (soap-wsdl-get parent wsdl 'soap-type-p))))
+ (dolist (element (soap-sequence-type-elements type))
+ (let ((element-type (soap-sequence-element-type element)))
+ (cond ((or (consp element-type) (stringp element-type))
+ (setf (soap-sequence-element-type element)
+ (soap-wsdl-get element-type wsdl 'soap-type-p)))
+ ((soap-element-p element-type)
+ ;; since the element already has a child element, it
+ ;; could be an inline structure. we must resolve
+ ;; references in it, because it might not be reached by
+ ;; scanning the wsdl names.
+ (soap-resolve-references-for-element element-type wsdl))))))
+
+(defun soap-resolve-references-for-array-type (type wsdl)
+ "Resolve references for an array TYPE using WSDL.
+See also `soap-resolve-references-for-element' and
+`soap-wsdl-resolve-references'"
+ (let ((element-type (soap-array-type-element-type type)))
+ (when (or (consp element-type) (stringp element-type))
+ (setf (soap-array-type-element-type type)
+ (soap-wsdl-get element-type wsdl 'soap-type-p)))))
+
+(defun soap-resolve-references-for-message (message wsdl)
+ "Resolve references for a MESSAGE type using the WSDL document.
+See also `soap-resolve-references-for-element' and
+`soap-wsdl-resolve-references'"
+ (let (resolved-parts)
+ (dolist (part (soap-message-parts message))
+ (let ((name (car part))
+ (type (cdr part)))
+ (when (stringp name)
+ (setq name (intern name)))
+ (when (or (consp type) (stringp type))
+ (setq type (soap-wsdl-get type wsdl 'soap-type-p)))
+ (push (cons name type) resolved-parts)))
+ (setf (soap-message-parts message) (nreverse resolved-parts))))
+
+(defun soap-resolve-references-for-operation (operation wsdl)
+ "Resolve references for an OPERATION type using the WSDL document.
+See also `soap-resolve-references-for-element' and
+`soap-wsdl-resolve-references'"
+ (let ((input (soap-operation-input operation))
+ (counter 0))
+ (let ((name (car input))
+ (message (cdr input)))
+ ;; Name this part if it was not named
+ (when (or (null name) (equal name ""))
+ (setq name (format "in%d" (incf counter))))
+ (when (or (consp message) (stringp message))
+ (setf (soap-operation-input operation)
+ (cons (intern name)
+ (soap-wsdl-get message wsdl 'soap-message-p))))))
+
+ (let ((output (soap-operation-output operation))
+ (counter 0))
+ (let ((name (car output))
+ (message (cdr output)))
+ (when (or (null name) (equal name ""))
+ (setq name (format "out%d" (incf counter))))
+ (when (or (consp message) (stringp message))
+ (setf (soap-operation-output operation)
+ (cons (intern name)
+ (soap-wsdl-get message wsdl 'soap-message-p))))))
+
+ (let ((resolved-faults nil)
+ (counter 0))
+ (dolist (fault (soap-operation-faults operation))
+ (let ((name (car fault))
+ (message (cdr fault)))
+ (when (or (null name) (equal name ""))
+ (setq name (format "fault%d" (incf counter))))
+ (if (or (consp message) (stringp message))
+ (push (cons (intern name)
+ (soap-wsdl-get message wsdl 'soap-message-p))
+ resolved-faults)
+ (push fault resolved-faults))))
+ (setf (soap-operation-faults operation) resolved-faults))
+
+ (when (= (length (soap-operation-parameter-order operation)) 0)
+ (setf (soap-operation-parameter-order operation)
+ (mapcar 'car (soap-message-parts
+ (cdr (soap-operation-input operation))))))
+
+ (setf (soap-operation-parameter-order operation)
+ (mapcar (lambda (p)
+ (if (stringp p)
+ (intern p)
+ p))
+ (soap-operation-parameter-order operation))))
+
+(defun soap-resolve-references-for-binding (binding wsdl)
+ "Resolve references for a BINDING type using the WSDL document.
+See also `soap-resolve-references-for-element' and
+`soap-wsdl-resolve-references'"
+ (when (or (consp (soap-binding-port-type binding))
+ (stringp (soap-binding-port-type binding)))
+ (setf (soap-binding-port-type binding)
+ (soap-wsdl-get (soap-binding-port-type binding)
+ wsdl 'soap-port-type-p)))
+
+ (let ((port-ops (soap-port-type-operations (soap-binding-port-type binding))))
+ (maphash (lambda (k v)
+ (setf (soap-bound-operation-operation v)
+ (soap-namespace-get k port-ops 'soap-operation-p)))
+ (soap-binding-operations binding))))
+
+(defun soap-resolve-references-for-port (port wsdl)
+ "Resolve references for a PORT type using the WSDL document.
+See also `soap-resolve-references-for-element' and
+`soap-wsdl-resolve-references'"
+ (when (or (consp (soap-port-binding port))
+ (stringp (soap-port-binding port)))
+ (setf (soap-port-binding port)
+ (soap-wsdl-get (soap-port-binding port) wsdl 'soap-binding-p))))
+
+;; Install resolvers for our types
+(progn
+ (put (aref (make-soap-sequence-type) 0) 'soap-resolve-references
+ 'soap-resolve-references-for-sequence-type)
+ (put (aref (make-soap-array-type) 0) 'soap-resolve-references
+ 'soap-resolve-references-for-array-type)
+ (put (aref (make-soap-message) 0) 'soap-resolve-references
+ 'soap-resolve-references-for-message)
+ (put (aref (make-soap-operation) 0) 'soap-resolve-references
+ 'soap-resolve-references-for-operation)
+ (put (aref (make-soap-binding) 0) 'soap-resolve-references
+ 'soap-resolve-references-for-binding)
+ (put (aref (make-soap-port) 0) 'soap-resolve-references
+ 'soap-resolve-references-for-port))
+
+(defun soap-wsdl-resolve-references (wsdl)
+ "Resolve all references inside the WSDL structure.
+
+When the WSDL elements are created from the XML document, they
+refer to each other by name. For example, the ELEMENT-TYPE slot
+of an SOAP-ARRAY-TYPE will contain the name of the element and
+the user would have to call `soap-wsdl-get' to obtain the actual
+element.
+
+After the entire document is loaded, we resolve all these
+references to the actual elements they refer to so that at
+runtime, we don't have to call `soap-wsdl-get' each time we
+traverse an element tree."
+ (let ((nprocessed 0)
+ (nstag-id 0)
+ (alias-table (soap-wsdl-alias-table wsdl)))
+ (dolist (ns (soap-wsdl-namespaces wsdl))
+ (let ((nstag (car-safe (rassoc (soap-namespace-name ns) alias-table))))
+ (unless nstag
+ ;; If this namespace does not have an alias, create one for it.
+ (catch 'done
+ (while t
+ (setq nstag (format "ns%d" (incf nstag-id)))
+ (unless (assoc nstag alias-table)
+ (soap-wsdl-add-alias nstag (soap-namespace-name ns) wsdl)
+ (throw 'done t)))))
+
+ (maphash (lambda (name element)
+ (cond ((soap-element-p element) ; skip links
+ (incf nprocessed)
+ (soap-resolve-references-for-element element wsdl)
+ (setf (soap-element-namespace-tag element) nstag))
+ ((listp element)
+ (dolist (e element)
+ (when (soap-element-p e)
+ (incf nprocessed)
+ (soap-resolve-references-for-element e wsdl)
+ (setf (soap-element-namespace-tag e) nstag))))))
+ (soap-namespace-elements ns))))
+
+ (message "Processed %d" nprocessed))
+ wsdl)
+
+;;;;; Loading WSDL from XML documents
+
+(defun soap-load-wsdl-from-url (url)
+ "Load a WSDL document from URL and return it.
+The returned WSDL document needs to be used for `soap-invoke'
+calls."
+ (let ((url-request-method "GET")
+ (url-package-name "soap-client.el")
+ (url-package-version "1.0")
+ (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5")
+ (url-request-coding-system 'utf-8)
+ (url-http-attempt-keepalives nil))
+ (let ((buffer (url-retrieve-synchronously url)))
+ (with-current-buffer buffer
+ (declare (special url-http-response-status))
+ (if (> url-http-response-status 299)
+ (error "Error retrieving WSDL: %s" url-http-response-status))
+ (let ((mime-part (mm-dissect-buffer t t)))
+ (unless mime-part
+ (error "Failed to decode response from server"))
+ (unless (equal (car (mm-handle-type mime-part)) "text/xml")
+ (error "Server response is not an XML document"))
+ (with-temp-buffer
+ (mm-insert-part mime-part)
+ (let ((wsdl-xml (car (xml-parse-region (point-min) (point-max)))))
+ (prog1
+ (let ((wsdl (soap-parse-wsdl wsdl-xml)))
+ (setf (soap-wsdl-origin wsdl) url)
+ wsdl)
+ (kill-buffer buffer)))))))))
+
+(defun soap-load-wsdl (file)
+ "Load a WSDL document from FILE and return it."
+ (with-temp-buffer
+ (insert-file-contents file)
+ (let ((xml (car (xml-parse-region (point-min) (point-max)))))
+ (let ((wsdl (soap-parse-wsdl xml)))
+ (setf (soap-wsdl-origin wsdl) file)
+ wsdl))))
+
+(defun soap-parse-wsdl (node)
+ "Construct a WSDL structure from NODE, which is an XML document."
+ (soap-with-local-xmlns node
+
+ (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:definitions)
+ nil
+ "soap-parse-wsdl: expecting wsdl:definitions node, got %s"
+ (soap-l2wk (xml-node-name node)))
+
+ (let ((wsdl (make-soap-wsdl)))
+
+ ;; Add the local alias table to the wsdl document -- it will be used for
+ ;; all types in this document even after we finish parsing it.
+ (setf (soap-wsdl-alias-table wsdl) soap-local-xmlns)
+
+ ;; Add the XSD types to the wsdl document
+ (let ((ns (soap-default-xsd-types)))
+ (soap-wsdl-add-namespace ns wsdl)
+ (soap-wsdl-add-alias "xsd" (soap-namespace-name ns) wsdl))
+
+ ;; Add the soapenc types to the wsdl document
+ (let ((ns (soap-default-soapenc-types)))
+ (soap-wsdl-add-namespace ns wsdl)
+ (soap-wsdl-add-alias "soapenc" (soap-namespace-name ns) wsdl))
+
+ ;; Find all the 'xsd:schema nodes which are children of wsdl:types nodes
+ ;; and build our type-library
+
+ (let ((types (car (soap-xml-get-children1 node 'wsdl:types))))
+ (dolist (node (xml-node-children types))
+ ;; We cannot use (xml-get-children node (soap-wk2l 'xsd:schema))
+ ;; because each node can install its own alias type so the schema
+ ;; nodes might have a different prefix.
+ (when (consp node)
+ (soap-with-local-xmlns node
+ (when (eq (soap-l2wk (xml-node-name node)) 'xsd:schema)
+ (soap-wsdl-add-namespace (soap-parse-schema node) wsdl))))))
+
+ (let ((ns (make-soap-namespace :name (soap-get-target-namespace node))))
+ (dolist (node (soap-xml-get-children1 node 'wsdl:message))
+ (soap-namespace-put (soap-parse-message node) ns))
+
+ (dolist (node (soap-xml-get-children1 node 'wsdl:portType))
+ (let ((port-type (soap-parse-port-type node)))
+ (soap-namespace-put port-type ns)
+ (soap-wsdl-add-namespace
+ (soap-port-type-operations port-type) wsdl)))
+
+ (dolist (node (soap-xml-get-children1 node 'wsdl:binding))
+ (soap-namespace-put (soap-parse-binding node) ns))
+
+ (dolist (node (soap-xml-get-children1 node 'wsdl:service))
+ (dolist (node (soap-xml-get-children1 node 'wsdl:port))
+ (let ((name (xml-get-attribute node 'name))
+ (binding (xml-get-attribute node 'binding))
+ (url (let ((n (car (soap-xml-get-children1
+ node 'wsdlsoap:address))))
+ (xml-get-attribute n 'location))))
+ (let ((port (make-soap-port
+ :name name :binding (soap-l2fq binding 'tns)
+ :service-url url)))
+ (soap-namespace-put port ns)
+ (push port (soap-wsdl-ports wsdl))))))
+
+ (soap-wsdl-add-namespace ns wsdl))
+
+ (soap-wsdl-resolve-references wsdl)
+
+ wsdl)))
+
+(defun soap-parse-schema (node)
+ "Parse a schema NODE.
+Return a SOAP-NAMESPACE containing the elements."
+ (soap-with-local-xmlns node
+ (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:schema)
+ nil
+ "soap-parse-schema: expecting an xsd:schema node, got %s"
+ (soap-l2wk (xml-node-name node)))
+ (let ((ns (make-soap-namespace :name (soap-get-target-namespace node))))
+ ;; NOTE: we only extract the complexTypes from the schema, we wouldn't
+ ;; know how to handle basic types beyond the built in ones anyway.
+ (dolist (node (soap-xml-get-children1 node 'xsd:complexType))
+ (soap-namespace-put (soap-parse-complex-type node) ns))
+
+ (dolist (node (soap-xml-get-children1 node 'xsd:element))
+ (soap-namespace-put (soap-parse-schema-element node) ns))
+
+ ns)))
+
+(defun soap-parse-schema-element (node)
+ "Parse NODE and construct a schema element from it."
+ (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:element)
+ nil
+ "soap-parse-schema-element: expecting xsd:element node, got %s"
+ (soap-l2wk (xml-node-name node)))
+ (let ((name (xml-get-attribute-or-nil node 'name))
+ type)
+ ;; A schema element that contains an inline complex type --
+ ;; construct the actual complex type for it.
+ (let ((type-node (soap-xml-get-children1 node 'xsd:complexType)))
+ (when (> (length type-node) 0)
+ (assert (= (length type-node) 1)) ; only one complex type
+ ; definition per element
+ (setq type (soap-parse-complex-type (car type-node)))))
+ (setf (soap-element-name type) name)
+ type))
+
+(defun soap-parse-complex-type (node)
+ "Parse NODE and construct a complex type from it."
+ (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:complexType)
+ nil
+ "soap-parse-complex-type: expecting xsd:complexType node, got %s"
+ (soap-l2wk (xml-node-name node)))
+ (let ((name (xml-get-attribute-or-nil node 'name))
+ ;; Use a dummy type for the complex type, it will be replaced
+ ;; with the real type below, except when the complex type node
+ ;; is empty...
+ (type (make-soap-sequence-type :elements nil)))
+ (dolist (c (xml-node-children node))
+ (when (consp c) ; skip string nodes, which are whitespace
+ (let ((node-name (soap-l2wk (xml-node-name c))))
+ (cond
+ ;; The difference between xsd:all and xsd:sequence is that fields
+ ;; in xsd:all are not ordered and they can occur only once. We
+ ;; don't care about that difference in soap-client.el
+ ((or (eq node-name 'xsd:sequence)
+ (eq node-name 'xsd:all))
+ (setq type (soap-parse-complex-type-sequence c)))
+ ((eq node-name 'xsd:complexContent)
+ (setq type (soap-parse-complex-type-complex-content c)))
+ ((eq node-name 'xsd:attribute)
+ ;; The name of this node comes from an attribute tag
+ (let ((n (xml-get-attribute-or-nil c 'name)))
+ (setq name n)))
+ (t
+ (error "Unknown node type %s" node-name))))))
+ (setf (soap-element-name type) name)
+ type))
+
+(defun soap-parse-sequence (node)
+ "Parse NODE and a list of sequence elements that it defines.
+NODE is assumed to be an xsd:sequence node. In that case, each
+of its children is assumed to be a sequence element. Each
+sequence element is parsed constructing the corresponding type.
+A list of these types is returned."
+ (assert (let ((n (soap-l2wk (xml-node-name node))))
+ (memq n '(xsd:sequence xsd:all)))
+ nil
+ "soap-parse-sequence: expecting xsd:sequence or xsd:all node, got %s"
+ (soap-l2wk (xml-node-name node)))
+ (let (elements)
+ (dolist (e (soap-xml-get-children1 node 'xsd:element))
+ (let ((name (xml-get-attribute-or-nil e 'name))
+ (type (xml-get-attribute-or-nil e 'type))
+ (nillable? (or (equal (xml-get-attribute-or-nil e 'nillable) "true")
+ (let ((e (xml-get-attribute-or-nil e 'minOccurs)))
+ (and e (equal e "0")))))
+ (multiple? (let ((e (xml-get-attribute-or-nil e 'maxOccurs)))
+ (and e (not (equal e "1"))))))
+ (if type
+ (setq type (soap-l2fq type 'tns))
+
+ ;; The node does not have a type, maybe it has a complexType
+ ;; defined inline...
+ (let ((type-node (soap-xml-get-children1 e 'xsd:complexType)))
+ (when (> (length type-node) 0)
+ (assert (= (length type-node) 1)
+ nil
+ "only one complex type definition per element supported")
+ (setq type (soap-parse-complex-type (car type-node))))))
+
+ (push (make-soap-sequence-element
+ :name (intern name) :type type :nillable? nillable?
+ :multiple? multiple?)
+ elements)))
+ (nreverse elements)))
+
+(defun soap-parse-complex-type-sequence (node)
+ "Parse NODE as a sequence type."
+ (let ((elements (soap-parse-sequence node)))
+ (make-soap-sequence-type :elements elements)))
+
+(defun soap-parse-complex-type-complex-content (node)
+ "Parse NODE as a xsd:complexContent node.
+A sequence or an array type is returned depending on the actual
+contents."
+ (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:complexContent)
+ nil
+ "soap-parse-complex-type-complex-content: expecting xsd:complexContent node, got %s"
+ (soap-l2wk (xml-node-name node)))
+ (let (array? parent elements)
+ (let ((extension (car-safe (soap-xml-get-children1 node 'xsd:extension)))
+ (restriction (car-safe
+ (soap-xml-get-children1 node 'xsd:restriction))))
+ ;; a complex content node is either an extension or a restriction
+ (cond (extension
+ (setq parent (xml-get-attribute-or-nil extension 'base))
+ (setq elements (soap-parse-sequence
+ (car (soap-xml-get-children1
+ extension 'xsd:sequence)))))
+ (restriction
+ (let ((base (xml-get-attribute-or-nil restriction 'base)))
+ (assert (equal base "soapenc:Array")
+ nil
+ "restrictions supported only for soapenc:Array types, this is a %s"
+ base))
+ (setq array? t)
+ (let ((attribute (car (soap-xml-get-children1
+ restriction 'xsd:attribute))))
+ (let ((array-type (soap-xml-get-attribute-or-nil1
+ attribute 'wsdl:arrayType)))
+ (when (string-match "^\\(.*\\)\\[\\]$" array-type)
+ (setq parent (match-string 1 array-type))))))
+
+ (t
+ (error "Unknown complex type"))))
+
+ (if parent
+ (setq parent (soap-l2fq parent 'tns)))
+
+ (if array?
+ (make-soap-array-type :element-type parent)
+ (make-soap-sequence-type :parent parent :elements elements))))
+
+(defun soap-parse-message (node)
+ "Parse NODE as a wsdl:message and return the corresponding type."
+ (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:message)
+ nil
+ "soap-parse-message: expecting wsdl:message node, got %s"
+ (soap-l2wk (xml-node-name node)))
+ (let ((name (xml-get-attribute-or-nil node 'name))
+ parts)
+ (dolist (p (soap-xml-get-children1 node 'wsdl:part))
+ (let ((name (xml-get-attribute-or-nil p 'name))
+ (type (xml-get-attribute-or-nil p 'type))
+ (element (xml-get-attribute-or-nil p 'element)))
+
+ (when type
+ (setq type (soap-l2fq type 'tns)))
+
+ (when element
+ (setq element (soap-l2fq element 'tns)))
+
+ (push (cons name (or type element)) parts)))
+ (make-soap-message :name name :parts (nreverse parts))))
+
+(defun soap-parse-port-type (node)
+ "Parse NODE as a wsdl:portType and return the corresponding port."
+ (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:portType)
+ nil
+ "soap-parse-port-type: expecting wsdl:portType node got %s"
+ (soap-l2wk (xml-node-name node)))
+ (let ((ns (make-soap-namespace
+ :name (concat "urn:" (xml-get-attribute node 'name)))))
+ (dolist (node (soap-xml-get-children1 node 'wsdl:operation))
+ (let ((o (soap-parse-operation node)))
+
+ (let ((other-operation (soap-namespace-get
+ (soap-element-name o) ns 'soap-operation-p)))
+ (if other-operation
+ ;; Unfortunately, the Confluence WSDL defines two operations
+ ;; named "search" which differ only in parameter names...
+ (soap-warning "Discarding duplicate operation: %s"
+ (soap-element-name o))
+
+ (progn
+ (soap-namespace-put o ns)
+
+ ;; link all messages from this namespace, as this namespace
+ ;; will be used for decoding the response.
+ (destructuring-bind (name . message) (soap-operation-input o)
+ (soap-namespace-put-link name message ns))
+
+ (destructuring-bind (name . message) (soap-operation-output o)
+ (soap-namespace-put-link name message ns))
+
+ (dolist (fault (soap-operation-faults o))
+ (destructuring-bind (name . message) fault
+ (soap-namespace-put-link name message ns 'replace)))
+
+ )))))
+
+ (make-soap-port-type :name (xml-get-attribute node 'name)
+ :operations ns)))
+
+(defun soap-parse-operation (node)
+ "Parse NODE as a wsdl:operation and return the corresponding type."
+ (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:operation)
+ nil
+ "soap-parse-operation: expecting wsdl:operation node, got %s"
+ (soap-l2wk (xml-node-name node)))
+ (let ((name (xml-get-attribute node 'name))
+ (parameter-order (split-string
+ (xml-get-attribute node 'parameterOrder)))
+ input output faults)
+ (dolist (n (xml-node-children node))
+ (when (consp n) ; skip string nodes which are whitespace
+ (let ((node-name (soap-l2wk (xml-node-name n))))
+ (cond
+ ((eq node-name 'wsdl:input)
+ (let ((message (xml-get-attribute n 'message))
+ (name (xml-get-attribute n 'name)))
+ (setq input (cons name (soap-l2fq message 'tns)))))
+ ((eq node-name 'wsdl:output)
+ (let ((message (xml-get-attribute n 'message))
+ (name (xml-get-attribute n 'name)))
+ (setq output (cons name (soap-l2fq message 'tns)))))
+ ((eq node-name 'wsdl:fault)
+ (let ((message (xml-get-attribute n 'message))
+ (name (xml-get-attribute n 'name)))
+ (push (cons name (soap-l2fq message 'tns)) faults)))))))
+ (make-soap-operation
+ :name name
+ :parameter-order parameter-order
+ :input input
+ :output output
+ :faults (nreverse faults))))
+
+(defun soap-parse-binding (node)
+ "Parse NODE as a wsdl:binding and return the corresponding type."
+ (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:binding)
+ nil
+ "soap-parse-binding: expecting wsdl:binding node, got %s"
+ (soap-l2wk (xml-node-name node)))
+ (let ((name (xml-get-attribute node 'name))
+ (type (xml-get-attribute node 'type)))
+ (let ((binding (make-soap-binding :name name
+ :port-type (soap-l2fq type 'tns))))
+ (dolist (wo (soap-xml-get-children1 node 'wsdl:operation))
+ (let ((name (xml-get-attribute wo 'name))
+ soap-action
+ use)
+ (dolist (so (soap-xml-get-children1 wo 'wsdlsoap:operation))
+ (setq soap-action (xml-get-attribute-or-nil so 'soapAction)))
+
+ ;; Search a wsdlsoap:body node and find a "use" tag. The
+ ;; same use tag is assumed to be present for both input and
+ ;; output types (although the WDSL spec allows separate
+ ;; "use"-s for each of them...
+
+ (dolist (i (soap-xml-get-children1 wo 'wsdl:input))
+ (dolist (b (soap-xml-get-children1 i 'wsdlsoap:body))
+ (setq use (or use
+ (xml-get-attribute-or-nil b 'use)))))
+
+ (unless use
+ (dolist (i (soap-xml-get-children1 wo 'wsdl:output))
+ (dolist (b (soap-xml-get-children1 i 'wsdlsoap:body))
+ (setq use (or use
+ (xml-get-attribute-or-nil b 'use))))))
+
+ (puthash name (make-soap-bound-operation :operation name
+ :soap-action soap-action
+ :use (and use (intern use)))
+ (soap-binding-operations binding))))
+ binding)))
+
+;;;; SOAP type decoding
+
+(defvar soap-multi-refs nil
+ "The list of multi-ref nodes in the current SOAP response.
+This is a dynamically bound variable used during decoding the
+SOAP response.")
+
+(defvar soap-decoded-multi-refs nil
+ "List of decoded multi-ref nodes in the current SOAP response.
+This is a dynamically bound variable used during decoding the
+SOAP response.")
+
+(defvar soap-current-wsdl nil
+ "The current WSDL document used when decoding the SOAP response.
+This is a dynamically bound variable.")
+
+(defun soap-decode-type (type node)
+ "Use TYPE (an xsd type) to decode the contents of NODE.
+
+NODE is an XML node, representing some SOAP encoded value or a
+reference to another XML node (a multiRef). This function will
+resolve the multiRef reference, if any, than call a TYPE specific
+decode function to perform the actual decoding."
+ (let ((href (xml-get-attribute-or-nil node 'href)))
+ (cond (href
+ (catch 'done
+ ;; NODE is actually a HREF, find the target and decode that.
+ ;; Check first if we already decoded this multiref.
+
+ (let ((decoded (cdr (assoc href soap-decoded-multi-refs))))
+ (when decoded
+ (throw 'done decoded)))
+
+ (string-match "^#\\(.*\\)$" href) ; TODO: check that it matched
+
+ (let ((id (match-string 1 href)))
+ (dolist (mr soap-multi-refs)
+ (let ((mrid (xml-get-attribute mr 'id)))
+ (when (equal id mrid)
+ ;; recurse here, in case there are multiple HREF's
+ (let ((decoded (soap-decode-type type mr)))
+ (push (cons href decoded) soap-decoded-multi-refs)
+ (throw 'done decoded)))))
+ (error "Cannot find href %s" href))))
+ (t
+ (soap-with-local-xmlns node
+ (if (equal (soap-xml-get-attribute-or-nil1 node 'xsi:nil) "true")
+ nil
+ (let ((decoder (get (aref type 0) 'soap-decoder)))
+ (assert decoder nil "no soap-decoder for %s type"
+ (aref type 0))
+ (funcall decoder type node))))))))
+
+(defun soap-decode-any-type (node)
+ "Decode NODE using type information inside it."
+ ;; If the NODE has type information, we use that...
+ (let ((type (soap-xml-get-attribute-or-nil1 node 'xsi:type)))
+ (if type
+ (let ((wtype (soap-wsdl-get type soap-current-wsdl 'soap-type-p)))
+ (if wtype
+ (soap-decode-type wtype node)
+ ;; The node has type info encoded in it, but we don't know how
+ ;; to decode it...
+ (error "Soap-decode-any-type: node has unknown type: %s" type)))
+
+ ;; No type info in the node...
+
+ (let ((contents (xml-node-children node)))
+ (if (and (= (length contents) 1) (stringp (car contents)))
+ ;; contents is just a string
+ (car contents)
+
+ ;; we assume the NODE is a sequence with every element a
+ ;; structure name
+ (let (result)
+ (dolist (element contents)
+ (let ((key (xml-node-name element))
+ (value (soap-decode-any-type element)))
+ (push (cons key value) result)))
+ (nreverse result)))))))
+
+(defun soap-decode-array (node)
+ "Decode NODE as an Array using type information inside it."
+ (let ((type (soap-xml-get-attribute-or-nil1 node 'soapenc:arrayType))
+ (wtype nil)
+ (contents (xml-node-children node))
+ result)
+ (when type
+ ;; Type is in the format "someType[NUM]" where NUM is the number of
+ ;; elements in the array. We discard the [NUM] part.
+ (setq type (replace-regexp-in-string "\\[[0-9]+\\]\\'" "" type))
+ (setq wtype (soap-wsdl-get type soap-current-wsdl 'soap-type-p))
+ (unless wtype
+ ;; The node has type info encoded in it, but we don't know how to
+ ;; decode it...
+ (error "Soap-decode-array: node has unknown type: %s" type)))
+ (dolist (e contents)
+ (when (consp e)
+ (push (if wtype
+ (soap-decode-type wtype e)
+ (soap-decode-any-type e))
+ result)))
+ (nreverse result)))
+
+(defun soap-decode-basic-type (type node)
+ "Use TYPE to decode the contents of NODE.
+TYPE is a `soap-basic-type' struct, and NODE is an XML document.
+A LISP value is returned based on the contents of NODE and the
+type-info stored in TYPE."
+ (let ((contents (xml-node-children node))
+ (type-kind (soap-basic-type-kind type)))
+
+ (if (null contents)
+ nil
+ (ecase type-kind
+ (string (car contents))
+ (dateTime (car contents)) ; TODO: convert to a date time
+ ((long int float) (string-to-number (car contents)))
+ (boolean (string= (downcase (car contents)) "true"))
+ (base64Binary (base64-decode-string (car contents)))
+ (anyType (soap-decode-any-type node))
+ (Array (soap-decode-array node))))))
+
+(defun soap-decode-sequence-type (type node)
+ "Use TYPE to decode the contents of NODE.
+TYPE is assumed to be a sequence type and an ALIST with the
+contents of the NODE is returned."
+ (let ((result nil)
+ (parent (soap-sequence-type-parent type)))
+ (when parent
+ (setq result (nreverse (soap-decode-type parent node))))
+ (dolist (element (soap-sequence-type-elements type))
+ (let ((instance-count 0)
+ (e-name (soap-sequence-element-name element))
+ (e-type (soap-sequence-element-type element)))
+ (dolist (node (xml-get-children node e-name))
+ (incf instance-count)
+ (push (cons e-name (soap-decode-type e-type node)) result))
+ ;; Do some sanity checking
+ (cond ((and (= instance-count 0)
+ (not (soap-sequence-element-nillable? element)))
+ (soap-warning "While decoding %s: missing non-nillable slot %s"
+ (soap-element-name type) e-name))
+ ((and (> instance-count 1)
+ (not (soap-sequence-element-multiple? element)))
+ (soap-warning "While decoding %s: multiple slots named %s"
+ (soap-element-name type) e-name)))))
+ (nreverse result)))
+
+(defun soap-decode-array-type (type node)
+ "Use TYPE to decode the contents of NODE.
+TYPE is assumed to be an array type. Arrays are decoded as lists.
+This is because it is easier to work with list results in LISP."
+ (let ((result nil)
+ (element-type (soap-array-type-element-type type)))
+ (dolist (node (xml-node-children node))
+ (when (consp node)
+ (push (soap-decode-type element-type node) result)))
+ (nreverse result)))
+
+(progn
+ (put (aref (make-soap-basic-type) 0)
+ 'soap-decoder 'soap-decode-basic-type)
+ (put (aref (make-soap-sequence-type) 0)
+ 'soap-decoder 'soap-decode-sequence-type)
+ (put (aref (make-soap-array-type) 0)
+ 'soap-decoder 'soap-decode-array-type))
+
+;;;; Soap Envelope parsing
+
+(put 'soap-error
+ 'error-conditions
+ '(error soap-error))
+(put 'soap-error 'error-message "SOAP error")
+
+(defun soap-parse-envelope (node operation wsdl)
+ "Parse the SOAP envelope in NODE and return the response.
+OPERATION is the WSDL operation for which we expect the response,
+WSDL is used to decode the NODE"
+ (soap-with-local-xmlns node
+ (assert (eq (soap-l2wk (xml-node-name node)) 'soap:Envelope)
+ nil
+ "soap-parse-envelope: expecting soap:Envelope node, got %s"
+ (soap-l2wk (xml-node-name node)))
+ (let ((body (car (soap-xml-get-children1 node 'soap:Body))))
+
+ (let ((fault (car (soap-xml-get-children1 body 'soap:Fault))))
+ (when fault
+ (let ((fault-code (let ((n (car (xml-get-children
+ fault 'faultcode))))
+ (car-safe (xml-node-children n))))
+ (fault-string (let ((n (car (xml-get-children
+ fault 'faultstring))))
+ (car-safe (xml-node-children n)))))
+ (while t
+ (signal 'soap-error (list fault-code fault-string))))))
+
+ ;; First (non string) element of the body is the root node of he
+ ;; response
+ (let ((response (if (eq (soap-bound-operation-use operation) 'literal)
+ ;; For 'literal uses, the response is the actual body
+ body
+ ;; ...otherwise the first non string element
+ ;; of the body is the response
+ (catch 'found
+ (dolist (n (xml-node-children body))
+ (when (consp n)
+ (throw 'found n)))))))
+ (soap-parse-response response operation wsdl body)))))
+
+(defun soap-parse-response (response-node operation wsdl soap-body)
+ "Parse RESPONSE-NODE and return the result as a LISP value.
+OPERATION is the WSDL operation for which we expect the response,
+WSDL is used to decode the NODE.
+
+SOAP-BODY is the body of the SOAP envelope (of which
+RESPONSE-NODE is a sub-node). It is used in case RESPONSE-NODE
+reference multiRef parts which are external to RESPONSE-NODE."
+ (let* ((soap-current-wsdl wsdl)
+ (op (soap-bound-operation-operation operation))
+ (use (soap-bound-operation-use operation))
+ (message (cdr (soap-operation-output op))))
+
+ (soap-with-local-xmlns response-node
+
+ (when (eq use 'encoded)
+ (let* ((received-message-name (soap-l2fq (xml-node-name response-node)))
+ (received-message (soap-wsdl-get
+ received-message-name wsdl 'soap-message-p)))
+ (unless (eq received-message message)
+ (error "Unexpected message: got %s, expecting %s"
+ received-message-name
+ (soap-element-name message)))))
+
+ (let ((decoded-parts nil)
+ (soap-multi-refs (xml-get-children soap-body 'multiRef))
+ (soap-decoded-multi-refs nil))
+
+ (dolist (part (soap-message-parts message))
+ (let ((tag (car part))
+ (type (cdr part))
+ node)
+
+ (setq node
+ (cond
+ ((eq use 'encoded)
+ (car (xml-get-children response-node tag)))
+
+ ((eq use 'literal)
+ (catch 'found
+ (let* ((ns-aliases (soap-wsdl-alias-table wsdl))
+ (ns-name (cdr (assoc
+ (soap-element-namespace-tag type)
+ ns-aliases)))
+ (fqname (cons ns-name (soap-element-name type))))
+ (dolist (c (xml-node-children response-node))
+ (when (consp c)
+ (soap-with-local-xmlns c
+ (when (equal (soap-l2fq (xml-node-name c))
+ fqname)
+ (throw 'found c))))))))))
+
+ (unless node
+ (error "Soap-parse-response(%s): cannot find message part %s"
+ (soap-element-name op) tag))
+ (push (soap-decode-type type node) decoded-parts)))
+
+ decoded-parts))))
+
+;;;; SOAP type encoding
+
+(defvar soap-encoded-namespaces nil
+ "A list of namespace tags used during encoding a message.
+This list is populated by `soap-encode-value' and used by
+`soap-create-envelope' to add aliases for these namespace to the
+XML request.
+
+This variable is dynamically bound in `soap-create-envelope'.")
+
+(defun soap-encode-value (xml-tag value type)
+ "Encode inside an XML-TAG the VALUE using TYPE.
+The resulting XML data is inserted in the current buffer
+at (point)/
+
+TYPE is one of the soap-*-type structures which defines how VALUE
+is to be encoded. This is a generic function which finds an
+encoder function based on TYPE and calls that encoder to do the
+work."
+ (let ((encoder (get (aref type 0) 'soap-encoder)))
+ (assert encoder nil "no soap-encoder for %s type" (aref type 0))
+ ;; XML-TAG can be a string or a symbol, but we pass only string's to the
+ ;; encoders
+ (when (symbolp xml-tag)
+ (setq xml-tag (symbol-name xml-tag)))
+ (funcall encoder xml-tag value type))
+ (add-to-list 'soap-encoded-namespaces (soap-element-namespace-tag type)))
+
+(defun soap-encode-basic-type (xml-tag value type)
+ "Encode inside XML-TAG the LISP VALUE according to TYPE.
+Do not call this function directly, use `soap-encode-value'
+instead."
+ (let ((xsi-type (soap-element-fq-name type))
+ (basic-type (soap-basic-type-kind type)))
+
+ ;; try to classify the type based on the value type and use that type when
+ ;; encoding
+ (when (eq basic-type 'anyType)
+ (cond ((stringp value)
+ (setq xsi-type "xsd:string" basic-type 'string))
+ ((integerp value)
+ (setq xsi-type "xsd:int" basic-type 'int))
+ ((memq value '(t nil))
+ (setq xsi-type "xsd:boolean" basic-type 'boolean))
+ (t
+ (error
+ "Soap-encode-basic-type(%s, %s, %s): cannot classify anyType value"
+ xml-tag value xsi-type))))
+
+ (insert "<" xml-tag " xsi:type=\"" xsi-type "\"")
+
+ ;; We have some ambiguity here, as a nil value represents "false" when the
+ ;; type is boolean, we will never have a "nil" boolean type...
+
+ (if (or value (eq basic-type 'boolean))
+ (progn
+ (insert ">")
+ (case basic-type
+ (string
+ (unless (stringp value)
+ (error "Soap-encode-basic-type(%s, %s, %s): not a string value"
+ xml-tag value xsi-type))
+ (insert (url-insert-entities-in-string value)))
+
+ (dateTime
+ (cond ((and (consp value) ; is there a time-value-p ?
+ (>= (length value) 2)
+ (numberp (nth 0 value))
+ (numberp (nth 1 value)))
+ ;; Value is a (current-time) style value, convert
+ ;; to a string
+ (insert (format-time-string "%Y-%m-%dT%H:%M:%S" value)))
+ ((stringp value)
+ (insert (url-insert-entities-in-string value)))
+ (t
+ (error
+ "Soap-encode-basic-type(%s, %s, %s): not a dateTime value"
+ xml-tag value xsi-type))))
+
+ (boolean
+ (unless (memq value '(t nil))
+ (error "Soap-encode-basic-type(%s, %s, %s): not a boolean value"
+ xml-tag value xsi-type))
+ (insert (if value "true" "false")))
+
+ ((long int)
+ (unless (integerp value)
+ (error "Soap-encode-basic-type(%s, %s, %s): not an integer value"
+ xml-tag value xsi-type))
+ (insert (number-to-string value)))
+
+ (base64Binary
+ (unless (stringp value)
+ (error "Soap-encode-basic-type(%s, %s, %s): not a string value"
+ xml-tag value xsi-type))
+ (insert (base64-encode-string value)))
+
+ (otherwise
+ (error
+ "Soap-encode-basic-type(%s, %s, %s): don't know how to encode"
+ xml-tag value xsi-type))))
+
+ (insert " xsi:nil=\"true\">"))
+ (insert "</" xml-tag ">\n")))
+
+(defun soap-encode-sequence-type (xml-tag value type)
+ "Encode inside XML-TAG the LISP VALUE according to TYPE.
+Do not call this function directly, use `soap-encode-value'
+instead."
+ (let ((xsi-type (soap-element-fq-name type)))
+ (insert "<" xml-tag " xsi:type=\"" xsi-type "\"")
+ (if value
+ (progn
+ (insert ">\n")
+ (let ((parents (list type))
+ (parent (soap-sequence-type-parent type)))
+
+ (while parent
+ (push parent parents)
+ (setq parent (soap-sequence-type-parent parent)))
+
+ (dolist (type parents)
+ (dolist (element (soap-sequence-type-elements type))
+ (let ((instance-count 0)
+ (e-name (soap-sequence-element-name element))
+ (e-type (soap-sequence-element-type element)))
+ (dolist (v value)
+ (when (equal (car v) e-name)
+ (incf instance-count)
+ (soap-encode-value e-name (cdr v) e-type)))
+
+ ;; Do some sanity checking
+ (cond ((and (= instance-count 0)
+ (not (soap-sequence-element-nillable? element)))
+ (soap-warning
+ "While encoding %s: missing non-nillable slot %s"
+ (soap-element-name type) e-name))
+ ((and (> instance-count 1)
+ (not (soap-sequence-element-multiple? element)))
+ (soap-warning
+ "While encoding %s: multiple slots named %s"
+ (soap-element-name type) e-name))))))))
+ (insert " xsi:nil=\"true\">"))
+ (insert "</" xml-tag ">\n")))
+
+(defun soap-encode-array-type (xml-tag value type)
+ "Encode inside XML-TAG the LISP VALUE according to TYPE.
+Do not call this function directly, use `soap-encode-value'
+instead."
+ (unless (vectorp value)
+ (error "Soap-encode: %s(%s) expects a vector, got: %s"
+ xml-tag (soap-element-fq-name type) value))
+ (let* ((element-type (soap-array-type-element-type type))
+ (array-type (concat (soap-element-fq-name element-type)
+ "[" (format "%s" (length value)) "]")))
+ (insert "<" xml-tag
+ " soapenc:arrayType=\"" array-type "\" "
+ " xsi:type=\"soapenc:Array\">\n")
+ (loop for i below (length value)
+ do (soap-encode-value xml-tag (aref value i) element-type))
+ (insert "</" xml-tag ">\n")))
+
+(progn
+ (put (aref (make-soap-basic-type) 0)
+ 'soap-encoder 'soap-encode-basic-type)
+ (put (aref (make-soap-sequence-type) 0)
+ 'soap-encoder 'soap-encode-sequence-type)
+ (put (aref (make-soap-array-type) 0)
+ 'soap-encoder 'soap-encode-array-type))
+
+(defun soap-encode-body (operation parameters wsdl)
+ "Create the body of a SOAP request for OPERATION in the current buffer.
+PARAMETERS is a list of parameters supplied to the OPERATION.
+
+The OPERATION and PARAMETERS are encoded according to the WSDL
+document."
+ (let* ((op (soap-bound-operation-operation operation))
+ (use (soap-bound-operation-use operation))
+ (message (cdr (soap-operation-input op)))
+ (parameter-order (soap-operation-parameter-order op)))
+
+ (unless (= (length parameter-order) (length parameters))
+ (error "Wrong number of parameters for %s: expected %d, got %s"
+ (soap-element-name op)
+ (length parameter-order)
+ (length parameters)))
+
+ (insert "<soap:Body>\n")
+ (when (eq use 'encoded)
+ (add-to-list 'soap-encoded-namespaces (soap-element-namespace-tag op))
+ (insert "<" (soap-element-fq-name op) ">\n"))
+
+ (let ((param-table (loop for formal in parameter-order
+ for value in parameters
+ collect (cons formal value))))
+ (dolist (part (soap-message-parts message))
+ (let* ((param-name (car part))
+ (type (cdr part))
+ (tag-name (if (eq use 'encoded)
+ param-name
+ (soap-element-name type)))
+ (value (cdr (assoc param-name param-table)))
+ (start-pos (point)))
+ (soap-encode-value tag-name value type)
+ (when (eq use 'literal)
+ ;; hack: add the xmlns attribute to the tag, the only way
+ ;; ASP.NET web services recognize the namespace of the
+ ;; element itself...
+ (save-excursion
+ (goto-char start-pos)
+ (when (re-search-forward " ")
+ (let* ((ns (soap-element-namespace-tag type))
+ (namespace (cdr (assoc ns
+ (soap-wsdl-alias-table wsdl)))))
+ (when namespace
+ (insert "xmlns=\"" namespace "\" ")))))))))
+
+ (when (eq use 'encoded)
+ (insert "</" (soap-element-fq-name op) ">\n"))
+ (insert "</soap:Body>\n")))
+
+(defun soap-create-envelope (operation parameters wsdl)
+ "Create a SOAP request envelope for OPERATION using PARAMETERS.
+WSDL is the wsdl document used to encode the PARAMETERS."
+ (with-temp-buffer
+ (let ((soap-encoded-namespaces '("xsi" "soap" "soapenc"))
+ (use (soap-bound-operation-use operation)))
+
+ ;; Create the request body
+ (soap-encode-body operation parameters wsdl)
+
+ ;; Put the envelope around the body
+ (goto-char (point-min))
+ (insert "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<soap:Envelope\n")
+ (when (eq use 'encoded)
+ (insert " soapenc:encodingStyle=\"http://schemas.xmlsoap.org/soap/encoding/\"\n"))
+ (dolist (nstag soap-encoded-namespaces)
+ (insert " xmlns:" nstag "=\"")
+ (let ((nsname (cdr (assoc nstag soap-well-known-xmlns))))
+ (unless nsname
+ (setq nsname (cdr (assoc nstag (soap-wsdl-alias-table wsdl)))))
+ (insert nsname)
+ (insert "\"\n")))
+ (insert ">\n")
+ (goto-char (point-max))
+ (insert "</soap:Envelope>\n"))
+
+ (buffer-string)))
+
+;;;; invoking soap methods
+
+(defcustom soap-debug nil
+ "When t, enable some debugging facilities."
+ :type 'boolean
+ :group 'soap-client)
+
+(defun soap-invoke (wsdl service operation-name &rest parameters)
+ "Invoke a SOAP operation and return the result.
+
+WSDL is used for encoding the request and decoding the response.
+It also contains information about the WEB server address that
+will service the request.
+
+SERVICE is the SOAP service to invoke.
+
+OPERATION-NAME is the operation to invoke.
+
+PARAMETERS -- the remaining parameters are used as parameters for
+the SOAP request.
+
+NOTE: The SOAP service provider should document the available
+operations and their parameters for the service. You can also
+use the `soap-inspect' function to browse the available
+operations in a WSDL document."
+ (let ((port (catch 'found
+ (dolist (p (soap-wsdl-ports wsdl))
+ (when (equal service (soap-element-name p))
+ (throw 'found p))))))
+ (unless port
+ (error "Unknown SOAP service: %s" service))
+
+ (let* ((binding (soap-port-binding port))
+ (operation (gethash operation-name
+ (soap-binding-operations binding))))
+ (unless operation
+ (error "No operation %s for SOAP service %s" operation-name service))
+
+ (let ((url-request-method "POST")
+ (url-package-name "soap-client.el")
+ (url-package-version "1.0")
+ (url-http-version "1.0")
+ (url-request-data (soap-create-envelope operation parameters wsdl))
+ (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5")
+ (url-request-coding-system 'utf-8)
+ (url-http-attempt-keepalives t)
+ (url-request-extra-headers (list
+ (cons "SOAPAction"
+ (soap-bound-operation-soap-action
+ operation))
+ (cons "Content-Type"
+ "text/xml; charset=utf-8"))))
+ (let ((buffer (url-retrieve-synchronously
+ (soap-port-service-url port))))
+ (condition-case err
+ (with-current-buffer buffer
+ (declare (special url-http-response-status))
+ (if (null url-http-response-status)
+ (error "No HTTP response from server"))
+ (if (and soap-debug (> url-http-response-status 299))
+ ;; This is a warning because some SOAP errors come
+ ;; back with a HTTP response 500 (internal server
+ ;; error)
+ (warn "Error in SOAP response: HTTP code %s"
+ url-http-response-status))
+ (when (> (buffer-size) 1000000)
+ (soap-warning
+ "Received large message: %s bytes"
+ (buffer-size)))
+ (let ((mime-part (mm-dissect-buffer t t)))
+ (unless mime-part
+ (error "Failed to decode response from server"))
+ (unless (equal (car (mm-handle-type mime-part)) "text/xml")
+ (error "Server response is not an XML document"))
+ (with-temp-buffer
+ (mm-insert-part mime-part)
+ (let ((response (car (xml-parse-region
+ (point-min) (point-max)))))
+ (prog1
+ (soap-parse-envelope response operation wsdl)
+ (kill-buffer buffer)
+ (mm-destroy-part mime-part))))))
+ (soap-error
+ ;; Propagate soap-errors -- they are error replies of the
+ ;; SOAP protocol and don't indicate a communication
+ ;; problem or a bug in this code.
+ (signal (car err) (cdr err)))
+ (error
+ (when soap-debug
+ (pop-to-buffer buffer))
+ (error (error-message-string err)))))))))
+
+(provide 'soap-client)
+
+
+;;; Local Variables:
+;;; eval: (outline-minor-mode)
+;;; outline-regexp: ";;;;+"
+;;; End:
+
+;;; soap-client.el ends here
diff --git a/lisp/net/soap-inspect.el b/lisp/net/soap-inspect.el
new file mode 100644
index 00000000000..8f67d02dc6f
--- /dev/null
+++ b/lisp/net/soap-inspect.el
@@ -0,0 +1,358 @@
+;;;; soap-inspect.el -- Interactive inspector for soap WSDL structures
+
+;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
+
+;; Author: Alexandru Harsanyi <AlexHarsanyi@gmail.com>
+;; Created: October 2010
+;; Keywords: soap, web-services, comm, hypermedia
+;; Package: soap-client
+;; Homepage: http://code.google.com/p/emacs-soap-client
+
+;; 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 inspector for a WSDL document loaded with
+;; `soap-load-wsdl' or `soap-load-wsdl-from-url'. To use it, evaluate:
+;;
+;; (soap-inspect *wsdl*)
+;;
+;; This will pop-up the inspector buffer. You can click on ports, operations
+;; and types to explore the structure of the wsdl document.
+;;
+
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(require 'soap-client)
+
+;;; sample-value
+
+(defun soap-sample-value (type)
+ "Provide a sample value for TYPE, a WSDL type.
+A sample value is a LISP value which soap-client.el will accept
+for encoding it using TYPE when making SOAP requests.
+
+This is a generic function, depending on TYPE a specific function
+will be called."
+ (let ((sample-value (get (aref type 0) 'soap-sample-value)))
+ (if sample-value
+ (funcall sample-value type)
+ (error "Cannot provide sample value for type %s" (aref type 0)))))
+
+(defun soap-sample-value-for-basic-type (type)
+ "Provide a sample value for TYPE which is a basic type.
+This is a specific function which should not be called directly,
+use `soap-sample-value' instead."
+ (case (soap-basic-type-kind type)
+ (string "a string value")
+ (boolean t) ; could be nil as well
+ ((long int) (random 4200))
+ ;; TODO: we need better sample values for more types.
+ (t (format "%s" (soap-basic-type-kind type)))))
+
+(defun soap-sample-value-for-seqence-type (type)
+ "Provide a sample value for TYPE which is a sequence type.
+Values for sequence types are ALISTS of (slot-name . VALUE) for
+each sequence element.
+
+This is a specific function which should not be called directly,
+use `soap-sample-value' instead."
+ (let ((sample-value nil))
+ (dolist (element (soap-sequence-type-elements type))
+ (push (cons (soap-sequence-element-name element)
+ (soap-sample-value (soap-sequence-element-type element)))
+ sample-value))
+ (when (soap-sequence-type-parent type)
+ (setq sample-value
+ (append (soap-sample-value (soap-sequence-type-parent type))
+ sample-value)))
+ sample-value))
+
+(defun soap-sample-value-for-array-type (type)
+ "Provide a sample value for TYPE which is an array type.
+Values for array types are LISP vectors of values which are
+array's element type.
+
+This is a specific function which should not be called directly,
+use `soap-sample-value' instead."
+ (let* ((element-type (soap-array-type-element-type type))
+ (sample1 (soap-sample-value element-type))
+ (sample2 (soap-sample-value element-type)))
+ ;; Our sample value is a vector of two elements, but any number of
+ ;; elements are permissible
+ (vector sample1 sample2 '&etc)))
+
+(defun soap-sample-value-for-message (message)
+ "Provide a sample value for a WSDL MESSAGE.
+This is a specific function which should not be called directly,
+use `soap-sample-value' instead."
+ ;; NOTE: parameter order is not considered.
+ (let (sample-value)
+ (dolist (part (soap-message-parts message))
+ (push (cons (car part)
+ (soap-sample-value (cdr part)))
+ sample-value))
+ (nreverse sample-value)))
+
+(progn
+ ;; Install soap-sample-value methods for our types
+ (put (aref (make-soap-basic-type) 0) 'soap-sample-value
+ 'soap-sample-value-for-basic-type)
+
+ (put (aref (make-soap-sequence-type) 0) 'soap-sample-value
+ 'soap-sample-value-for-seqence-type)
+
+ (put (aref (make-soap-array-type) 0) 'soap-sample-value
+ 'soap-sample-value-for-array-type)
+
+ (put (aref (make-soap-message) 0) 'soap-sample-value
+ 'soap-sample-value-for-message) )
+
+
+
+;;; soap-inspect
+
+(defvar soap-inspect-previous-items nil
+ "A stack of previously inspected items in the *soap-inspect* buffer.
+Used to implement the BACK button.")
+
+(defvar soap-inspect-current-item nil
+ "The current item being inspected in the *soap-inspect* buffer.")
+
+(progn
+ (make-variable-buffer-local 'soap-inspect-previous-items)
+ (make-variable-buffer-local 'soap-inspect-current-item))
+
+(defun soap-inspect (element)
+ "Inspect a SOAP ELEMENT in the *soap-inspect* buffer.
+The buffer is populated with information about ELEMENT with links
+to its sub elements. If ELEMENT is the WSDL document itself, the
+entire WSDL can be inspected."
+ (let ((inspect (get (aref element 0) 'soap-inspect)))
+ (unless inspect
+ (error "Soap-inspect: no inspector for element"))
+
+ (with-current-buffer (get-buffer-create "*soap-inspect*")
+ (setq buffer-read-only t)
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+
+ (when soap-inspect-current-item
+ (push soap-inspect-current-item
+ soap-inspect-previous-items))
+ (setq soap-inspect-current-item element)
+
+ (funcall inspect element)
+
+ (unless (null soap-inspect-previous-items)
+ (insert "\n\n")
+ (insert-text-button
+ "[back]"
+ 'type 'soap-client-describe-back-link
+ 'item element)
+ (insert "\n"))
+ (goto-char (point-min))
+ (pop-to-buffer (current-buffer))))))
+
+
+(define-button-type 'soap-client-describe-link
+ 'face 'italic
+ 'help-echo "mouse-2, RET: describe item"
+ 'follow-link t
+ 'action (lambda (button)
+ (let ((item (button-get button 'item)))
+ (soap-inspect item)))
+ 'skip t)
+
+(define-button-type 'soap-client-describe-back-link
+ 'face 'italic
+ 'help-echo "mouse-2, RET: browse the previous item"
+ 'follow-link t
+ 'action (lambda (button)
+ (let ((item (pop soap-inspect-previous-items)))
+ (when item
+ (setq soap-inspect-current-item nil)
+ (soap-inspect item))))
+ 'skip t)
+
+(defun soap-insert-describe-button (element)
+ "Insert a button to inspect ELEMENT when pressed."
+ (insert-text-button
+ (soap-element-fq-name element)
+ 'type 'soap-client-describe-link
+ 'item element))
+
+(defun soap-inspect-basic-type (basic-type)
+ "Insert information about BASIC-TYPE into the current buffer."
+ (insert "Basic type: " (soap-element-fq-name basic-type))
+ (insert "\nSample value\n")
+ (pp (soap-sample-value basic-type) (current-buffer)))
+
+(defun soap-inspect-sequence-type (sequence)
+ "Insert information about SEQUENCE into the current buffer."
+ (insert "Sequence type: " (soap-element-fq-name sequence) "\n")
+ (when (soap-sequence-type-parent sequence)
+ (insert "Parent: ")
+ (soap-insert-describe-button
+ (soap-sequence-type-parent sequence))
+ (insert "\n"))
+ (insert "Elements: \n")
+ (dolist (element (soap-sequence-type-elements sequence))
+ (insert "\t" (symbol-name (soap-sequence-element-name element))
+ "\t")
+ (soap-insert-describe-button
+ (soap-sequence-element-type element))
+ (when (soap-sequence-element-multiple? element)
+ (insert " multiple"))
+ (when (soap-sequence-element-nillable? element)
+ (insert " optional"))
+ (insert "\n"))
+ (insert "Sample value:\n")
+ (pp (soap-sample-value sequence) (current-buffer)))
+
+(defun soap-inspect-array-type (array)
+ "Insert information about the ARRAY into the current buffer."
+ (insert "Array name: " (soap-element-fq-name array) "\n")
+ (insert "Element type: ")
+ (soap-insert-describe-button
+ (soap-array-type-element-type array))
+ (insert "\nSample value:\n")
+ (pp (soap-sample-value array) (current-buffer)))
+
+(defun soap-inspect-message (message)
+ "Insert information about MESSAGE into the current buffer."
+ (insert "Message name: " (soap-element-fq-name message) "\n")
+ (insert "Parts:\n")
+ (dolist (part (soap-message-parts message))
+ (insert "\t" (symbol-name (car part))
+ " type: ")
+ (soap-insert-describe-button (cdr part))
+ (insert "\n")))
+
+(defun soap-inspect-operation (operation)
+ "Insert information about OPERATION into the current buffer."
+ (insert "Operation name: " (soap-element-fq-name operation) "\n")
+ (let ((input (soap-operation-input operation)))
+ (insert "\tInput: " (symbol-name (car input)) " (" )
+ (soap-insert-describe-button (cdr input))
+ (insert ")\n"))
+ (let ((output (soap-operation-output operation)))
+ (insert "\tOutput: " (symbol-name (car output)) " (")
+ (soap-insert-describe-button (cdr output))
+ (insert ")\n"))
+
+ (insert "\n\nSample invocation:\n")
+ (let ((sample-message-value
+ (soap-sample-value (cdr (soap-operation-input operation))))
+ (funcall (list 'soap-invoke '*WSDL* "SomeService" (soap-element-name operation))))
+ (let ((sample-invocation
+ (append funcall (mapcar 'cdr sample-message-value))))
+ (pp sample-invocation (current-buffer)))))
+
+(defun soap-inspect-port-type (port-type)
+ "Insert information about PORT-TYPE into the current buffer."
+ (insert "Port-type name: " (soap-element-fq-name port-type) "\n")
+ (insert "Operations:\n")
+ (loop for o being the hash-values of
+ (soap-namespace-elements (soap-port-type-operations port-type))
+ do (progn
+ (insert "\t")
+ (soap-insert-describe-button (car o)))))
+
+(defun soap-inspect-binding (binding)
+ "Insert information about BINDING into the current buffer."
+ (insert "Binding: " (soap-element-fq-name binding) "\n")
+ (insert "\n")
+ (insert "Bound operations:\n")
+ (let* ((ophash (soap-binding-operations binding))
+ (operations (loop for o being the hash-keys of ophash
+ collect o))
+ op-name-width)
+
+ (setq operations (sort operations 'string<))
+
+ (setq op-name-width (loop for o in operations maximizing (length o)))
+
+ (dolist (op operations)
+ (let* ((bound-op (gethash op ophash))
+ (soap-action (soap-bound-operation-soap-action bound-op))
+ (use (soap-bound-operation-use bound-op)))
+ (unless soap-action
+ (setq soap-action ""))
+ (insert "\t")
+ (soap-insert-describe-button (soap-bound-operation-operation bound-op))
+ (when (or use (not (equal soap-action "")))
+ (insert (make-string (- op-name-width (length op)) ?\s))
+ (insert " (")
+ (insert soap-action)
+ (when use
+ (insert " " (symbol-name use)))
+ (insert ")"))
+ (insert "\n")))))
+
+(defun soap-inspect-port (port)
+ "Insert information about PORT into the current buffer."
+ (insert "Port name: " (soap-element-name port) "\n"
+ "Service URL: " (soap-port-service-url port) "\n"
+ "Binding: ")
+ (soap-insert-describe-button (soap-port-binding port)))
+
+(defun soap-inspect-wsdl (wsdl)
+ "Insert information about WSDL into the current buffer."
+ (insert "WSDL Origin: " (soap-wsdl-origin wsdl) "\n")
+ (insert "Ports:")
+ (dolist (p (soap-wsdl-ports wsdl))
+ (insert "\n--------------------\n")
+ ;; (soap-insert-describe-button p)
+ (soap-inspect-port p))
+ (insert "\n--------------------\nNamespace alias table:\n")
+ (dolist (a (soap-wsdl-alias-table wsdl))
+ (insert "\t" (car a) " => " (cdr a) "\n")))
+
+(progn
+ ;; Install the soap-inspect methods for our types
+
+ (put (aref (make-soap-basic-type) 0) 'soap-inspect
+ 'soap-inspect-basic-type)
+
+ (put (aref (make-soap-sequence-type) 0) 'soap-inspect
+ 'soap-inspect-sequence-type)
+
+ (put (aref (make-soap-array-type) 0) 'soap-inspect
+ 'soap-inspect-array-type)
+
+ (put (aref (make-soap-message) 0) 'soap-inspect
+ 'soap-inspect-message)
+ (put (aref (make-soap-operation) 0) 'soap-inspect
+ 'soap-inspect-operation)
+
+ (put (aref (make-soap-port-type) 0) 'soap-inspect
+ 'soap-inspect-port-type)
+
+ (put (aref (make-soap-binding) 0) 'soap-inspect
+ 'soap-inspect-binding)
+
+ (put (aref (make-soap-port) 0) 'soap-inspect
+ 'soap-inspect-port)
+
+ (put (aref (make-soap-wsdl) 0) 'soap-inspect
+ 'soap-inspect-wsdl))
+
+(provide 'soap-inspect)
+;;; soap-inspect.el ends here
diff --git a/lisp/net/socks.el b/lisp/net/socks.el
index 420d9d19775..d792077d861 100644
--- a/lisp/net/socks.el
+++ b/lisp/net/socks.el
@@ -1,7 +1,6 @@
;;; socks.el --- A Socks v5 Client for Emacs
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2002,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2000, 2002, 2007-2011 Free Software Foundation, Inc.
;; Author: William M. Perry <wmperry@gnu.org>
;; Dave Love <fx@gnu.org>
@@ -646,5 +645,4 @@ version.")
(provide 'socks)
-;; arch-tag: 67aef0d9-f4f7-4056-89c3-b4c9bf93ce7f
;;; socks.el ends here
diff --git a/lisp/net/telnet.el b/lisp/net/telnet.el
index a9c997c4341..d4850fed345 100644
--- a/lisp/net/telnet.el
+++ b/lisp/net/telnet.el
@@ -1,7 +1,7 @@
;;; telnet.el --- run a telnet session from within an Emacs buffer
-;; Copyright (C) 1985, 1988, 1992, 1994, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1988, 1992, 1994, 2001-2011
+;; Free Software Foundation, Inc.
;; Author: William F. Schelter
;; Maintainer: FSF
@@ -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."
@@ -265,5 +263,4 @@ Normally input is edited in Emacs and sent a line at a time."
(provide 'telnet)
-;; arch-tag: 98218821-d04a-48b6-9058-57d0d4677a56
;;; telnet.el ends here
diff --git a/lisp/net/tls.el b/lisp/net/tls.el
index 57c295b3672..42ae5920eee 100644
--- a/lisp/net/tls.el
+++ b/lisp/net/tls.el
@@ -1,7 +1,6 @@
;;; tls.el --- TLS/SSL support via wrapper around GnuTLS
-;; Copyright (C) 1996, 1997, 1998, 1999, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1999, 2002-2011 Free Software Foundation, Inc.
;; Author: Simon Josefsson <simon@josefsson.org>
;; Keywords: comm, tls, gnutls, ssl
@@ -75,8 +74,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 +237,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 +301,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 3b0e93e5c92..f8bc594e959 100644
--- a/lisp/net/tramp-cache.el
+++ b/lisp/net/tramp-cache.el
@@ -1,11 +1,11 @@
;;; tramp-cache.el --- file information caching for Tramp
-;; Copyright (C) 2000, 2005, 2006, 2007, 2008, 2009,
-;; 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000, 2005-2011 Free Software Foundation, Inc.
;; 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.
@@ -33,7 +33,7 @@
;; - localname is NIL. This are reusable properties. Examples:
;; "remote-shell" identifies the POSIX shell to be called on the
;; remote host, or "perl" is the command to be called on the remote
-;; host, when starting a Perl script. These properties are saved in
+;; host when starting a Perl script. These properties are saved in
;; the file `tramp-persistency-file-name'.
;;
;; - localname is a string. This are temporary properties, which are
@@ -49,37 +49,20 @@
;;; 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.
+ ((and (fboundp 'locate-user-emacs-file))
+ (expand-file-name (tramp-compat-funcall 'locate-user-emacs-file "tramp")))
((and (boundp 'user-emacs-directory)
(stringp (symbol-value 'user-emacs-directory))
(file-directory-p (symbol-value 'user-emacs-directory)))
@@ -102,6 +85,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 +98,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 +132,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 +168,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 +192,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 +209,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 +226,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 +241,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 +283,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 +304,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,48 +318,49 @@ 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)))
-
-(add-hook 'kill-emacs-hook 'tramp-dump-connection-properties)
+ (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))))))
+
+(unless noninteractive
+ (add-hook 'kill-emacs-hook 'tramp-dump-connection-properties))
(add-hook 'tramp-cache-unload-hook
'(lambda ()
(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,7 +399,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
;;; tramp-cache.el ends here
diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el
index 97f875f2cff..58f1e2c6a9e 100644
--- a/lisp/net/tramp-cmds.el
+++ b/lisp/net/tramp-cmds.el
@@ -1,9 +1,10 @@
;;; tramp-cmds.el --- Interactive commands for Tramp
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; 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.
@@ -317,6 +281,12 @@ Used for non-7bit chars in strings."
(insert ")\n"))
(insert-buffer-substring elbuf)))
+ ;; Dump load-path shadows.
+ (insert "\nload-path shadows:\n==================\n")
+ (ignore-errors
+ (mapc (lambda (x) (when (string-match "tramp" x) (insert x "\n")))
+ (split-string (list-load-path-shadows t) "\n")))
+
;; Append buffers only when we are in message mode.
(when (and
(eq major-mode 'message-mode)
@@ -334,8 +304,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 +355,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,16 +366,8 @@ 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'
-;; I'm presented with a mismatch and raw lisp for a value. It is my
-;; understanding that a variable declared with defcustom is a User
-;; 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)
-
-;; 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 beb380d5e6f..3c0642c3c78 100644
--- a/lisp/net/tramp-compat.el
+++ b/lisp/net/tramp-compat.el
@@ -1,9 +1,10 @@
;;; tramp-compat.el --- Tramp compatibility functions
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; 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.
@@ -156,7 +156,7 @@
'set-file-times filename time)))))
;; We currently use "[" and "]" in the filename format for IPv6
- ;; hosts of GNU Emacs. This means, that Emacs wants to expand
+ ;; hosts of GNU Emacs. This means that Emacs wants to expand
;; wildcards if `find-file-wildcards' is non-nil, and then barfs
;; because no expansion could be found. We detect this situation
;; and do something really awful: we have `file-expand-wildcards'
@@ -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)
@@ -450,9 +476,38 @@ This is the last value stored with `(process-put PROCESS PROPNAME 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 ea0548a8174..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, 2011 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 e8e06bb38f8..f048208ea41 100644
--- a/lisp/net/tramp-ftp.el
+++ b/lisp/net/tramp-ftp.el
@@ -1,10 +1,10 @@
;;; tramp-ftp.el --- Tramp convenience functions for Ange-FTP
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, processes
+;; Package: tramp
;; This file is part of GNU Emacs.
@@ -29,7 +29,6 @@
;;; Code:
(require 'tramp)
-(autoload 'tramp-set-connection-property "tramp-cache")
(eval-when-compile
@@ -98,19 +97,20 @@ 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
- (list "\\`ftp\\." "" tramp-ftp-method))
-(add-to-list 'tramp-default-method-alist
- (list "" "\\`\\(anonymous\\|ftp\\)\\'" tramp-ftp-method))
+ ;; Add some defaults for `tramp-default-method-alist'.
+ (add-to-list 'tramp-default-method-alist
+ (list "\\`ftp\\." nil tramp-ftp-method))
+ (add-to-list 'tramp-default-method-alist
+ (list nil "\\`\\(anonymous\\|ftp\\)\\'" tramp-ftp-method)))
;; Add completion function for FTP method.
(tramp-set-completion-function
@@ -128,6 +128,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 +199,25 @@ 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 2707c62d82f..b3278dc312d 100644
--- a/lisp/net/tramp-gvfs.el
+++ b/lisp/net/tramp-gvfs.el
@@ -1,9 +1,10 @@
;;; tramp-gvfs.el --- Tramp access functions for GVFS daemon
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
;; 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
@@ -121,8 +124,8 @@
;; Add a default for `tramp-default-user-alist'. Rule: For the SYNCE
;; method, no user is chosen.
-(add-to-list 'tramp-default-user-alist
- '("synce" nil nil))
+;;;###tramp-autoload
+(add-to-list 'tramp-default-user-alist '("\\`synce\\'" nil nil))
(defcustom tramp-gvfs-zeroconf-domain "local"
"*Zeroconf domain to be used for discovering services, like host names."
@@ -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 preceding 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))
@@ -1197,14 +1212,14 @@ connection if a previous connection has died for some reason."
;; Enable auth-sorce and password-cache.
(tramp-set-connection-property vec "first-password-request" t)
- ;; There will be a callback of "askPassword", when a password is
+ ;; There will be a callback of "askPassword" when a password is
;; needed.
(dbus-register-method
:session dbus-service-emacs object-path
tramp-gvfs-interface-mountoperation "askPassword"
'tramp-gvfs-handler-askpassword)
- ;; There could be a callback of "askQuestion", when adding fingerprint.
+ ;; There could be a callback of "askQuestion" when adding fingerprint.
(dbus-register-method
:session dbus-service-emacs object-path
tramp-gvfs-interface-mountoperation "askQuestion"
@@ -1402,16 +1417,19 @@ 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:
;; * Host name completion via smb-server or smb-network.
-;; * Check, how two shares of the same SMB server can be mounted in
+;; * Check how two shares of the same SMB server can be mounted in
;; parallel.
;; * Apply SDP on bluetooth devices, in order to filter out obex
;; capability.
;; * Implement obex for other serial communication but bluetooth.
-;; arch-tag: f7f660ce-77f4-4132-9663-f5c25a47f7ed
;;; tramp-gvfs.el ends here
diff --git a/lisp/net/tramp-gw.el b/lisp/net/tramp-gw.el
index 2b01b91e9ac..70b70004de9 100644
--- a/lisp/net/tramp-gw.el
+++ b/lisp/net/tramp-gw.el
@@ -1,9 +1,10 @@
;;; tramp-gw.el --- Tramp utility functions for HTTP tunnels and SOCKS gateways
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, processes
+;; Package: tramp
;; This file is part of GNU Emacs.
@@ -37,38 +38,47 @@
(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
(when (featurep 'xemacs)
(byte-compiler-options (warnings (- unused-vars)))))
+;; We don't add the following methods to `tramp-methods', in order to
+;; exclude them from file name completion.
+
;; 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)))
-(add-to-list 'tramp-default-user-alist
- `(,tramp-gw-socks-method nil ,(user-login-name)))
+;;;###tramp-autoload
+(add-to-list
+ 'tramp-default-user-alist
+ (list (concat "\\`"
+ (regexp-opt (list tramp-gw-tunnel-method tramp-gw-socks-method))
+ "\\'")
+ nil (user-login-name)))
;; Internal file name functions and variables.
@@ -103,7 +113,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 +134,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 +160,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))))
@@ -189,12 +200,12 @@ instead of the host name declared in TARGET-VEC."
(setq tramp-gw-gw-proc
(funcall
socks-function
- (tramp-buffer-name gw-vec)
- (tramp-get-buffer gw-vec)
+ (tramp-get-connection-name gw-vec)
+ (tramp-get-connection-buffer gw-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 +236,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 +249,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 +319,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)
@@ -317,5 +330,4 @@ password in password cache. This is done for the first try only."
;; * Provide descriptive Commentary.
;; * Enable it for several gateway processes in parallel.
-;; arch-tag: 277e3a81-fdee-40cf-9e6b-59626292a5e0
;;; tramp-gw.el ends here
diff --git a/lisp/net/tramp-imap.el b/lisp/net/tramp-imap.el
deleted file mode 100644
index a5ca8a7bb54..00000000000
--- a/lisp/net/tramp-imap.el
+++ /dev/null
@@ -1,860 +0,0 @@
-;;; tramp-imap.el --- Tramp interface to IMAP through imap.el
-
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
-
-;; Author: Teodor Zlatanov <tzz@lifelogs.com>
-;; Keywords: mail, comm
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 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:
-
-;; Package to provide Tramp over IMAP
-
-;;; Setup:
-
-;; just load and open files, e.g.
-;; /imaps:user@yourhosthere.com:/INBOX.test/1
-;; or
-;; /imap:user@yourhosthere.com:/INBOX.test/1
-
-;; where `imap' goes over IMAP, while `imaps' goes over IMAP+SSL
-
-;; This module will use imap-hash.el to access the IMAP mailbox.
-
-;; This module will use auth-source.el to authenticate against the
-;; IMAP server, PLUS it will use auth-source.el to get your passphrase
-;; for the symmetrically encrypted messages. For the former, use the
-;; usual IMAP ports. For the latter, use the port "tramp-imap".
-
-;; example .authinfo / .netrc file:
-
-;; machine yourhosthere.com port tramp-imap login USER password SYMMETRIC-PASSPHRASE
-
-;; note above is the symmetric encryption passphrase for GPG
-;; below is the regular password for IMAP itself and other things on that host
-
-;; machine yourhosthere.com login USER password NORMAL-PASSWORD
-
-
-;;; Code:
-
-(require 'assoc)
-(require 'tramp)
-(require 'tramp-compat)
-
-(autoload 'auth-source-user-or-password "auth-source")
-(autoload 'epg-context-operation "epg")
-(autoload 'epg-context-set-armor "epg")
-(autoload 'epg-context-set-passphrase-callback "epg")
-(autoload 'epg-context-set-progress-callback "epg")
-(autoload 'epg-decrypt-string "epg")
-(autoload 'epg-encrypt-string "epg")
-(autoload 'epg-make-context "epg")
-(autoload 'imap-hash-get "imap-hash")
-(autoload 'imap-hash-make "imap-hash")
-(autoload 'imap-hash-map "imap-hash")
-(autoload 'imap-hash-put "imap-hash")
-(autoload 'imap-hash-rem "imap-hash")
-
-;; We use the additional header "X-Size" for encoding the size of a file.
-(eval-after-load "imap-hash"
- '(add-to-list 'imap-hash-headers 'X-Size 'append))
-
-;; Define Tramp IMAP method ...
-(defconst tramp-imap-method "imap"
- "*Method to connect via IMAP protocol.")
-
-(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 ...
-(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)))
-
-;; Add a default for `tramp-default-user-alist'. Default is the local user.
-(add-to-list 'tramp-default-user-alist
- `(,tramp-imaps-method nil ,(user-login-name)))
-
-;; Add completion function for IMAP method.
-;; (tramp-set-completion-function
-;; tramp-imap-method tramp-completion-function-alist-ssh) ; TODO: test this
-;; tramp-imaps-method tramp-completion-function-alist-ssh) ; TODO: test this
-
-;; New handlers should be added here.
-(defconst tramp-imap-file-name-handler-alist
- '(
- ;; `access-file' performed by default handler
- (add-name-to-file . ignore)
- ;; `byte-compiler-base-file-name' performed by default handler
- ;; `copy-directory' performed by default handler
- (copy-file . tramp-imap-handle-copy-file)
- (delete-directory . ignore) ;; tramp-imap-handle-delete-directory)
- (delete-file . tramp-imap-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-imap-handle-directory-files-and-attributes)
- (dired-call-process . ignore)
- ;; `dired-compress-file' performed by default handler
- ;; `dired-uncache' performed by default handler
- (expand-file-name . tramp-imap-handle-expand-file-name)
- ;; `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-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)
- (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-imap-handle-file-newer-than-file-p)
- (file-ownership-preserved-p . ignore)
- (file-readable-p . tramp-imap-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-imap-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-imap-handle-insert-directory)
- (insert-file-contents . tramp-imap-handle-insert-file-contents)
- (load . tramp-handle-load)
- (make-directory . ignore) ;; tramp-imap-handle-make-directory)
- (make-directory-internal . ignore) ;; tramp-imap-handle-make-directory-internal)
- (make-symbolic-link . ignore)
- (rename-file . tramp-imap-handle-rename-file)
- (set-file-modes . ignore)
- ;; `set-file-selinux-context' performed by default handler.
- (set-file-times . ignore) ;; tramp-imap-handle-set-file-times)
- (set-visited-file-modtime . ignore)
- (shell-command . ignore)
- (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-imap-handle-write-region)
- (executable-find . ignore)
- (start-file-process . ignore)
- (process-file . ignore)
-)
- "Alist of handler functions for Tramp IMAP method.
-Operations not mentioned here will be handled by the default Emacs primitives.")
-
-(defgroup tramp-imap nil
- "Tramp over IMAP configuration."
- :version "23.2"
- :group 'tramp)
-
-(defcustom tramp-imap-subject-marker "tramp-imap-subject-marker"
- "The subject marker that Tramp-IMAP will use."
- :type 'string
- :version "23.2"
- :group 'tramp-imap)
-
-;; TODO: these will be defcustoms later.
-(defvar tramp-imap-passphrase-cache nil) ;; can be t or 'never
-(defvar tramp-imap-passphrase nil)
-
-(defun 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))))
-
-(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
-pass to the OPERATION."
- (let ((fn (assoc operation tramp-imap-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-imap-file-name-p 'tramp-imap-file-name-handler))
-
-(defun tramp-imap-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-imap-do-copy-or-rename-file
- 'copy filename newname ok-if-already-exists keep-date preserve-uid-gid))
-
-(defun tramp-imap-handle-rename-file
- (filename newname &optional ok-if-already-exists)
- "Like `rename-file' for Tramp files."
- (tramp-imap-do-copy-or-rename-file
- 'rename filename newname ok-if-already-exists t t))
-
-(defun tramp-imap-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. PRESERVE-UID-GID, when non-nil, instructs to keep
-the uid and gid if both files are on the same host.
-
-This function is invoked by `tramp-imap-handle-copy-file' and
-`tramp-imap-handle-rename-file'. It is an error if OP is neither
-of `copy' and `rename'."
- (unless (memq op '(copy rename))
- (error "Unknown operation `%s', must be `copy' or `rename'" op))
- (setq filename (expand-file-name filename))
- (setq newname (expand-file-name newname))
- (when (file-directory-p newname)
- (setq newname (expand-file-name (file-name-nondirectory filename) newname)))
-
- (let ((t1 (and (tramp-tramp-file-p filename)
- (tramp-imap-file-name-p filename)))
- (t2 (and (tramp-tramp-file-p newname)
- (tramp-imap-file-name-p newname))))
-
- (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)
-
- ;; We just make a local copy of FILENAME, and write it then to
- ;; NEWNAME. This must be optimized, when both files are
- ;; located on the same IMAP server.
- (with-temp-buffer
- (if (and t1 t2)
- ;; We don't encrypt.
- (with-parsed-tramp-file-name newname v1
- (insert (tramp-imap-get-file filename nil))
- (tramp-imap-put-file
- v1 (current-buffer)
- (tramp-imap-file-name-name v1)
- nil nil (nth 7 (file-attributes filename))))
- ;; One of them is not located on a IMAP mailbox.
- (insert-file-contents filename)
- (write-region (point-min) (point-max) newname)))))
-
- (when (eq op 'rename) (delete-file filename))))
-
-;; TODO: revise this much
-(defun tramp-imap-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)))
- ;; There might be a double slash, for example when "~/"
- ;; expands to "/". Remove this.
- (while (string-match "//" localname)
- (setq localname (replace-match "/" t t localname)))
- ;; 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 ((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))))))))
-
-;; This function should return "foo/" for directories and "bar" for
-;; files.
-(defun tramp-imap-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
- (save-match-data
- (let ((entries
- (tramp-imap-get-file-entries v localname)))
- (mapcar
- (lambda (x)
- (list
- (if (string-match "d" (nth 9 x))
- (file-name-as-directory (nth 0 x))
- (nth 0 x))))
- entries))))))
-
-(defun tramp-imap-get-file-entries (vec localname &optional exact)
- "Read entries returned by IMAP server. EXACT limits to exact matches.
-Result is a list of (LOCALNAME LINK COUNT UID GID ATIME MTIME CTIME
-SIZE MODE WEIRD INODE DEVICE)."
- (tramp-message vec 5 "working on %s" localname)
- (let* ((name (tramp-imap-file-name-name vec))
- (search-name (or name ""))
- (search-name (if exact (concat search-name "$") search-name))
- (iht (tramp-imap-make-iht vec search-name)))
-;; TODO: catch errors
- ;; (tramp-error vec 'none "bad name %s or mailbox %s" name mbox))
- (imap-hash-map (lambda (uid headers body)
- (let ((subject (substring
- (aget headers 'Subject "")
- (length tramp-imap-subject-marker)))
- (from (aget headers 'From ""))
- (date (date-to-time (aget headers 'Date "")))
- (size (string-to-number
- (or (aget headers 'X-Size "0") "0"))))
- (setq from
- (if (string-match "<\\([^@]+\\)@" from)
- (match-string 1 from)
- "nobody"))
- (list
- subject
- nil
- -1
- from
- "nogroup"
- date
- date
- date
- size
- "-rw-rw-rw-"
- nil
- uid
- (tramp-get-device vec))))
- iht t)))
-
-(defun tramp-imap-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)
- (let* ((old-buffer (current-buffer))
- (inode (tramp-imap-get-file-inode filename))
- (min 1)
- (max (point-max))
- ;; Make sure we have good start and end values.
- (start (or start min))
- (end (or end max))
- temp-buffer)
- (with-temp-buffer
- (setq temp-buffer (if (and (eq start min) (eq end max))
- old-buffer
- ;; If this is a region write, insert the substring.
- (insert
- (with-current-buffer old-buffer
- (buffer-substring-no-properties start end)))
- (current-buffer)))
- (tramp-imap-put-file v
- temp-buffer
- (tramp-imap-file-name-name v)
- inode
- t)))
- (when (eq visit t)
- (set-visited-file-modtime))))
-
-(defun tramp-imap-handle-insert-directory
- (filename switches &optional wildcard full-directory-p)
- "Like `insert-directory' for Tramp files."
- (setq filename (expand-file-name filename))
- (if full-directory-p
- ;; Called from `dired-add-entry'.
- (setq filename (file-name-as-directory filename))
- (setq filename (directory-file-name filename)))
- (with-parsed-tramp-file-name filename nil
- (save-match-data
- (let ((base (file-name-nondirectory localname))
- (entries (copy-sequence
- (tramp-imap-get-file-entries
- v (file-name-directory localname)))))
-
- (when wildcard
- (when (string-match "\\." base)
- (setq base (replace-match "\\\\." nil nil base)))
- (when (string-match "\\*" base)
- (setq base (replace-match ".*" nil nil base)))
- (when (string-match "\\?" base)
- (setq base (replace-match ".?" nil nil base))))
-
- ;; Filter entries.
- (setq entries
- (delq
- nil
- (if (or wildcard (zerop (length base)))
- ;; Check for matching entries.
- (mapcar
- (lambda (x)
- (when (string-match
- (format "^%s" base) (nth 0 x))
- x))
- entries)
- ;; We just need the only and only entry FILENAME.
- (list (assoc base entries)))))
-
- ;; 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))))))
-
- ;; Handle "-F" switch.
- (when (string-match "F" switches)
- (mapc
- (lambda (x)
- (when (not (zerop (length (car x))))
- (cond
- ((char-equal ?d (string-to-char (nth 9 x)))
- (setcar x (concat (car x) "/")))
- ((char-equal ?x (string-to-char (nth 9 x)))
- (setcar x (concat (car x) "*"))))))
- entries))
-
- ;; Print entries.
- (mapcar
- (lambda (x)
- (when (not (zerop (length (nth 0 x))))
- (insert
- (format
- "%10s %3d %-8s %-8s %8s %s "
- (nth 9 x) ; mode
- (nth 11 x) ; inode
- (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
- ;; For the file name, we set the `dired-filename'
- ;; property. This allows to handle file names with
- ;; leading or trailing spaces as well. The inserted name
- ;; could be from somewhere else, so we use the relative
- ;; file name of `default-directory'.
- (let ((pos (point)))
- (insert
- (format
- "%s\n"
- (file-relative-name
- (expand-file-name (nth 0 x) (file-name-directory filename)))))
- (put-text-property pos (1- (point)) 'dired-filename t))
- (forward-line)
- (beginning-of-line)))
- entries)))))
-
-(defun tramp-imap-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 data)
- (with-progress-reporter v 3 (format "Fetching file %s" filename)
- (insert (tramp-imap-get-file filename t))
- (setq size (- (point) point))
-;;; TODO: handle ranges.
-;;; (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-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.
- (with-parsed-tramp-file-name (expand-file-name filename default-directory) nil
- (and (string-match "^/[^/]*$" (directory-file-name localname)) t)))
-
-(defun tramp-imap-handle-file-attributes (filename &optional id-format)
- "Like `file-attributes' for Tramp-IMAP FILENAME."
- (with-parsed-tramp-file-name (expand-file-name filename) nil
- (let ((res (cdr-safe (nth 0 (tramp-imap-get-file-entries v localname)))))
- (unless (or (null res) (eq id-format 'string))
- (setcar (nthcdr 2 res) 1)
- (setcar (nthcdr 3 res) 1))
- res)))
-
-(defun tramp-imap-get-file-inode (filename &optional id-format)
- "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.
- ;; (file-exists-p (file-name-directory filename)))
- (file-directory-p (file-name-directory filename)))
-
-(defun tramp-imap-handle-delete-file (filename &optional trash)
- "Like `delete-file' for Tramp files."
- (cond
- ((not (file-exists-p filename)) nil)
- (t (with-parsed-tramp-file-name (expand-file-name filename) nil
- (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
- (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)
- (with-temp-buffer
- (insert-file-contents filename)
- (write-region (point-min) (point-max) tmpfile)
- tmpfile)))))
-
-(defun tramp-imap-put-file
- (vec filename-or-buffer &optional subject inode encode size)
- "Write contents of FILENAME-OR-BUFFER to Tramp-IMAP file VEC with name SUBJECT.
-When INODE is given, delete that old remote file after writing the new one
-\(normally this is the old file with the same name). A non-nil ENCODE
-forces the encoding of the buffer or file. SIZE, when available, indicates
-the file size; this is needed, if the file or buffer is already encoded."
- ;; `tramp-current-host' is used in `tramp-imap-passphrase-callback-function'.
- (let ((tramp-current-host (tramp-file-name-real-host vec))
- (iht (tramp-imap-make-iht vec)))
- (imap-hash-put (list
- (list (cons
- 'Subject
- (format
- "%s%s"
- tramp-imap-subject-marker
- (or subject "no subject")))
- (cons
- 'X-Size
- (number-to-string
- (cond
- ((numberp size) size)
- ((bufferp filename-or-buffer)
- (buffer-size filename-or-buffer))
- ((stringp filename-or-buffer)
- (nth 7 (file-attributes filename-or-buffer)))
- ;; We don't know the size.
- (t -1)))))
- (cond ((bufferp filename-or-buffer)
- (with-current-buffer filename-or-buffer
- (if encode
- (tramp-imap-encode-buffer)
- (buffer-string))))
- ;; TODO: allow file names.
- (t "No body available")))
- iht
- inode)))
-
-(defun tramp-imap-get-file (filename &optional decode)
- ;; (debug (tramp-imap-get-file-inode filename))
- (with-parsed-tramp-file-name (expand-file-name filename) nil
- (condition-case ()
- ;; `tramp-current-host' is used in
- ;; `tramp-imap-passphrase-callback-function'.
- (let* ((tramp-current-host (tramp-file-name-real-host v))
- (iht (tramp-imap-make-iht v))
- (inode (tramp-imap-get-file-inode filename))
- (data (imap-hash-get inode iht t)))
- (if decode
- (with-temp-buffer
- (insert (nth 1 data))
- ;;(debug inode (buffer-string))
- (tramp-imap-decode-buffer))
- (nth 1 data)))
- (error (tramp-error
- v 'file-error "File `%s' could not be read" filename)))))
-
-(defun tramp-imap-passphrase-callback-function (context key-id handback)
- "Called by EPG to get a passphrase for Tramp-IMAP.
-CONTEXT is the encryption/decryption EPG context.
-HANDBACK is just carried through.
-KEY-ID can be 'SYM or 'PIN among others."
- (let* ((server tramp-current-host)
- (port "tramp-imap") ; this is NOT the server password!
- (auth-passwd
- (auth-source-user-or-password "password" server port)))
- (or
- (copy-sequence auth-passwd)
- ;; If we cache the passphrase and we have one.
- (if (and (eq tramp-imap-passphrase-cache t)
- tramp-imap-passphrase)
- ;; Do we reuse it?
- (if (y-or-n-p "Reuse the passphrase? ")
- (copy-sequence tramp-imap-passphrase)
- ;; Don't reuse: revert caching behavior to nil, erase passphrase,
- ;; call ourselves again.
- (setq tramp-imap-passphrase-cache nil)
- (setq tramp-imap-passphrase nil)
- (tramp-imap-passphrase-callback-function context key-id handback))
- (let ((p (if (eq key-id 'SYM)
- (read-passwd
- "Tramp-IMAP passphrase for symmetric encryption: "
- (eq (epg-context-operation context) 'encrypt)
- tramp-imap-passphrase)
- (read-passwd
- (if (eq key-id 'PIN)
- "Tramp-IMAP passphrase for PIN: "
- (let ((entry (assoc key-id
- (symbol-value 'epg-user-id-alist))))
- (if entry
- (format "Tramp-IMAP passphrase for %s %s: "
- key-id (cdr entry))
- (format "Tramp-IMAP passphrase for %s: " key-id))))
- nil
- tramp-imap-passphrase))))
-
- ;; If we have an answer, the passphrase has changed,
- ;; the user hasn't declined keeping the passphrase,
- ;; and they answer yes to keep it now...
- (when (and
- p
- (not (equal tramp-imap-passphrase p))
- (not (eq tramp-imap-passphrase-cache 'never))
- (y-or-n-p "Keep the passphrase? "))
- (setq tramp-imap-passphrase (copy-sequence p))
- (setq tramp-imap-passphrase-cache t))
-
- ;; If we still don't have a passphrase, the user didn't want
- ;; to keep it.
- (when (and
- p
- (not tramp-imap-passphrase))
- (setq tramp-imap-passphrase-cache 'never))
-
- p)))))
-
-(defun tramp-imap-encode-buffer ()
- (let ((context (epg-make-context 'OpenPGP))
- cipher)
- (epg-context-set-armor context t)
- (epg-context-set-passphrase-callback context
- #'tramp-imap-passphrase-callback-function)
- (epg-context-set-progress-callback context
- (cons #'epa-progress-callback-function
- "Encrypting..."))
- (message "Encrypting...")
- (setq cipher (epg-encrypt-string
- context
- (encode-coding-string (buffer-string) 'utf-8)
- nil))
- (message "Encrypting...done")
- cipher))
-
-(defun tramp-imap-decode-buffer ()
- (let ((context (epg-make-context 'OpenPGP))
- plain)
- (epg-context-set-passphrase-callback context
- #'tramp-imap-passphrase-callback-function)
- (epg-context-set-progress-callback context
- (cons #'epa-progress-callback-function
- "Decrypting..."))
- (message "Decrypting...")
- (setq plain (decode-coding-string
- (epg-decrypt-string context (buffer-string))
- 'utf-8))
- (message "Decrypting...done")
- plain))
-
-(defun tramp-imap-file-name-mailbox (vec)
- (nth 0 (tramp-imap-file-name-parse vec)))
-
-(defun tramp-imap-file-name-name (vec)
- (nth 1 (tramp-imap-file-name-parse vec)))
-
-(defun tramp-imap-file-name-localname (vec)
- (nth 1 (tramp-imap-file-name-parse vec)))
-
-(defun tramp-imap-file-name-parse (vec)
- (let ((name (substring-no-properties (tramp-file-name-localname vec))))
- (if (string-match "^/\\([^/]+\\)/?\\(.*\\)$" name)
- (list (match-string 1 name)
- (match-string 2 name))
- nil)))
-
-(defun tramp-imap-make-iht (vec &optional needed-subject)
- "Translate the Tramp vector VEC to the imap-hash structure.
-With NEEDED-SUBJECT, alters the imap-hash test accordingly."
- (let* ((mbox (tramp-imap-file-name-mailbox vec))
- (server (tramp-file-name-real-host vec))
- (method (tramp-file-name-method vec))
- (user (tramp-file-name-user vec))
- (ssl (string-equal method tramp-imaps-method))
- (port (or (tramp-file-name-port vec)
- (tramp-get-method-parameter method 'tramp-default-port)))
- (result (imap-hash-make server port mbox user nil ssl)))
- ;; Return the IHT with a test override to look for the subject
- ;; marker.
- (plist-put
- result
- :test (format "^%s%s"
- tramp-imap-subject-marker
- (if needed-subject needed-subject "")))))
-
-;;; TODO:
-
-;; * Implement `tramp-imap-handle-delete-directory',
-;; `tramp-imap-handle-make-directory',
-;; `tramp-imap-handle-make-directory-internal',
-;; `tramp-imap-handle-set-file-times'.
-
-;; * Encode the subject. If the filename has trailing spaces (like
-;; "test "), those characters get lost, for example in dired listings.
-
-;; * When opening a dired buffer, like "/imap::INBOX.test", there are
-;; several error messages:
-;; "Buffer has a running process; kill it? (yes or no) "
-;; "error in process filter: Internal error, tag 6 status BAD code nil text No mailbox selected."
-;; Afterwards, everything seems to be fine.
-
-;; * imaps works for local IMAP servers. Accessing
-;; "/imaps:imap.gmail.com:/INBOX.test/" results in error
-;; "error in process filter: Internal error, tag 5 status BAD code nil text UNSELECT not allowed now."
-
-;; * Improve `tramp-imap-handle-file-attributes' for directories.
-
-;; * Saving a file creates a second one, instead of overwriting.
-
-;; * Backup files: just *one* is kept.
-
-;; * Password requests shall have a descriptive prompt.
-
-;; * Exiting Emacs, there are running IMAP processes. Make them quiet
-;; by `set-process-query-on-exit-flag'.
-
-(provide 'tramp-imap)
-;;; tramp-imap.el ends here
-
-;; Ignore, for testing only.
-
-;;; (setq tramp-imap-subject-marker "T")
-;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/4") t)
-;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/") t)
-;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/test/4") t)
-;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/test/") t)
-;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/test/welcommen") t)
-;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/test/welcommen") t t)
-;;;(tramp-imap-get-file-inode "/imap:yourhosthere.com:/test/welcome")
-;;; (dired-copy-file "/etc/fstab" "/imap:yourhosthere.com:/test/welcome" t)
-;;; (write-region 1 100 "/imap:yourhosthere.com:/test/welcome")
-;;; (tramp-imap-get-file "/imap:yourhosthere.com:/test/welcome" t)
-;;(with-temp-buffer (insert "hello") (write-file "/imap:yourhosthere.com:/test/welcome"))
-;;(with-temp-buffer (insert "hello") (write-file "/imap:yourhosthere.com:/test/welcome2"))
-;;(file-writable-p "/imap:yourhosthere.com:/test/welcome2")
-;;(file-name-directory "/imap:yourhosthere.com:/test/welcome2")
-;;(with-temp-buffer (insert "hello") (delete-file "/tmp/hellotest") (write-file "/tmp/hellotest") (write-file "/imap:yourhosthere.com:/test/welcome2"))
-;;;(file-exists-p "/imap:yourhosthere.com:/INBOX.test/4")
-;;;(file-attributes "/imap:yourhosthere.com:/INBOX.test/4")
-;;;(setq vec (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/4"))
-;;;(tramp-imap-handle-file-attributes "/imap:yourhosthere.com:/INBOX.test/4")
-;;; (tramp-imap-handle-insert-file-contents "/imap:user@yourhosthere.com:/INBOX.test/4" nil nil nil nil)
-;;;(insert-file-contents "/imap:yourhosthere.com:/INBOX.test/4")
-;;;(file-attributes "/imap:yourhosthere.com:/test/welcommen")
-;;;(insert-file-contents "/imap:yourhosthere.com:/test/welcome")
-;;;(file-exists-p "/imap:yourhosthere.com:/test/welcome2")
-;;;(tramp-imap-handle-file-attributes "/imap:yourhosthere.com:/test/welcome")
-;;;(tramp-imap-get-file-inode "/imap:yourhosthere.com:/test/welcommen")
-;;;(tramp-imap-get-file-inode "/imap:yourhosthere.com:/test/welcome")
-;;;(file-writable-p "/imap:yourhosthere.com:/test/welcome2")
-;;; (delete-file "/imap:yourhosthere.com:/test/welcome")
-;;; (tramp-imap-get-file "/imap:yourhosthere.com:/test/welcommen" t)
-;;; (tramp-imap-get-file "/imap:yourhosthere.com:/test/welcome" t)
-;;;(tramp-imap-file-name-mailbox (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test"))
-;;;(tramp-imap-file-name-mailbox (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/new/old"))
-;;;(tramp-imap-file-name-mailbox (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/new"))
-;;;(tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/new/two"))
-;;;(tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/new/one"))
-;;;(tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test"))
-;;; (tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/test/4"))
-;;; (tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/test/"))
-;;; (tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/test/welcommen"))
-;;; (tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/test/welcommen"))
-;;; (tramp-imap-make-iht (tramp-dissect-file-name "/imap:yourhosthere.com:/test/welcommen"))
-;;; (tramp-imap-make-iht (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/4"))
-;;; (tramp-imap-make-iht (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/4") "extra")
-
-;; arch-tag: f2723749-58fb-4f29-894e-39708096e850
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
new file mode 100644
index 00000000000..cc404baef06
--- /dev/null
+++ b/lisp/net/tramp-sh.el
@@ -0,0 +1,5091 @@
+;;; tramp-sh.el --- Tramp access functions for (s)sh-like connections
+
+;; Copyright (C) 1998-2011 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") ("-r")
+ ("-o" "ControlPath=%t.%%r@%%h:%%p")
+ ("-o" "ControlMaster=auto")))
+ (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
+ '("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" "%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
+ '("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
+ '("ksu"
+ (tramp-login-program "ksu")
+ (tramp-login-args (("%u") ("-q")))
+ (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")
+ ("-q") ("-r")))
+ (tramp-copy-keep-date t)
+ (tramp-copy-recursive 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")
+ ("-q") ("-r")))
+ (tramp-copy-keep-date t)
+ (tramp-copy-recursive 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)))
+
+;;;###tramp-autoload
+(add-to-list 'tramp-default-method-alist
+ `(,tramp-local-host-regexp "\\`root\\'" "su"))
+
+;;;###tramp-autoload
+(add-to-list 'tramp-default-user-alist
+ `(,(concat "\\`" (regexp-opt '("su" "sudo" "ksu")) "\\'")
+ nil "root"))
+;; Do not add "ssh" based methods, otherwise ~/.ssh/config would be ignored.
+;;;###tramp-autoload
+(add-to-list 'tramp-default-user-alist
+ `(,(concat
+ "\\`"
+ (regexp-opt
+ '("rcp" "remcp" "rsh" "telnet" "krlogin"
+ "plink" "plink1" "pscp" "psftp" "fcp"))
+ "\\'")
+ 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 "ksu" 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. On remote hosts which
+do not offer the getconf command (like cygwin), the value
+\"/bin:/usr/bin\" is used instead of.
+
+`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, 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-2011 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-2011 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
+ (or
+ (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 nil))
+ ;; The scripts could fail, for example with huge file size.
+ (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 (file-truename 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 (file-truename 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))
+ (orig-vec (tramp-dissect-file-name (if t1 filename 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)))))
+
+ ;; 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))
+
+ ;; 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 host and port number. We cannot use
+ ;; `tramp-file-name-port', because this returns also
+ ;; `tramp-default-port', which might clash with settings in
+ ;; "~/.ssh/config".
+ (setq host (tramp-file-name-host v)
+ port "")
+ (when (string-match tramp-host-with-port-regexp host)
+ (setq port (string-to-number (match-string 2 host))
+ host (string-to-number (match-string 1 host))))
+
+ ;; 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
+ (delete
+ ;; " " has either been a replacement of "%k" (when
+ ;; keep-date argument is non-nil), or a replacement
+ ;; for the whole keep-date sublist.
+ " "
+ (dolist
+ (x
+ (tramp-get-method-parameter method 'tramp-copy-args)
+ copy-args)
+ (setq copy-args
+ (append
+ copy-args
+ (let ((y (mapcar (lambda (z) (format-spec z spec)) x)))
+ (if (member "" y) '(" ") y))))))
+ 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.
+ (unless (let ((default-directory
+ (tramp-compat-temporary-file-directory)))
+ (executable-find copy-program))
+ (tramp-error
+ v 'file-error "Cannot find copy program: %s" copy-program))
+
+ (with-temp-buffer
+ (unwind-protect
+ ;; 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
+ orig-vec 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-name v)
+ (tramp-get-connection-buffer v)
+ copy-program
+ (append copy-args (list source target))))))
+ (tramp-message
+ orig-vec 6 "%s"
+ (mapconcat 'identity (process-command p) " "))
+ (tramp-compat-set-process-query-on-exit-flag p nil)
+ (tramp-process-actions
+ p v nil tramp-actions-copy-out-of-band)))
+
+ ;; Reset the transfer process properties.
+ (tramp-message orig-vec 6 "%s" (buffer-string))
+ (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 explicitly.
+ 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
+ ;; 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))
+ (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer)))
+ (name1 name)
+ (i 0))
+ (unwind-protect
+ (save-excursion
+ (save-restriction
+ (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)
+ (let ((buffer-undo-list t))
+ (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)))
+ (set-buffer-modified-p bmp)))
+ (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 (file-truename 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 explicitly, 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
+ ;; Windows shells need the program file name after
+ ;; the pipe symbol be quoted if they use forward
+ ;; slashes as directory separators.
+ (if (memq system-type '(windows-nt))
+ "echo %s | \"%s\" | \"%s\""
+ "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-file-name-port hop)
+ (tramp-error
+ vec 'file-error
+ "Connection `%s' is not supported for gateway access." hop))
+ ;; 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))
+ (pos (with-current-buffer (tramp-get-connection-buffer vec) (point))))
+
+ ;; 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
+ (tramp-get-connection-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 pos 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
+ (or
+ (tramp-send-command-and-read
+ vec
+ "x=`getconf PATH 2>/dev/null` && echo \\\"$x\\\" || echo nil")
+ ;; Default if "getconf" is not available.
+ (progn
+ (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\\\"")
+ (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
+ ;; Windows shells need the program file name after
+ ;; the pipe symbol be quoted if they use forward
+ ;; slashes as directory separators.
+ (if (and (string-match "local" prop)
+ (memq system-type '(windows-nt)))
+ "(%s | \"%s\" >%%s)"
+ "(%s | %s >%%s)")
+ coding compress))
+ (compress
+ (format
+ ;; Windows shells need the program file name after
+ ;; the pipe symbol be quoted if they use forward
+ ;; slashes as directory separators.
+ (if (and (string-match "local" prop)
+ (memq system-type '(windows-nt)))
+ "(%s <%%s | \"%s\")"
+ "(%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 3cd6fd0c96f..5a62b71bda1 100644
--- a/lisp/net/tramp-smb.el
+++ b/lisp/net/tramp-smb.el
@@ -1,10 +1,10 @@
;;; tramp-smb.el --- Tramp access functions for SMB servers
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
-;; 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, processes
+;; Package: tramp
;; This file is part of GNU Emacs.
@@ -29,27 +29,28 @@
(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.
+;;;###tramp-autoload
(add-to-list 'tramp-default-method-alist
`(nil ,tramp-prefix-domain-regexp ,tramp-smb-method))
;; Add a default for `tramp-default-user-alist'. Rule: For the SMB method,
;; the anonymous user is chosen.
+;;;###tramp-autoload
(add-to-list 'tramp-default-user-alist
- `(,tramp-smb-method nil ""))
+ `(,(concat "\\`" tramp-smb-method "\\'") nil nil))
;; Add completion function for SMB method.
(tramp-set-completion-function
@@ -75,45 +76,48 @@ call, letting the SMB client use the default one."
"Regexp used as prompt in smbclient.")
(defconst tramp-smb-errors
- ;; `regexp-opt' not possible because of first string.
(mapconcat
'identity
- '(;; Connection error / timeout / unknown command.
- "Connection to \\S-+ failed"
+ `(;; Connection error / timeout / unknown command.
+ "Connection\\( to \\S-+\\)? failed"
"Read from server failed, maybe it closed the connection"
"Call timed out: server did not respond"
"\\S-+: command not found"
"Server doesn't support UNIX CIFS calls"
- ;; Samba.
- "ERRDOS"
- "ERRHRD"
- "ERRSRV"
- "ERRbadfile"
- "ERRbadpw"
- "ERRfilexists"
- "ERRnoaccess"
- "ERRnomem"
- "ERRnosuchshare"
- ;; Windows 4.0 (Windows NT), Windows 5.0 (Windows 2000),
- ;; Windows 5.1 (Windows XP), Windows 5.2 (Windows Server 2003).
- "NT_STATUS_ACCESS_DENIED"
- "NT_STATUS_ACCOUNT_LOCKED_OUT"
- "NT_STATUS_BAD_NETWORK_NAME"
- "NT_STATUS_CANNOT_DELETE"
- "NT_STATUS_CONNECTION_REFUSED"
- "NT_STATUS_DIRECTORY_NOT_EMPTY"
- "NT_STATUS_DUPLICATE_NAME"
- "NT_STATUS_FILE_IS_A_DIRECTORY"
- "NT_STATUS_LOGON_FAILURE"
- "NT_STATUS_NETWORK_ACCESS_DENIED"
- "NT_STATUS_NOT_IMPLEMENTED"
- "NT_STATUS_NO_SUCH_FILE"
- "NT_STATUS_OBJECT_NAME_COLLISION"
- "NT_STATUS_OBJECT_NAME_INVALID"
- "NT_STATUS_OBJECT_NAME_NOT_FOUND"
- "NT_STATUS_SHARING_VIOLATION"
- "NT_STATUS_TRUSTED_RELATIONSHIP_FAILURE"
- "NT_STATUS_WRONG_PASSWORD")
+ ,(regexp-opt
+ '(;; Samba.
+ "ERRDOS"
+ "ERRHRD"
+ "ERRSRV"
+ "ERRbadfile"
+ "ERRbadpw"
+ "ERRfilexists"
+ "ERRnoaccess"
+ "ERRnomem"
+ "ERRnosuchshare"
+ ;; Windows 4.0 (Windows NT), Windows 5.0 (Windows 2000),
+ ;; Windows 5.1 (Windows XP), Windows 5.2 (Windows Server 2003).
+ "NT_STATUS_ACCESS_DENIED"
+ "NT_STATUS_ACCOUNT_LOCKED_OUT"
+ "NT_STATUS_BAD_NETWORK_NAME"
+ "NT_STATUS_CANNOT_DELETE"
+ "NT_STATUS_CONNECTION_REFUSED"
+ "NT_STATUS_DIRECTORY_NOT_EMPTY"
+ "NT_STATUS_DUPLICATE_NAME"
+ "NT_STATUS_FILE_IS_A_DIRECTORY"
+ "NT_STATUS_IO_TIMEOUT"
+ "NT_STATUS_LOGON_FAILURE"
+ "NT_STATUS_NETWORK_ACCESS_DENIED"
+ "NT_STATUS_NOT_IMPLEMENTED"
+ "NT_STATUS_NO_SUCH_FILE"
+ "NT_STATUS_NO_SUCH_USER"
+ "NT_STATUS_OBJECT_NAME_COLLISION"
+ "NT_STATUS_OBJECT_NAME_INVALID"
+ "NT_STATUS_OBJECT_NAME_NOT_FOUND"
+ "NT_STATUS_SHARING_VIOLATION"
+ "NT_STATUS_TRUSTED_RELATIONSHIP_FAILURE"
+ "NT_STATUS_UNSUCCESSFUL"
+ "NT_STATUS_WRONG_PASSWORD")))
"\\|")
"Regexp for possible error strings of SMB servers.
Used instead of analyzing error codes of commands.")
@@ -153,7 +157,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 +165,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 +175,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 +208,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 +224,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.
@@ -331,7 +339,7 @@ pass to the OPERATION."
preserve-uid-gid preserve-selinux-context)
"Like `copy-file' for Tramp files.
KEEP-DATE is not handled in case NEWNAME resides on an SMB server.
-PRESERVE-UID-GID is completely ignored."
+PRESERVE-UID-GID and PRESERVE-SELINUX-CONTEXT are completely ignored."
(setq filename (expand-file-name filename)
newname (expand-file-name newname))
(with-progress-reporter
@@ -447,15 +455,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 +592,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 +629,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 +770,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 +879,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)))))
@@ -1052,17 +1039,17 @@ Result is a list of (LOCALNAME MODE SIZE MONTH DAY TIME YEAR)."
;; \s-\{2,2} - leading spaces
;; \S-\(.*\S-\)\s-* - file name, 30 chars, left bound
;; \s-+[ADHRSV]* - permissions, 7 chars, right bound
-;; \s- - space delimeter
+;; \s- - space delimiter
;; \s-+[0-9]+ - size, 8 chars, right bound
-;; \s-\{2,2\} - space delimeter
+;; \s-\{2,2\} - space delimiter
;; \w\{3,3\} - weekday
-;; \s- - space delimeter
+;; \s- - space delimiter
;; \w\{3,3\} - month
-;; \s- - space delimeter
+;; \s- - space delimiter
;; [ 12][0-9] - day
-;; \s- - space delimeter
+;; \s- - space delimiter
;; [0-9]\{2,2\}:[0-9]\{2,2\}:[0-9]\{2,2\} - time
-;; \s- - space delimeter
+;; \s- - space delimiter
;; [0-9]\{4,4\} - year
;;
;; samba/src/client.c (http://samba.org/doxygen/samba/client_8c-source.html)
@@ -1096,7 +1083,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 +1181,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 +1305,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 +1382,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 +1399,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 16b46017727..391fba0b404 100644
--- a/lisp/net/tramp-uu.el
+++ b/lisp/net/tramp-uu.el
@@ -1,10 +1,10 @@
;;; tramp-uu.el --- uuencode in Lisp
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Kai Großjohann <kai.grossjohann@gmx.net>
;; Keywords: comm, terminals
+;; Package: tramp
;; This file is part of GNU Emacs.
@@ -49,6 +49,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,9 +87,12 @@
(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
;;; tramp-uu.el ends here
;; Local Variables:
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index e3ec1a1c429..693e082ecc8 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -1,13 +1,11 @@
;;; tramp.el --- Transparent Remote Access, Multiple Protocol
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
-
-;; (copyright statements below in code to be updated with the above notice)
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; 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 +57,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,386 +174,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") ("-r")
- ("-o" "ControlPath=%t.%%r@%%h:%%p")
- ("-o" "ControlMaster=auto")))
- (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))
- ("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" "%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))
- ("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")
- ("-r")))
- (tramp-copy-keep-date t)
- (tramp-copy-recursive 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")
- ("-r")))
- (tramp-copy-keep-date t)
- (tramp-copy-recursive 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
@@ -787,6 +297,7 @@ shouldn't return t when it isn't."
(executable-find "pscp"))
(if (or (fboundp 'password-read)
(fboundp 'auth-source-user-or-password)
+ (fboundp 'auth-source-search)
;; Pageant is running.
(tramp-compat-process-running-p "Pageant"))
"pscp"
@@ -797,6 +308,7 @@ shouldn't return t when it isn't."
((tramp-detect-ssh-controlmaster) "scpc")
((or (fboundp 'password-read)
(fboundp 'auth-source-user-or-password)
+ (fboundp 'auth-source-search)
;; ssh-agent is running.
(getenv "SSH_AUTH_SOCK")
(getenv "SSH_AGENT_PID"))
@@ -810,8 +322,8 @@ Also see `tramp-default-method-alist'."
:group 'tramp
:type 'string)
-(defcustom tramp-default-method-alist
- '(("\\`localhost\\'" "\\`root\\'" "su"))
+;;;###tramp-autoload
+(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
@@ -828,8 +340,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'.
@@ -838,10 +349,8 @@ 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)))
+;;;###tramp-autoload
+(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
@@ -856,8 +365,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
@@ -882,44 +390,15 @@ interpreted as a regular expression which always matches."
(choice :tag "User regexp" regexp sexp)
(choice :tag " Proxy name" string (const nil)))))
+;;;###tramp-autoload
(defconst tramp-local-host-regexp
(concat
- "^" (regexp-opt (list "localhost" (system-name) "127\.0\.0\.1" "::1") t) "$")
+ "\\`"
+ (regexp-opt
+ (list "localhost" "localhost6" (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 ...\).
@@ -940,63 +419,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.")
@@ -1045,55 +467,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.
@@ -1221,15 +594,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.
@@ -1239,22 +610,7 @@ It shall be used in combination with `generate-new-buffer-name'.")
"File name of a persistent local temporary file.
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))))
+(put 'tramp-temp-buffer-file-name 'permanent-local t)
;; XEmacs is distributed with few Lisp packages. Further packages are
;; installed using EFS. If we use a unified filename format, then
@@ -1306,28 +662,28 @@ Should always start with \"^\". Derived from `tramp-prefix-format'.")
((equal tramp-syntax 'sep) "/")
((equal tramp-syntax 'url) "://")
(t (error "Wrong `tramp-syntax' defined")))
- "*String matching delimeter between method and user or host names.
+ "*String matching delimiter between method and user or host names.
Used in `tramp-make-tramp-file-name'.")
(defconst tramp-postfix-method-regexp
(regexp-quote tramp-postfix-method-format)
- "*Regexp matching delimeter between method and user or host names.
+ "*Regexp matching delimiter 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.")
+;;;###tramp-autoload
(defconst tramp-prefix-domain-format "%"
- "*String matching delimeter between user and domain names.")
+ "*String matching delimiter between user and domain names.")
+;;;###tramp-autoload
(defconst tramp-prefix-domain-regexp
(regexp-quote tramp-prefix-domain-format)
- "*Regexp matching delimeter between user and domain names.
+ "*Regexp matching delimiter 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
@@ -1336,18 +692,16 @@ Derived from `tramp-prefix-domain-format'.")
"\\(" tramp-domain-regexp "\\)")
"*Regexp matching user names with domain names.")
-(defconst tramp-postfix-user-format
- "@"
- "*String matching delimeter between user and host names.
+(defconst tramp-postfix-user-format "@"
+ "*String matching delimiter between user and host names.
Used in `tramp-make-tramp-file-name'.")
(defconst tramp-postfix-user-regexp
(regexp-quote tramp-postfix-user-format)
- "*Regexp matching delimeter between user and host names.
+ "*Regexp matching delimiter 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
@@ -1388,15 +742,14 @@ Derived from `tramp-postfix-ipv6-format'.")
((equal tramp-syntax 'sep) "#")
((equal tramp-syntax 'url) ":")
(t (error "Wrong `tramp-syntax' defined")))
- "*String matching delimeter between host names and port numbers.")
+ "*String matching delimiter between host names and port numbers.")
(defconst tramp-prefix-port-regexp
(regexp-quote tramp-prefix-port-format)
- "*Regexp matching delimeter between host names and port numbers.
+ "*Regexp matching delimiter 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
@@ -1410,19 +763,18 @@ Derived from `tramp-prefix-port-format'.")
((equal tramp-syntax 'sep) "]")
((equal tramp-syntax 'url) "")
(t (error "Wrong `tramp-syntax' defined")))
- "*String matching delimeter between host names and localnames.
+ "*String matching delimiter between host names and localnames.
Used in `tramp-make-tramp-file-name'.")
(defconst tramp-postfix-host-regexp
(regexp-quote tramp-postfix-host-format)
- "*Regexp matching delimeter between host names and localnames.
+ "*Regexp matching delimiter 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
@@ -1467,15 +819,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.")
@@ -1549,38 +899,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
@@ -1669,8 +987,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))
@@ -1686,437 +1004,276 @@ 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,
-# 2011 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,
-# 2011 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 ((method (tramp-file-name-method vec))
+ (host (tramp-file-name-host vec)))
+ (or (and (stringp host)
+ (string-match tramp-host-with-port-regexp host)
+ (string-to-number (match-string 2 host)))
+ (tramp-get-method-parameter method 'tramp-default-port)))))
+
+;;;###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-name (vec)
+ "Get the connection name to be used for VEC.
+In case a second asynchronous communication has been started, it is different
+from the default one."
+ (or (tramp-get-connection-property vec "process-name" nil)
+ (tramp-buffer-name 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 (tramp-get-connection-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
@@ -2137,7 +1294,8 @@ ARGS to actually emit the message (if applicable)."
(let ((now (current-time)))
(insert (format-time-string "%T." now))
(insert (format "%06d " (nth 2 now))))
- ;; Calling function.
+ ;; Calling Tramp function. We suppress compat and trace
+ ;; functions from being displayed.
(let ((btn 1) btf fn)
(while (not fn)
(setq btf (nth 1 (backtrace-frame btn)))
@@ -2145,10 +1303,23 @@ ARGS to actually emit the message (if applicable)."
(setq fn "")
(when (symbolp btf)
(setq fn (symbol-name btf))
- (unless (and (string-match "^tramp" fn)
- (not (string-match
- "^tramp\\(-debug\\)?\\(-message\\|-error\\|-compat-funcall\\)$"
- fn)))
+ (unless
+ (and
+ (string-match "^tramp" fn)
+ (not
+ (string-match
+ (concat
+ "^"
+ (regexp-opt
+ '("tramp-compat-funcall"
+ "tramp-compat-with-temp-message"
+ "tramp-debug-message"
+ "tramp-error"
+ "tramp-error-with-buffer"
+ "tramp-message")
+ t)
+ "$")
+ fn)))
(setq fn nil)))
(setq btn (1+ btn))))
;; The following code inserts filename and line number.
@@ -2183,36 +1354,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.
@@ -2274,40 +1443,8 @@ 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))
@@ -2327,11 +1464,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
@@ -2345,13 +1481,14 @@ 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))
(defun tramp-drop-volume-letter (name)
"Cut off unnecessary drive letter from file NAME.
-The function `tramp-handle-expand-file-name' calls `expand-file-name'
+The functions `tramp-*-handle-expand-file-name' call `expand-file-name'
locally on a remote file name. When the local system is a W32 system
but the remote system is Unix, this introduces a superfluous drive
letter into the file name. This function removes it."
@@ -2362,34 +1499,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)
@@ -2424,7 +1533,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)))))
@@ -2465,8 +1574,12 @@ special handling of `substitute-in-file-name'."
(let ((props (tramp-compat-funcall
'overlay-properties (symbol-value 'rfn-eshadow-overlay))))
(while props
- (tramp-compat-funcall
- 'overlay-put tramp-rfn-eshadow-overlay (pop props) (pop props))))))
+ ;; The `field' property prevents correct minibuffer
+ ;; completion; we exclude it.
+ (if (not (eq (car props) 'field))
+ (tramp-compat-funcall
+ 'overlay-put tramp-rfn-eshadow-overlay (pop props) (pop props))
+ (pop props) (pop props))))))
(when (boundp 'rfn-eshadow-setup-minibuffer-hook)
(add-hook 'rfn-eshadow-setup-minibuffer-hook
@@ -2512,279 +1625,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
@@ -2801,1639 +1641,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 nil 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.
@@ -4450,38 +1663,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)
@@ -4511,411 +1692,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
- ;; 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))
- (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer)))
- (name1 name)
- (i 0))
- (unwind-protect
- (save-excursion
- (save-restriction
- (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)
- (let ((buffer-undo-list t))
- (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-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)))
- (set-buffer-modified-p bmp)))
- (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
@@ -4931,537 +1707,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
- (tramp-file-name-handler '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.
@@ -5622,8 +1867,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
@@ -5681,48 +1925,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.
@@ -5781,9 +1983,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
@@ -5816,6 +2038,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
@@ -5920,12 +2143,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
@@ -6103,7 +2325,7 @@ remote host and localname (filename on remote host)."
(vector method user host localname)))))
;; This function returns all possible method completions, adding the
-;; trailing method delimeter.
+;; trailing method delimiter.
(defun tramp-get-completion-methods (partial-method)
"Returns all method completions for PARTIAL-METHOD."
(mapcar
@@ -6168,7 +2390,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)
@@ -6195,7 +2417,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)
@@ -6224,7 +2446,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)
@@ -6285,7 +2507,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)
@@ -6320,7 +2542,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)
@@ -6350,7 +2572,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)
@@ -6365,7 +2587,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))))
@@ -6376,333 +2598,387 @@ 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-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-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-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 if it is readable 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))
-(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 delimiter 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
@@ -6801,7 +3077,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."
@@ -6828,7 +3104,7 @@ PROC and VEC indicate the remote connection to be used. POS, if
set, is the starting point of the region to be deleted in the
connection buffer."
;; 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)
(save-restriction
@@ -6856,7 +3132,7 @@ connection buffer."
(with-current-buffer (tramp-get-connection-buffer vec)
(let (buffer-read-only) (delete-region pos (point)))))))))
-;; Utility functions.
+:;; Utility functions:
(defun tramp-accept-process-output (&optional proc timeout timeout-msecs)
"Like `accept-process-output' for Tramp processes.
@@ -6940,17 +3216,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.
@@ -6963,841 +3228,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))
- (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.
-
-(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
- ;; Windows shells need the program file name after
- ;; the pipe symbol be quoted if they use forward
- ;; slashes as directory separators.
- (if (memq system-type '(windows-nt))
- "echo %s | \"%s\" | \"%s\""
- "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))
- (pos (with-current-buffer (tramp-get-connection-buffer vec) (point))))
-
- ;; 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 pos 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
@@ -7840,6 +3270,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
@@ -7856,454 +3336,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
@@ -8326,401 +3413,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
- ;; Windows shells need the program file name after
- ;; the pipe symbol be quoted if they use forward
- ;; slashes as directory separators.
- (if (and (string-match "local" prop)
- (memq system-type '(windows-nt)))
- "(%s | \"%s\" >%%s)"
- "(%s | %s >%%s)")
- coding compress))
- (compress
- (format
- ;; Windows shells need the program file name after
- ;; the pipe symbol be quoted if they use forward
- ;; slashes as directory separators.
- (if (and (string-match "local" prop)
- (memq system-type '(windows-nt)))
- "(%s <%%s | \"%s\")"
- "(%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.
@@ -8750,8 +3493,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)
@@ -8774,9 +3518,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).
@@ -8789,17 +3531,32 @@ Invokes `password-read' if available, `read-passwd' else."
(or prompt
(with-current-buffer (process-buffer proc)
(tramp-check-for-regexp proc tramp-password-prompt-regexp)
- (format "%s for %s " (capitalize (match-string 1)) key)))))
+ (format "%s for %s " (capitalize (match-string 1)) key))))
+ auth-info auth-passwd)
(with-parsed-tramp-file-name key nil
(prog1
(or
- ;; See if auth-sources contains something useful, if it's bound.
+ ;; See if auth-sources contains something useful, if it's
+ ;; bound. `auth-source-user-or-password' is an obsoleted
+ ;; function, it has been replaced by `auth-source-search'.
(and (boundp 'auth-sources)
(tramp-get-connection-property v "first-password-request" nil)
;; Try with Tramp's current method.
- (tramp-compat-funcall
- 'auth-source-user-or-password
- "password" tramp-current-host tramp-current-method))
+ (if (fboundp 'auth-source-search)
+ (setq auth-info
+ (tramp-compat-funcall
+ 'auth-source-search
+ :max 1
+ :user (or tramp-current-user t)
+ :host tramp-current-host
+ :port tramp-current-method)
+ auth-passwd (plist-get (nth 0 auth-info) :secret)
+ auth-passwd (if (functionp auth-passwd)
+ (funcall auth-passwd)
+ auth-passwd))
+ (tramp-compat-funcall
+ 'auth-source-user-or-password
+ "password" tramp-current-host tramp-current-method)))
;; Try the password cache.
(when (functionp 'password-read)
(unless (tramp-get-connection-property
@@ -8855,7 +3612,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
@@ -8875,37 +3631,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'
@@ -8931,6 +3656,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."
@@ -8956,113 +3682,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
@@ -9074,7 +3729,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 0fc0cd3657b..7b4c6fd75b1 100644
--- a/lisp/net/trampver.el
+++ b/lisp/net/trampver.el
@@ -1,11 +1,11 @@
;;; trampver.el --- Transparent Remote Access, Multiple Protocol
;;; lisp/trampver.el. Generated from trampver.el.in by configure.
-;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
-;; 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003-2011 Free Software Foundation, Inc.
;; Author: Kai Großjohann <kai.grossjohann@gmx.net>
;; Keywords: comm, processes
+;; Package: tramp
;; This file is part of GNU Emacs.
@@ -30,19 +30,31 @@
;; version check is defined in macro AC_EMACS_INFO of aclocal.m4;
;; should be changed only there.
-(defconst tramp-version "2.1.21-pre"
+;;;###tramp-autoload
+(defconst tramp-version "2.2.2-pre"
"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.21-pre 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.2-pre 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/webjump.el b/lisp/net/webjump.el
index 51c2a682d20..be79bc721e2 100644
--- a/lisp/net/webjump.el
+++ b/lisp/net/webjump.el
@@ -1,7 +1,6 @@
;;; webjump.el --- programmable Web hotlist
-;; Copyright (C) 1996, 1997, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Neil W. Van Dyke <nwv@acm.org>
;; Created: 09-Aug-1996
@@ -480,5 +479,4 @@ Please submit bug reports and other feedback to the author, Neil W. Van Dyke
(provide 'webjump)
-;; arch-tag: f1d20156-0a6f-488b-bd91-f69ee8b6d5cc
;;; webjump.el ends here
diff --git a/lisp/net/xesam.el b/lisp/net/xesam.el
index e783f3ce102..64c26cfb2c9 100644
--- a/lisp/net/xesam.el
+++ b/lisp/net/xesam.el
@@ -1,6 +1,6 @@
;;; xesam.el --- Xesam interface to search engines.
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Michael Albinus <michael.albinus@gmx.de>
;; Keywords: tools, hypermedia
@@ -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
@@ -414,18 +414,18 @@ If there is no registered search engine at all, the function returns `nil'."
;; Hopefully, this will change later.
(setq hit-fields
(case (intern vendor-id)
- ('Beagle
+ (Beagle
'("xesam:mimeType" "xesam:url"))
- ('Strigi
+ (Strigi
'("xesam:author" "xesam:cc" "xesam:charset"
"xesam:contentType" "xesam:fileExtension"
"xesam:id" "xesam:lineCount" "xesam:links"
"xesam:mimeType" "xesam:name" "xesam:size"
"xesam:sourceModified" "xesam:subject" "xesam:to"
"xesam:url"))
- ('TrackerXesamSession
+ (TrackerXesamSession
'("xesam:relevancyRating" "xesam:url"))
- ('Debbugs
+ (Debbugs
'("xesam:keyword" "xesam:owner" "xesam:title"
"xesam:url" "xesam:sourceModified" "xesam:mimeType"
"debbugs:key"))
@@ -446,7 +446,12 @@ If there is no registered search engine at all, the function returns `nil'."
;;; Search buffers.
-(define-derived-mode xesam-mode nil "Xesam"
+(defvar xesam-mode-map
+ (let ((map (copy-keymap special-mode-map)))
+ (set-keymap-parent xesam-mode-map widget-keymap)
+ map))
+
+(define-derived-mode xesam-mode special-mode "Xesam"
"Major mode for presenting search results of a Xesam search.
In this mode, widgets represent the search results.
@@ -455,12 +460,6 @@ Turning on Xesam mode runs the normal hook `xesam-mode-hook'. It
can be used to set `xesam-notify-function', which must a search
engine specific, widget :notify function to visualize xesam:url."
(set (make-local-variable 'xesam-notify-function) nil)
-
- ;; Keymap.
- (setq xesam-mode-map (copy-keymap special-mode-map))
- (set-keymap-parent xesam-mode-map widget-keymap)
- (define-key xesam-mode-map "z" 'kill-this-buffer)
-
;; Maybe we implement something useful, later on.
(set (make-local-variable 'revert-buffer-function) 'ignore)
;; `xesam-engine', `xesam-search', `xesam-type', `xesam-query', and
@@ -918,5 +917,4 @@ Example:
;; yahoo, ebay, ...
;; - Construct complex queries via widgets, like in mairix.el.
-;; arch-tag: 7fb9fc6c-c2ff-4bc7-bb42-bacb80cce2b2
;;; xesam.el ends here
diff --git a/lisp/net/zeroconf.el b/lisp/net/zeroconf.el
index 40ceb5b149f..d801a4c094c 100644
--- a/lisp/net/zeroconf.el
+++ b/lisp/net/zeroconf.el
@@ -1,6 +1,6 @@
;;; zeroconf.el --- Service browser using Avahi.
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, hardware
@@ -686,5 +686,4 @@ For the description of arguments, see `zeroconf-resolved-services-hash'."
(provide 'zeroconf)
-;; arch-tag: ea578165-7fa8-44f4-90f0-de3940aec69f
;;; zeroconf.el ends here
diff --git a/lisp/newcomment.el b/lisp/newcomment.el
index 6a7b8dfdb5b..f1243f158a5 100644
--- a/lisp/newcomment.el
+++ b/lisp/newcomment.el
@@ -1,11 +1,11 @@
-;;; newcomment.el --- (un)comment regions of buffers
+;;; newcomment.el --- (un)comment regions of buffers -*- lexical-binding: t -*-
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; 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.
@@ -186,21 +186,58 @@ This should generally stay 0, except for a few modes like Lisp where
it is 1 so that regions are commented with two or three semi-colons.")
(defconst comment-styles
- '((plain . (nil nil nil nil))
- (indent . (nil nil nil t))
- (indent-or-triple
- . (nil nil nil multi-char))
- (aligned . (nil t nil t))
- (multi-line . (t nil nil t))
- (extra-line . (t nil t t))
- (box . (nil t t t))
- (box-multi . (t t t t)))
- "Comment region styles of the form (STYLE . (MULTI ALIGN EXTRA INDENT)).
+ '((plain nil nil nil nil
+ "Start in column 0 (do not indent), as in Emacs-20")
+ (indent-or-triple nil nil nil multi-char
+ "Start in column 0, but only for single-char starters")
+ (indent nil nil nil t
+ "Full comment per line, ends not aligned")
+ (aligned nil t nil t
+ "Full comment per line, ends aligned")
+ (box nil t t t
+ "Full comment per line, ends aligned, + top and bottom")
+ (extra-line t nil t t
+ "One comment for all lines, end on a line by itself")
+ (multi-line t nil nil t
+ "One comment for all lines, end on last commented line")
+ (box-multi t t t t
+ "One comment for all lines, + top and bottom"))
+ "Comment region style definitions.
+Each style is defined with a form (STYLE . (MULTI ALIGN EXTRA INDENT DOC)).
+DOC should succinctly describe the style.
STYLE should be a mnemonic symbol.
MULTI specifies that comments are allowed to span multiple lines.
+ e.g. in C it comments regions as
+ /* blabla
+ * bli */
+ rather than
+ /* blabla */
+ /* bli */
+ if `comment-end' is empty, this has no effect.
+
ALIGN specifies that the `comment-end' markers should be aligned.
+ e.g. in C it comments regions as
+ /* blabla */
+ /* bli */
+ rather than
+ /* blabla */
+ /* bli */
+ if `comment-end' is empty, this has no effect, unless EXTRA is also set,
+ in which case the comment gets wrapped in a box.
+
EXTRA specifies that an extra line should be used before and after the
region to comment (to put the `comment-end' and `comment-start').
+ e.g. in C it comments regions as
+ /*
+ * blabla
+ * bli
+ */
+ rather than
+ /* blabla
+ * bli */
+ if the comment style is not multi line, this has no effect, unless ALIGN
+ is also set, in which case the comment gets wrapped in a box.
+
INDENT specifies that the `comment-start' markers should not be put at the
left margin but at the current indentation of the region to comment.
If INDENT is `multi-char', that means indent multi-character
@@ -211,8 +248,11 @@ If INDENT is `multi-char', that means indent multi-character
"Style to be used for `comment-region'.
See `comment-styles' for a list of available styles."
:type (if (boundp 'comment-styles)
- `(choice ,@(mapcar (lambda (s) `(const ,(car s)))
- comment-styles))
+ `(choice
+ ,@(mapcar (lambda (s)
+ `(const :tag ,(format "%s: %s" (car s) (nth 5 s))
+ ,(car s)))
+ comment-styles))
'symbol)
:version "23.1"
:group 'comment)
@@ -682,7 +722,7 @@ With any other arg, set comment column to indentation of the previous comment
With prefix ARG, kill comments on that many lines starting with this one."
(interactive "P")
(comment-normalize-vars)
- (dotimes (_ (prefix-numeric-value arg))
+ (dotimes (_i (prefix-numeric-value arg))
(save-excursion
(beginning-of-line)
(let ((cs (comment-search-forward (line-end-position) t)))
@@ -946,12 +986,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))))
@@ -1144,6 +1184,12 @@ end- comment markers additionally to what `comment-add' already specifies."
'box-multi 'box)))
(comment-region beg end (+ comment-add arg))))
+(defun comment-only-p (beg end)
+ "Return non-nil if the text between BEG and END is all comments."
+ (save-excursion
+ (goto-char beg)
+ (comment-forward (point-max))
+ (<= end (point))))
;;;###autoload
(defun comment-or-uncomment-region (beg end &optional arg)
@@ -1152,10 +1198,7 @@ in which case call `uncomment-region'. If a prefix arg is given, it
is passed on to the respective function."
(interactive "*r\nP")
(comment-normalize-vars)
- (funcall (if (save-excursion ;; check for already commented region
- (goto-char beg)
- (comment-forward (point-max))
- (<= end (point)))
+ (funcall (if (comment-only-p beg end)
'uncomment-region 'comment-region)
beg end arg))
@@ -1163,8 +1206,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'.
@@ -1346,5 +1389,4 @@ unless optional argument SOFT is non-nil."
(provide 'newcomment)
-;; arch-tag: 01e3320a-00c8-44ea-a696-8f8e7354c858
;;; newcomment.el ends here
diff --git a/lisp/notifications.el b/lisp/notifications.el
new file mode 100644
index 00000000000..adb9fdd641a
--- /dev/null
+++ b/lisp/notifications.el
@@ -0,0 +1,294 @@
+;;; notifications.el --- Client interface to desktop notifications.
+
+;; Copyright (C) 2010-2011 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/novice.el b/lisp/novice.el
index 3d46be7e06b..e47b17cf346 100644
--- a/lisp/novice.el
+++ b/lisp/novice.el
@@ -1,7 +1,6 @@
;;; novice.el --- handling of disabled commands ("novice mode") for Emacs
-;; Copyright (C) 1985, 1986, 1987, 1994, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1987, 1994, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal, help
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-enc.el b/lisp/nxml/nxml-enc.el
index 0a0d70f31bc..350c5c77c7b 100644
--- a/lisp/nxml/nxml-enc.el
+++ b/lisp/nxml/nxml-enc.el
@@ -1,6 +1,6 @@
;;; nxml-enc.el --- XML encoding auto-detection
-;; Copyright (C) 2003, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2007-2011 Free Software Foundation, Inc.
;; Author: James Clark
;; Keywords: XML
@@ -146,5 +146,4 @@ Applied to any files that `auto-mode-alist' says should be handled by
(provide 'nxml-enc)
-;; arch-tag: c2436247-78f3-418c-8069-85dc5335d083
;;; nxml-enc.el ends here
diff --git a/lisp/nxml/nxml-glyph.el b/lisp/nxml/nxml-glyph.el
index 9d7e5136e4f..1b48a3fa25f 100644
--- a/lisp/nxml/nxml-glyph.el
+++ b/lisp/nxml/nxml-glyph.el
@@ -1,6 +1,6 @@
;;; nxml-glyph.el --- glyph-handling for nxml-mode
-;; Copyright (C) 2003, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2007-2011 Free Software Foundation, Inc.
;; Author: James Clark
;; Keywords: XML
@@ -415,5 +415,4 @@ Return nil if the face cannot display a glyph for N."
(provide 'nxml-glyph)
-;; arch-tag: 50985104-27c6-4241-8625-b11aa5685633
;;; nxml-glyph.el ends here
diff --git a/lisp/nxml/nxml-maint.el b/lisp/nxml/nxml-maint.el
index 20a3b09d3fa..e24a3d7172a 100644
--- a/lisp/nxml/nxml-maint.el
+++ b/lisp/nxml/nxml-maint.el
@@ -1,6 +1,6 @@
;;; nxml-maint.el --- commands for maintainers of nxml-*.el
-;; Copyright (C) 2003, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2007-2011 Free Software Foundation, Inc.
;; Author: James Clark
;; Keywords: XML
@@ -78,7 +78,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 +102,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 9f23b4c6617..993a6f7a2ab 100644
--- a/lisp/nxml/nxml-mode.el
+++ b/lisp/nxml/nxml-mode.el
@@ -1,6 +1,6 @@
;;; nxml-mode.el --- a new XML mode
-;; Copyright (C) 2003, 2004, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003-2004, 2007-2011 Free Software Foundation, Inc.
;; Author: James Clark
;; Keywords: XML
@@ -37,54 +37,49 @@
(require 'nxml-util)
(require 'nxml-rap)
(require 'nxml-outln)
-
-(declare-function rng-nxml-mode-init "rng-nxml")
-(declare-function nxml-enable-unicode-char-name-sets "nxml-uchnm")
+;; nxml-mode calls rng-nxml-mode-init, which is autoloaded from rng-nxml.
+;; So we might as well just require it and silence the compiler.
+(provide 'nxml-mode) ; avoid recursive require
+(require 'rng-nxml)
;;; Customization
(defgroup nxml nil
"New XML editing mode."
- :group 'languages
- :group 'wp)
+ :group 'languages)
(defgroup nxml-faces nil
"Faces for XML syntax highlighting."
:group 'nxml)
(defcustom nxml-char-ref-display-glyph-flag t
- "*Non-nil means display glyph following character reference.
+ "Non-nil means display glyph following character reference.
The glyph is displayed in face `nxml-glyph'. The hook
`nxml-glyph-set-hook' can be used to customize for which characters
glyphs are displayed."
:group 'nxml
:type 'boolean)
-(defcustom nxml-mode-hook nil
- "Hook run by command `nxml-mode'."
- :group 'nxml
- :type 'hook)
-
(defcustom nxml-sexp-element-flag nil
- "*Non-nil means sexp commands treat an element as a single expression."
+ "Non-nil means sexp commands treat an element as a single expression."
:group 'nxml
:type 'boolean)
(defcustom nxml-slash-auto-complete-flag nil
- "*Non-nil means typing a slash automatically completes the end-tag.
+ "Non-nil means typing a slash automatically completes the end-tag.
This is used by `nxml-electric-slash'."
:group 'nxml
:type 'boolean)
(defcustom nxml-child-indent 2
- "*Indentation for the children of an element relative to the start-tag.
+ "Indentation for the children of an element relative to the start-tag.
This only applies when the line or lines containing the start-tag contains
nothing else other than that start-tag."
:group 'nxml
:type 'integer)
(defcustom nxml-attribute-indent 4
- "*Indentation for the attributes of an element relative to the start-tag.
+ "Indentation for the attributes of an element relative to the start-tag.
This only applies when the first attribute of a tag starts a line.
In other cases, the first attribute on one line is indented the same
as the first attribute on the previous line."
@@ -92,7 +87,7 @@ as the first attribute on the previous line."
:type 'integer)
(defcustom nxml-bind-meta-tab-to-complete-flag (not window-system)
- "*Non-nil means bind M-TAB in `nxml-mode-map' to `nxml-complete'.
+ "Non-nil means bind M-TAB in `nxml-mode-map' to `nxml-complete'.
C-return will be bound to `nxml-complete' in any case.
M-TAB gets swallowed by many window systems/managers, and
`documentation' will show M-TAB rather than C-return as the
@@ -106,7 +101,7 @@ to bind M-TAB only when it will work."
:type 'boolean)
(defcustom nxml-prefer-utf-16-to-utf-8-flag nil
- "*Non-nil means prefer UTF-16 to UTF-8 when saving a buffer.
+ "Non-nil means prefer UTF-16 to UTF-8 when saving a buffer.
This is used only when a buffer does not contain an encoding declaration
and when its current `buffer-file-coding-system' specifies neither UTF-16
nor UTF-8."
@@ -115,7 +110,7 @@ nor UTF-8."
(defcustom nxml-prefer-utf-16-little-to-big-endian-flag (eq system-type
'windows-nt)
- "*Non-nil means prefer little-endian to big-endian byte-order for UTF-16.
+ "Non-nil means prefer little-endian to big-endian byte-order for UTF-16.
This is used only for saving a buffer; when reading the byte-order is
auto-detected. It may be relevant both when there is no encoding declaration
and when the encoding declaration specifies `UTF-16'."
@@ -123,14 +118,14 @@ and when the encoding declaration specifies `UTF-16'."
:type 'boolean)
(defcustom nxml-default-buffer-file-coding-system nil
- "*Default value for `buffer-file-coding-system' for a buffer for a new file.
+ "Default value for `buffer-file-coding-system' for a buffer for a new file.
A value of nil means use the default value of `buffer-file-coding-system' as normal.
A buffer's `buffer-file-coding-system' affects what \\[nxml-insert-xml-declaration] inserts."
:group 'nxml
:type 'coding-system)
(defcustom nxml-auto-insert-xml-declaration-flag nil
- "*Non-nil means automatically insert an XML declaration in a new file.
+ "Non-nil means automatically insert an XML declaration in a new file.
The XML declaration is inserted using `nxml-insert-xml-declaration'."
:group 'nxml
:type 'boolean)
@@ -355,6 +350,12 @@ The delimiters are <! and >."
;;; Global variables
+(defvar nxml-parent-document nil
+ "The parent document for a part of a modular document.
+Use `nxml-parent-document-set' to set it.")
+(make-variable-buffer-local 'nxml-parent-document)
+(put 'nxml-parent-document 'safe-local-variable 'stringp)
+
(defvar nxml-prolog-regions nil
"List of regions in the prolog to be fontified.
See the function `xmltok-forward-prolog' for more information.")
@@ -405,6 +406,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)
@@ -429,8 +432,40 @@ reference.")
(when (and face (< start end))
(font-lock-append-text-property start end 'face face)))
+(defun nxml-parent-document-set (parent-document)
+ "Set `nxml-parent-document' and inherit the DTD &c."
+ ;; FIXME: this does not work.
+ ;; the idea is that by inheriting some variables from the parent,
+ ;; `rng-validate-mode' will validate entities declared in the parent.
+ ;; alas, the most interesting variables (`rng-compile-table' et al)
+ ;; are circular and cannot be printed even with `print-circle'.
+ (interactive "fParent document")
+ (let (dtd current-schema current-schema-file-name compile-table
+ ipattern-table last-ipattern-index)
+ (when (string= (file-truename parent-document)
+ (file-truename buffer-file-name))
+ (error "Parent document cannot be the same as the document"))
+ (with-current-buffer (find-file-noselect parent-document)
+ (setq dtd rng-dtd
+ current-schema rng-current-schema
+ current-schema-file-name rng-current-schema-file-name
+ compile-table rng-compile-table
+ ipattern-table rng-ipattern-table
+ last-ipattern-index rng-last-ipattern-index
+ parent-document buffer-file-name))
+ (setq rng-dtd dtd
+ rng-current-schema current-schema
+ rng-current-schema-file-name current-schema-file-name
+ rng-compile-table compile-table
+ rng-ipattern-table ipattern-table
+ rng-last-ipattern-index last-ipattern-index
+ nxml-parent-document parent-document)
+ (message "Set parent document to %s" parent-document)
+ (when rng-validate-mode
+ (rng-validate-while-idle (current-buffer)))))
+
;;;###autoload
-(defun nxml-mode ()
+(define-derived-mode nxml-mode text-mode "nXML"
;; We use C-c C-i instead of \\[nxml-balanced-close-start-tag-inline]
;; because Emacs turns C-c C-i into C-c TAB which is hard to type and
;; not mnemonic.
@@ -484,10 +519,7 @@ be treated as a single markup item, set the variable
Many aspects this mode can be customized using
\\[customize-group] nxml RET."
- (interactive)
- (kill-all-local-variables)
- (setq major-mode 'nxml-mode)
- (setq mode-name "nXML")
+ ;; (kill-all-local-variables)
(set (make-local-variable 'mode-line-process) '((nxml-degraded "/degraded")))
;; We'll determine the fill prefix ourselves
(make-local-variable 'adaptive-fill-mode)
@@ -551,8 +583,7 @@ Many aspects this mode can be customized using
(font-lock-unfontify-region-function . nxml-unfontify-region)))
(rng-nxml-mode-init)
- (nxml-enable-unicode-char-name-sets)
- (run-mode-hooks 'nxml-mode-hook))
+ (nxml-enable-unicode-char-name-sets))
(defun nxml-cleanup ()
"Clean up after nxml-mode."
@@ -1370,17 +1401,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."
@@ -2659,5 +2694,4 @@ With a prefix argument, inserts the character directly."
(provide 'nxml-mode)
-;; arch-tag: 8603bc5f-1ef9-4021-b223-322fb2ca708e
;;; nxml-mode.el ends here
diff --git a/lisp/nxml/nxml-ns.el b/lisp/nxml/nxml-ns.el
index 4bb68a55049..4cf7f50d096 100644
--- a/lisp/nxml/nxml-ns.el
+++ b/lisp/nxml/nxml-ns.el
@@ -1,6 +1,6 @@
;;; nxml-ns.el --- XML namespace processing
-;; Copyright (C) 2003, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2007-2011 Free Software Foundation, Inc.
;; Author: James Clark
;; Keywords: XML
@@ -145,5 +145,4 @@ NS is a symbol or nil."
(provide 'nxml-ns)
-;; arch-tag: 5968e4b7-fb37-46ce-8621-c65db9793028
;;; nxml-ns.el ends here
diff --git a/lisp/nxml/nxml-outln.el b/lisp/nxml/nxml-outln.el
index 2293a386769..6a2a9daf7e4 100644
--- a/lisp/nxml/nxml-outln.el
+++ b/lisp/nxml/nxml-outln.el
@@ -1,6 +1,6 @@
;;; nxml-outln.el --- outline support for nXML mode
-;; Copyright (C) 2004, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2004, 2007-2011 Free Software Foundation, Inc.
;; Author: James Clark
;; Keywords: XML
@@ -82,7 +82,7 @@
(defcustom nxml-section-element-name-regexp
"article\\|\\(sub\\)*section\\|chapter\\|div\\|appendix\\|part\\|preface\\|reference\\|simplesect\\|bibliography\\|bibliodiv\\|glossary\\|glossdiv"
- "*Regular expression matching the name of elements used as sections.
+ "Regular expression matching the name of elements used as sections.
An XML element is treated as a section if:
- its local name (that is, the name without the prefix) matches
@@ -97,7 +97,7 @@ element has a local name matching the variable
:type 'regexp)
(defcustom nxml-heading-element-name-regexp "title\\|head"
- "*Regular expression matching the name of elements used as headings.
+ "Regular expression matching the name of elements used as headings.
An XML element is only recognized as a heading if it occurs as or
within the first child of an element that is recognized as a section.
See the variable `nxml-section-element-name-regexp' for more details."
@@ -105,7 +105,7 @@ See the variable `nxml-section-element-name-regexp' for more details."
:type 'regexp)
(defcustom nxml-outline-child-indent 2
- "*Indentation in an outline for child element relative to parent element."
+ "Indentation in an outline for child element relative to parent element."
:group 'nxml
:type 'integer)
@@ -1037,5 +1037,4 @@ immediately after the section's start-tag."
(provide 'nxml-outln)
-;; arch-tag: 1f1b7454-e573-4cd7-a505-d9dc64eef828
;;; nxml-outln.el ends here
diff --git a/lisp/nxml/nxml-parse.el b/lisp/nxml/nxml-parse.el
index 3566331284c..36e112e4078 100644
--- a/lisp/nxml/nxml-parse.el
+++ b/lisp/nxml/nxml-parse.el
@@ -1,6 +1,6 @@
;;; nxml-parse.el --- XML parser, sharing infrastructure with nxml-mode
-;; Copyright (C) 2003, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2007-2011 Free Software Foundation, Inc.
;; Author: James Clark
;; Keywords: XML
@@ -315,5 +315,4 @@ same way as well-formedness error."
(provide 'nxml-parse)
-;; arch-tag: fc19639b-1bff-4673-9992-f539da89ba1e
;;; nxml-parse.el ends here
diff --git a/lisp/nxml/nxml-rap.el b/lisp/nxml/nxml-rap.el
index 5816b5a3985..05df6118325 100644
--- a/lisp/nxml/nxml-rap.el
+++ b/lisp/nxml/nxml-rap.el
@@ -1,6 +1,6 @@
;;; nxml-rap.el --- low-level support for random access parsing for nXML mode
-;; Copyright (C) 2003, 2004, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003-2004, 2007-2011 Free Software Foundation, Inc.
;; Author: James Clark
;; Keywords: XML
@@ -482,5 +482,4 @@ expected `%s'"
(provide 'nxml-rap)
-;; arch-tag: cba241ec-4c59-4ef3-aa51-2cf92b3dd24f
;;; nxml-rap.el ends here
diff --git a/lisp/nxml/nxml-uchnm.el b/lisp/nxml/nxml-uchnm.el
index 418ff917a44..e96ee345ae6 100644
--- a/lisp/nxml/nxml-uchnm.el
+++ b/lisp/nxml/nxml-uchnm.el
@@ -1,6 +1,6 @@
;;; nxml-uchnm.el --- support for Unicode standard cha names in nxml-mode
-;; Copyright (C) 2003, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2007-2011 Free Software Foundation, Inc.
;; Author: James Clark
;; Keywords: XML
@@ -248,5 +248,4 @@ the variable `nxml-enabled-unicode-blocks'."
(provide 'nxml-uchnm)
-;; arch-tag: 440248c3-b604-467c-8b50-e83662c659a3
;;; nxml-uchnm.el ends here
diff --git a/lisp/nxml/nxml-util.el b/lisp/nxml/nxml-util.el
index e764d59fad3..e2e4ed348bd 100644
--- a/lisp/nxml/nxml-util.el
+++ b/lisp/nxml/nxml-util.el
@@ -1,6 +1,6 @@
;;; nxml-util.el --- utility functions for nxml-*.el
-;; Copyright (C) 2003, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2007-2011 Free Software Foundation, Inc.
;; Author: James Clark
;; Keywords: XML
@@ -132,5 +132,4 @@ modifications to the buffer."
(provide 'nxml-util)
-;; arch-tag: 7d3b3af4-de2b-4410-bf67-94d64824324b
;;; nxml-util.el ends here
diff --git a/lisp/nxml/rng-cmpct.el b/lisp/nxml/rng-cmpct.el
index 36db724d7f1..09bd2b75038 100644
--- a/lisp/nxml/rng-cmpct.el
+++ b/lisp/nxml/rng-cmpct.el
@@ -1,6 +1,6 @@
;;; rng-cmpct.el --- parsing of RELAX NG Compact Syntax schemas
-;; Copyright (C) 2003, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2007-2011 Free Software Foundation, Inc.
;; Author: James Clark
;; Keywords: XML, RelaxNG
@@ -938,4 +938,3 @@ Current token after parse is token following ]."
;;; rng-cmpct.el
-;; arch-tag: 90395eb1-283b-4146-bbc1-6d6ef1704e57
diff --git a/lisp/nxml/rng-dt.el b/lisp/nxml/rng-dt.el
index 35f55b5d9d5..e320f8377b2 100644
--- a/lisp/nxml/rng-dt.el
+++ b/lisp/nxml/rng-dt.el
@@ -1,6 +1,6 @@
;;; rng-dt.el --- datatype library interface for RELAX NG
-;; Copyright (C) 2003, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2007-2011 Free Software Foundation, Inc.
;; Author: James Clark
;; Keywords: XML, RelaxNG
@@ -61,5 +61,4 @@ a datatype library.")
(provide 'rng-dt)
-;; arch-tag: 1dca90f1-8dae-4dd4-b61f-fade4452c014
;;; rng-dt.el ends here
diff --git a/lisp/nxml/rng-loc.el b/lisp/nxml/rng-loc.el
index 9688178b22f..b9e31e0a09e 100644
--- a/lisp/nxml/rng-loc.el
+++ b/lisp/nxml/rng-loc.el
@@ -1,6 +1,6 @@
;;; rng-loc.el --- locate the schema to use for validation
-;; Copyright (C) 2003, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2007-2011 Free Software Foundation, Inc.
;; Author: James Clark
;; Keywords: XML, RelaxNG
@@ -48,7 +48,7 @@ It is nil if using a vacuous schema.")
"Schema for schema locating files or nil if not yet loaded.")
(defcustom rng-schema-locating-files rng-schema-locating-files-default
- "*List of schema locating files."
+ "List of schema locating files."
:type '(repeat file)
:group 'relax-ng)
@@ -546,5 +546,4 @@ saved to the first writable file in `rng-schema-locating-files'."
(provide 'rng-loc)
-;; arch-tag: 725cf968-37a2-418b-b47b-d5209871a9ab
;;; rng-loc.el ends here
diff --git a/lisp/nxml/rng-maint.el b/lisp/nxml/rng-maint.el
index 52268688364..d31740f0ca2 100644
--- a/lisp/nxml/rng-maint.el
+++ b/lisp/nxml/rng-maint.el
@@ -1,6 +1,6 @@
;;; rng-maint.el --- commands for RELAX NG maintainers
-;; Copyright (C) 2003, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2007-2011 Free Software Foundation, Inc.
;; Author: James Clark
;; Keywords: XML, RelaxNG
@@ -275,5 +275,4 @@
(while (rng-do-some-validation
(lambda () t))))
-;; arch-tag: 4b8c6143-daac-4888-9c61-9bea6f935f17
;;; rng-maint.el ends here
diff --git a/lisp/nxml/rng-match.el b/lisp/nxml/rng-match.el
index b49acdfb7b8..072d932678a 100644
--- a/lisp/nxml/rng-match.el
+++ b/lisp/nxml/rng-match.el
@@ -1,6 +1,6 @@
;;; rng-match.el --- matching of RELAX NG patterns against XML events
-;; Copyright (C) 2003, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2007-2011 Free Software Foundation, Inc.
;; Author: James Clark
;; Keywords: XML, RelaxNG
@@ -1736,5 +1736,4 @@ be exhaustive."
(provide 'rng-match)
-;; arch-tag: c8c50733-edcf-49fb-85e2-0aac8749b7f8
;;; rng-match.el ends here
diff --git a/lisp/nxml/rng-nxml.el b/lisp/nxml/rng-nxml.el
index e69ecdbcfa3..1686ebfc514 100644
--- a/lisp/nxml/rng-nxml.el
+++ b/lisp/nxml/rng-nxml.el
@@ -1,6 +1,6 @@
;;; rng-nxml.el --- make nxml-mode take advantage of rng-validate-mode
-;; Copyright (C) 2003, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2007-2011 Free Software Foundation, Inc.
;; Author: James Clark
;; Keywords: XML, RelaxNG
@@ -35,7 +35,7 @@
(require 'rng-loc)
(defcustom rng-nxml-auto-validate-flag t
- "*Non-nil means automatically turn on validation with nxml-mode."
+ "Non-nil means automatically turn on validation with nxml-mode."
:type 'boolean
:group 'relax-ng)
@@ -47,7 +47,7 @@
("http://www.w3.org/2001/XMLSchema-instance" . "xsi")
("http://purl.org/dc/elements/1.1/" . "dc")
("http://purl.org/dc/terms/" . "dcterms"))
- "*Alist of namespaces vs preferred prefixes."
+ "Alist of namespaces vs preferred prefixes."
:type '(repeat (cons :tag "With"
(string :tag "this namespace URI")
(string :tag "use this prefix")))
@@ -591,5 +591,4 @@ set `xmltok-dtd'. Returns the position of the end of the token."
(provide 'rng-nxml)
-;; arch-tag: bec0d6ed-6be1-4540-9c2c-6f56e8e55d8b
;;; rng-nxml.el ends here
diff --git a/lisp/nxml/rng-parse.el b/lisp/nxml/rng-parse.el
index 7e3a8cdefec..68a3aff3a0f 100644
--- a/lisp/nxml/rng-parse.el
+++ b/lisp/nxml/rng-parse.el
@@ -1,6 +1,6 @@
;;; rng-parse.el --- parse an XML file and validate it against a schema
-;; Copyright (C) 2003, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2007-2011 Free Software Foundation, Inc.
;; Author: James Clark
;; Keywords: XML, RelaxNG
@@ -100,5 +100,4 @@ be signaled in the same way as when it is not well-formed."
(provide 'rng-parse)
-;; arch-tag: 8f14f533-b687-4dc0-9cd7-617ead856981
;;; rng-parse.el ends here
diff --git a/lisp/nxml/rng-pttrn.el b/lisp/nxml/rng-pttrn.el
index 8e7139df32f..a803369d3d2 100644
--- a/lisp/nxml/rng-pttrn.el
+++ b/lisp/nxml/rng-pttrn.el
@@ -1,6 +1,6 @@
;;; rng-pttrn.el --- RELAX NG patterns
-;; Copyright (C) 2003, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2007-2011 Free Software Foundation, Inc.
;; Author: James Clark
;; Keywords: XML, RelaxNG
@@ -186,5 +186,4 @@
(provide 'rng-pttrn)
-;; arch-tag: 9418e269-ddd4-4037-861f-ff903f48f008
;;; rng-pttrn.el ends here
diff --git a/lisp/nxml/rng-uri.el b/lisp/nxml/rng-uri.el
index b4cbd9a066f..2b367b20072 100644
--- a/lisp/nxml/rng-uri.el
+++ b/lisp/nxml/rng-uri.el
@@ -1,6 +1,6 @@
;;; rng-uri.el --- URI parsing and manipulation
-;; Copyright (C) 2003, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2007-2011 Free Software Foundation, Inc.
;; Author: James Clark
;; Keywords: XML
@@ -352,5 +352,4 @@ Both FULL and BASE must be absolute URIs."
(provide 'rng-uri)
-;; arch-tag: c7b7b8b8-61d1-48ec-82bc-7001c70b2e9d
;;; rng-uri.el ends here
diff --git a/lisp/nxml/rng-util.el b/lisp/nxml/rng-util.el
index 0c4fb818a5c..3e23b67c998 100644
--- a/lisp/nxml/rng-util.el
+++ b/lisp/nxml/rng-util.el
@@ -1,6 +1,6 @@
;;; rng-util.el --- utility functions for RELAX NG library
-;; Copyright (C) 2003, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2007-2011 Free Software Foundation, Inc.
;; Author: James Clark
;; Keywords: XML, RelaxNG
@@ -167,5 +167,4 @@ HIST, if non-nil, specifies a history list as with `completing-read'."
(provide 'rng-util)
-;; arch-tag: 2dc233e0-5e7a-488f-bfc4-5909512dbaf0
;;; rng-util.el ends here
diff --git a/lisp/nxml/rng-valid.el b/lisp/nxml/rng-valid.el
index 992de5c7ab4..876e582ed21 100644
--- a/lisp/nxml/rng-valid.el
+++ b/lisp/nxml/rng-valid.el
@@ -1,6 +1,6 @@
;;; rng-valid.el --- real-time validation of XML using RELAX NG
-;; Copyright (C) 2003, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2007-2011 Free Software Foundation, Inc.
;; Author: James Clark
;; Keywords: XML, RelaxNG
@@ -110,12 +110,12 @@
:group 'relax-ng)
(defcustom rng-state-cache-distance 2000
- "*Distance in characters between each parsing and validation state cache."
+ "Distance in characters between each parsing and validation state cache."
:type 'integer
:group 'relax-ng)
(defcustom rng-validate-chunk-size 8000
- "*Number of characters in a RELAX NG validation chunk.
+ "Number of characters in a RELAX NG validation chunk.
A validation chunk will be the smallest chunk that is at least this
size and ends with a tag. After validating a chunk, validation will
continue only if Emacs is still idle."
@@ -123,14 +123,14 @@ continue only if Emacs is still idle."
:group 'relax-ng)
(defcustom rng-validate-delay 1.5
- "*Time in seconds that Emacs must be idle before starting a full validation.
+ "Time in seconds that Emacs must be idle before starting a full validation.
A full validation continues until either validation is up to date
or Emacs is no longer idle."
:type 'number
:group 'relax-ng)
(defcustom rng-validate-quick-delay 0.3
- "*Time in seconds that Emacs must be idle before starting a quick validation.
+ "Time in seconds that Emacs must be idle before starting a quick validation.
A quick validation validates at most one chunk."
:type 'number
:group 'relax-ng)
@@ -518,6 +518,9 @@ Return t if there is work to do, nil otherwise."
(goto-char pos))
(t (rng-set-initial-state))))))))))
+(defun rng-dtd-trivial-p (dtd)
+ "Check whether the current dtd is different from the trivial default."
+ (or (null dtd) (eq dtd xmltok-predefined-entity-alist)))
(defun rng-do-some-validation-1 (&optional continue-p-function)
(let ((limit (+ rng-validate-up-to-date-end
@@ -1461,5 +1464,4 @@ string between START and END."
(provide 'rng-valid)
-;; arch-tag: 7dd846d3-519d-4a6d-8107-4ff0024a60ef
;;; rng-valid.el ends here
diff --git a/lisp/nxml/rng-xsd.el b/lisp/nxml/rng-xsd.el
index e729b306718..266f8daac9e 100644
--- a/lisp/nxml/rng-xsd.el
+++ b/lisp/nxml/rng-xsd.el
@@ -1,6 +1,6 @@
;;; rng-xsd.el --- W3C XML Schema datatypes library for RELAX NG
-;; Copyright (C) 2003, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2007-2011 Free Software Foundation, Inc.
;; Author: James Clark
;; Keywords: XML, RelaxNG
@@ -856,5 +856,4 @@ MONTHS must be an integer >= 0."
(provide 'rng-xsd)
-;; arch-tag: 6b05510e-a5bb-4b99-8618-4660d00d0abb
;;; rng-xsd.el ends here
diff --git a/lisp/nxml/xmltok.el b/lisp/nxml/xmltok.el
index da8f356f9c8..a9b24955fa7 100644
--- a/lisp/nxml/xmltok.el
+++ b/lisp/nxml/xmltok.el
@@ -1,6 +1,6 @@
;;; xmltok.el --- XML tokenization
-;; Copyright (C) 2003, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2007-2011 Free Software Foundation, Inc.
;; Author: James Clark
;; Keywords: XML
@@ -1920,5 +1920,4 @@ and `xmltok-namespace-attributes'."
(provide 'xmltok)
-;; arch-tag: 747e5f3a-6fc3-4f8d-bd96-89f05aa99f5e
;;; xmltok.el ends here
diff --git a/lisp/nxml/xsd-regexp.el b/lisp/nxml/xsd-regexp.el
index 80b818e930f..fbf0e159247 100644
--- a/lisp/nxml/xsd-regexp.el
+++ b/lisp/nxml/xsd-regexp.el
@@ -1,6 +1,6 @@
;;; xsd-regexp.el --- translate W3C XML Schema regexps to Emacs regexps
-;; Copyright (C) 2003, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2007-2011 Free Software Foundation, Inc.
;; Author: James Clark
;; Keywords: XML, regexp
@@ -2117,5 +2117,4 @@ Code is inserted into the current buffer."
(provide 'xsd-regexp)
-;; arch-tag: bf990d61-a26c-4fd3-b578-56a5640729da
;;; xsd-regexp.el ends here
diff --git a/lisp/abbrevlist.el b/lisp/obsolete/abbrevlist.el
index 671289b293d..55940dfc1ce 100644
--- a/lisp/abbrevlist.el
+++ b/lisp/obsolete/abbrevlist.el
@@ -1,11 +1,12 @@
;;; abbrevlist.el --- list one abbrev table alphabetically ordered
-;; Copyright (C) 1986, 1992, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1986, 1992, 2001-2011 Free Software Foundation, Inc.
;; Suggested by a previous version by Gildea.
;; Maintainer: FSF
;; Keywords: abbrev
+;; Package: emacs
+;; Obsolete-since: 24.1
;; This file is part of GNU Emacs.
@@ -52,5 +53,4 @@
(provide 'abbrevlist)
-;; arch-tag: 178f0638-6597-4c16-bcee-576c3d8e9217
;;; abbrevlist.el ends here
diff --git a/lisp/obsolete/awk-mode.el b/lisp/obsolete/awk-mode.el
index a629b3ec67f..1a6d08c08ef 100644
--- a/lisp/obsolete/awk-mode.el
+++ b/lisp/obsolete/awk-mode.el
@@ -1,10 +1,10 @@
;;; awk-mode.el --- AWK code editing commands for Emacs
-;; Copyright (C) 1988, 1994, 1996, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1988, 1994, 1996, 2000-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: unix, languages
+;; Obsolete-since: 22.1
;; This file is part of GNU Emacs.
@@ -23,8 +23,6 @@
;;; Commentary:
-;; This file has been obsolete since Emacs 22.1.
-
;; Sets up C-mode with support for awk-style #-comments and a lightly
;; hacked syntax table.
@@ -122,5 +120,4 @@ Turning on AWK mode runs `awk-mode-hook'."
(provide 'awk-mode)
-;; arch-tag: 14ebc02a-b3c5-4e76-8034-6ca9ac0af0e6
;;; awk-mode.el ends here
diff --git a/lisp/obsolete/cl-compat.el b/lisp/obsolete/cl-compat.el
index 2d6c6416020..21bb46179c5 100644
--- a/lisp/obsolete/cl-compat.el
+++ b/lisp/obsolete/cl-compat.el
@@ -1,7 +1,6 @@
;;; cl-compat.el --- Common Lisp extensions for GNU Emacs Lisp (compatibility)
-;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2001-2011 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Version: 2.02
@@ -73,11 +72,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 +87,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 0f8e52630f6..925361566fb 100644
--- a/lisp/complete.el
+++ b/lisp/obsolete/complete.el
@@ -1,10 +1,11 @@
;;; complete.el --- partial completion mechanism plus other goodies
-;; Copyright (C) 1990, 1991, 1992, 1993, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 1999-2011 Free Software Foundation, Inc.
;; 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 +698,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)
@@ -1118,5 +1119,4 @@ This is only used by "
(provide 'complete)
-;; arch-tag: fc7e2768-ff44-4e22-b579-4d825b968458
;;; complete.el ends here
diff --git a/lisp/erc/erc-hecomplete.el b/lisp/obsolete/erc-hecomplete.el
index 0c03f10c27c..67f51d690b2 100644
--- a/lisp/erc/erc-hecomplete.el
+++ b/lisp/obsolete/erc-hecomplete.el
@@ -1,9 +1,10 @@
;;; erc-hecomplete.el --- Provides Nick name completion for ERC
-;; Copyright (C) 2001, 2002, 2004, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001-2002, 2004, 2006-2011 Free Software Foundation, Inc.
;; Author: Alex Schroeder <alex@gnu.org>
;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?ErcCompletion
+;; Obsolete-since: 24.1
;; This file is part of GNU Emacs.
@@ -108,16 +109,14 @@ add this string when a unique expansion was found."
This is a function to put on `hippie-expand-try-functions-list'.
Then use \\[hippie-expand] to expand nicks.
The type of completion depends on `erc-nick-completion'."
- (cond ((eq erc-nick-completion 'pals)
- (try-complete-erc-nick old erc-pals))
- ((eq erc-nick-completion 'all)
- (try-complete-erc-nick old (append
+ (try-complete-erc-nick old (cond ((eq erc-nick-completion 'pals) erc-pals)
+ ((eq erc-nick-completion 'all)
+ (append
(erc-get-channel-nickname-list)
- (erc-command-list))))
- ((functionp erc-nick-completion)
- (try-complete-erc-nick old (funcall erc-nick-completion)))
- (t
- (try-complete-erc-nick old erc-nick-completion))))
+ (erc-command-list)))
+ ((functionp erc-nick-completion)
+ (funcall erc-nick-completion))
+ (t erc-nick-completion))))
(defvar try-complete-erc-nick-window-configuration nil
"The window configuration for `try-complete-erc-nick'.
@@ -220,4 +219,3 @@ Window configurations are stored in
;; tab-width: 8
;; End:
-;; arch-tag: 3be13ee8-8fdb-41ab-83c2-6582c757b91e
diff --git a/lisp/obsolete/fast-lock.el b/lisp/obsolete/fast-lock.el
index 353f39273bb..9c750ca5e89 100644
--- a/lisp/obsolete/fast-lock.el
+++ b/lisp/obsolete/fast-lock.el
@@ -1,12 +1,12 @@
;;; fast-lock.el --- automagic text properties caching for fast Font Lock mode
-;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1998, 2001-2011 Free Software Foundation, Inc.
;; Author: Simon Marshall <simon@gnu.org>
;; Maintainer: FSF
;; Keywords: faces files
;; Version: 3.14
+;; Obsolete-since: 22.1
;; This file is part of GNU Emacs.
@@ -25,8 +25,6 @@
;;; Commentary:
-;; This file has been obsolete since Emacs 22.1.
-
;; Fast Lock mode is a Font Lock support mode.
;; It makes visiting a file in Font Lock mode faster by restoring its face text
;; properties from automatically saved associated Font Lock cache files.
@@ -841,7 +839,8 @@ See `fast-lock-get-face-properties'."
(add-hook 'after-save-hook 'fast-lock-save-cache-after-save-file)
(add-hook 'kill-buffer-hook 'fast-lock-save-cache-before-kill-buffer)
-(add-hook 'kill-emacs-hook 'fast-lock-save-caches-before-kill-emacs)
+(unless noninteractive
+ (add-hook 'kill-emacs-hook 'fast-lock-save-caches-before-kill-emacs))
;;;###autoload
(when (fboundp 'add-minor-mode)
@@ -855,5 +854,4 @@ See `fast-lock-get-face-properties'."
(provide 'fast-lock)
-;; arch-tag: 638c431e-8cae-4538-80a1-963ff97d233e
;;; fast-lock.el ends here
diff --git a/lisp/obsolete/iso-acc.el b/lisp/obsolete/iso-acc.el
index a237b17dee7..cb06091dfcf 100644
--- a/lisp/obsolete/iso-acc.el
+++ b/lisp/obsolete/iso-acc.el
@@ -1,11 +1,11 @@
;;; iso-acc.el --- minor mode providing electric accent keys
-;; Copyright (C) 1993, 1994, 1996, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1994, 1996, 2001-2011 Free Software Foundation, Inc.
;; Author: Johan Vromans
;; Maintainer: FSF
;; Keywords: i18n
+;; Obsolete-since: 22.1
;; This file is part of GNU Emacs.
@@ -24,8 +24,6 @@
;;; Commentary:
-;; This file has been obsolete since Emacs 22.1.
-
;; Function `iso-accents-mode' activates a minor mode in which
;; typewriter "dead keys" are emulated. The purpose of this emulation
;; is to provide a simple means for inserting accented characters
@@ -487,5 +485,4 @@ Noninteractively, this operates on text from START to END."
(add-hook 'minibuffer-setup-hook 'iso-acc-minibuf-setup)
-;; arch-tag: 149ff409-7c3e-4574-9b5d-ac038939c0a6
;;; iso-acc.el ends here
diff --git a/lisp/obsolete/iso-insert.el b/lisp/obsolete/iso-insert.el
index 785e372f01e..c223d096730 100644
--- a/lisp/obsolete/iso-insert.el
+++ b/lisp/obsolete/iso-insert.el
@@ -1,11 +1,11 @@
;;; iso-insert.el --- insert functions for ISO 8859/1 -*- coding: iso-8859-1;-*-
-;; Copyright (C) 1987, 1994, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1987, 1994, 2001-2011 Free Software Foundation, Inc.
;; Author: Howard Gayle
;; Maintainer: FSF
;; Keywords: i18n
+;; Obsolete-since: 22.1
;; This file is part of GNU Emacs.
@@ -24,8 +24,6 @@
;;; Commentary:
-;; This file has been obsolete since Emacs 22.1.
-
;; Provides keys for inserting ISO Latin-1 characters. They use the
;; prefix key C-x 8. Type C-x 8 C-h for a list.
@@ -629,5 +627,4 @@
(provide 'iso-insert)
-;; arch-tag: eb5f97bd-a034-4851-92ff-ab1f1bf92814
;;; iso-insert.el ends here
diff --git a/lisp/obsolete/iso-swed.el b/lisp/obsolete/iso-swed.el
index c3620711eb9..43686283e89 100644
--- a/lisp/obsolete/iso-swed.el
+++ b/lisp/obsolete/iso-swed.el
@@ -1,11 +1,11 @@
;;; iso-swed.el --- set up char tables for ISO 8859/1 for Swedish/Finnish ttys
-;; Copyright (C) 1987, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1987, 2001-2011 Free Software Foundation, Inc.
;; Author: Howard Gayle
;; Maintainer: FSF
;; Keywords: i18n
+;; Obsolete-since: 22.1
;; This file is part of GNU Emacs.
@@ -24,8 +24,6 @@
;;; Commentary:
-;; This file has been obsolete since Emacs 22.1.
-
;; Written by Howard Gayle. See case-table.el for details.
;;; Code:
@@ -149,5 +147,4 @@
(provide 'iso-swed)
-;; arch-tag: 6b3dc269-660c-44b6-a25f-680b921eaf2c
;;; iso-swed.el ends here
diff --git a/lisp/obsolete/keyswap.el b/lisp/obsolete/keyswap.el
index cb04a5858da..ec1263e5189 100644
--- a/lisp/obsolete/keyswap.el
+++ b/lisp/obsolete/keyswap.el
@@ -1,10 +1,10 @@
;;; keyswap.el --- swap BS and DEL keys -*- no-byte-compile: t -*-
-;; Copyright (C) 1992, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 2001-2011 Free Software Foundation, Inc.
;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
;; Keywords: terminals
+;; Obsolete-since: 22.1
;; This file is part of GNU Emacs.
@@ -23,8 +23,6 @@
;;; Commentary:
-;; This file has been obsolete since Emacs 22.1.
-
;; This package is meant to be called by other terminal packages.
;;; Code:
@@ -39,5 +37,4 @@
(aset the-table ?\^h ?\177)
(setq keyboard-translate-table the-table))
-;; arch-tag: 67cf7009-e23e-421c-9648-078e7277297c
;;; keyswap.el ends here
diff --git a/lisp/obsolete/lazy-lock.el b/lisp/obsolete/lazy-lock.el
index ebfe1487e0b..a04db4a0c72 100644
--- a/lisp/obsolete/lazy-lock.el
+++ b/lisp/obsolete/lazy-lock.el
@@ -1,12 +1,12 @@
;;; lazy-lock.el --- lazy demand-driven fontification for fast Font Lock mode
-;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1998, 2001-2011 Free Software Foundation, Inc.
;; Author: Simon Marshall <simon@gnu.org>
;; Maintainer: FSF
;; Keywords: faces files
;; Version: 2.11
+;; Obsolete-since: 22.1
;; This file is part of GNU Emacs.
@@ -25,8 +25,6 @@
;;; Commentary:
-;; This file has been obsolete since Emacs 22.1.
-
;; Purpose:
;;
;; Lazy Lock mode is a Font Lock support mode.
@@ -310,7 +308,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 +332,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 +352,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 +377,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 +394,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 +407,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 +417,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 +426,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 +440,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 +453,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 +1053,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/levents.el b/lisp/obsolete/levents.el
index 126b5a1f9b8..96183cadb9b 100644
--- a/lisp/obsolete/levents.el
+++ b/lisp/obsolete/levents.el
@@ -1,7 +1,6 @@
;;; levents.el --- emulate the Lucid event data type and associated functions
-;; Copyright (C) 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: emulations
@@ -290,5 +289,4 @@ GNU Emacs 19 does not currently generate process-output events."
(provide 'levents)
-;; arch-tag: a80c21da-69d7-46de-9cdb-5f68577b5525
;;; levents.el ends here
diff --git a/lisp/obsolete/lmenu.el b/lisp/obsolete/lmenu.el
index fb32c06fa21..3c188be93e2 100644
--- a/lisp/obsolete/lmenu.el
+++ b/lisp/obsolete/lmenu.el
@@ -1,7 +1,6 @@
;;; lmenu.el --- emulate Lucid's menubar support
-;; Copyright (C) 1992, 1993, 1994, 1997, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992-1994, 1997, 2001-2011 Free Software Foundation, Inc.
;; Keywords: emulations obsolete
;; Obsolete-since: 23.3
diff --git a/lisp/obsolete/lucid.el b/lisp/obsolete/lucid.el
index 2c65dacf436..d5ef629ffb4 100644
--- a/lisp/obsolete/lucid.el
+++ b/lisp/obsolete/lucid.el
@@ -1,7 +1,6 @@
;;; lucid.el --- emulate some Lucid Emacs functions
-;; Copyright (C) 1993, 1995, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1995, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: emulations
@@ -89,8 +88,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 +233,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 668a9625018..c33794f668d 100644
--- a/lisp/obsolete/old-whitespace.el
+++ b/lisp/obsolete/old-whitespace.el
@@ -1,10 +1,10 @@
;;; whitespace.el --- warn about and clean bogus whitespaces in the file
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Rajesh Vaidheeswarran <rv@gnu.org>
;; Keywords: convenience
+;; Obsolete-since: 23.1
;; This file is part of GNU Emacs.
@@ -23,8 +23,6 @@
;;; Commentary:
-;; This file has been obsolete since Emacs 23.1.
-
;; URL: http://www.dsmit.com/lisp/
;;
;; The whitespace library is intended to find and help fix five different types
@@ -725,9 +723,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 +785,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)
@@ -810,5 +807,4 @@ This is meant to be added buffer-locally to `write-file-functions'."
(provide 'whitespace)
-;; arch-tag: 4ff44e87-b63c-402d-95a6-15e51e58bd0c
;;; whitespace.el ends here
diff --git a/lisp/obsolete/options.el b/lisp/obsolete/options.el
index 5bb5dbb84bd..7c1c3552e2d 100644
--- a/lisp/obsolete/options.el
+++ b/lisp/obsolete/options.el
@@ -1,9 +1,9 @@
;;; options.el --- edit Options command for Emacs
-;; Copyright (C) 1985, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
+;; Obsolete-since: 22.1
;; This file is part of GNU Emacs.
@@ -22,8 +22,6 @@
;;; Commentary:
-;; This file has been obsolete since Emacs 22.1.
-
;; This code provides functions to list and edit the values of all global
;; option variables known to loaded Emacs Lisp code. There are two entry
;; points, `list-options' and `edit' options'. The latter enters a major
@@ -147,5 +145,4 @@ For convenience, the characters \\[backward-paragraph] and \\[forward-paragraph]
(provide 'options)
-;; arch-tag: d18211a1-f3fb-48c9-a449-d5acde406a3c
;;; options.el ends here
diff --git a/lisp/emulation/pc-mode.el b/lisp/obsolete/pc-mode.el
index fb915dbaa6d..192392d3821 100644
--- a/lisp/emulation/pc-mode.el
+++ b/lisp/obsolete/pc-mode.el
@@ -1,10 +1,10 @@
;;; pc-mode.el --- emulate certain key bindings used on PCs
-;; Copyright (C) 1995, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: emulations
+;; Obsolete-since: 24.1
;; This file is part of GNU Emacs.
@@ -53,5 +53,4 @@ C-Escape does list-buffers."
(provide 'pc-mode)
-;; arch-tag: df007c05-f885-4cd0-8c1e-487d0f8dd9c9
;;; pc-mode.el ends here
diff --git a/lisp/obsolete/pc-select.el b/lisp/obsolete/pc-select.el
new file mode 100644
index 00000000000..9a5f9e9d9dc
--- /dev/null
+++ b/lisp/obsolete/pc-select.el
@@ -0,0 +1,417 @@
+;;; pc-select.el --- emulate mark, cut, copy and paste from Motif
+;;; (or MAC GUI or MS-windoze (bah)) look-and-feel
+;;; including key bindings.
+
+;; Copyright (C) 1995-1997, 2000-2011 Free Software Foundation, Inc.
+
+;; Author: Michael Staats <michael@thp.Uni-Duisburg.DE>
+;; Keywords: convenience emulations
+;; Created: 26 Sep 1995
+;; Obsolete-since: 24.1
+
+;; 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 emulates the mark, copy, cut and paste look-and-feel of motif
+;; programs (which is the same as the MAC gui and (sorry for that) MS-Windows).
+;; It modifies the keybindings of the cursor keys and the next, prior,
+;; home and end keys. They will modify mark-active.
+;; You can still get the old behavior of cursor moving with the
+;; control sequences C-f, C-b, etc.
+;; This package uses transient-mark-mode and
+;; delete-selection-mode.
+;;
+;; In addition to that all key-bindings from the pc-mode are
+;; done here too (as suggested by RMS).
+;;
+;; As I found out after I finished the first version, s-region.el tries
+;; to do the same.... But my code is a little more complete and using
+;; delete-selection-mode is very important for the look-and-feel.
+;; Pete Forman <pete.forman@airgun.wg.waii.com> provided some motif
+;; compliant keybindings which I added. I had to modify them a little
+;; to add the -mark and -nomark functionality of cursor moving.
+;;
+;; Credits:
+;; Many thanks to all who made comments.
+;; Thanks to RMS and Ralf Muschall <prm@rz.uni-jena.de> for criticism.
+;; Kevin Cutts <cutts@ukraine.corp.mot.com> added the beginning-of-buffer
+;; and end-of-buffer functions which I modified a little.
+;; David Biesack <sasdjb@unx.sas.com> suggested some more cleanup.
+;; Thanks to Pete Forman <pete.forman@airgun.wg.waii.com>
+;; for additional motif keybindings.
+;; Thanks to jvromans@squirrel.nl (Johan Vromans) for a bug report
+;; concerning setting of this-command.
+;; Dan Nicolaescu <done@ece.arizona.ro> suggested suppressing the
+;; scroll-up/scroll-down error.
+;; Eli Barzilay (eli@cs.bgu.ac.il) suggested the sexps functions and
+;; keybindings.
+;;
+;; Ok, some details about the idea of PC Selection mode:
+;;
+;; o The standard keys for moving around (right, left, up, down, home, end,
+;; prior, next, called "move-keys" from now on) will always de-activate
+;; the mark.
+;; o If you press "Shift" together with the "move-keys", the region
+;; you pass along is activated
+;; o You have the copy, cut and paste functions (as in many other programs)
+;; which will operate on the active region
+;; It was not possible to bind them to C-v, C-x and C-c for obvious
+;; emacs reasons.
+;; They will be bound according to the "old" behavior to S-delete (cut),
+;; S-insert (paste) and C-insert (copy). These keys do the same in many
+;; other programs.
+;;
+
+;;; Code:
+
+;; Customization:
+(defgroup pc-select nil
+ "Emulate pc bindings."
+ :prefix "pc-select"
+ :group 'emulations)
+
+(define-obsolete-variable-alias 'pc-select-override-scroll-error
+ 'scroll-error-top-bottom
+ "24.1")
+(defcustom pc-select-override-scroll-error t
+ "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
+text with these commands. If you set this variable to non-nil, these
+errors are suppressed."
+ :type 'boolean
+ :group 'pc-select)
+
+(defcustom pc-select-selection-keys-only nil
+ "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."
+ :type 'boolean
+ :group 'pc-select)
+
+(defcustom pc-selection-mode-hook nil
+ "The hook to run when PC Selection mode is toggled."
+ :type 'hook
+ :group 'pc-select)
+
+(defvar pc-select-saved-settings-alist nil
+ "The values of the variables before PC Selection mode was toggled on.
+When PC Selection mode is toggled on, it sets quite a few variables
+for its own purposes. This alist holds the original values of the
+variables PC Selection mode had set, so that these variables can be
+restored to their original values when PC Selection mode is toggled off.")
+
+(defvar pc-select-map nil
+ "The keymap used as the global map when PC Selection mode is on." )
+
+(defvar pc-select-saved-global-map nil
+ "The global map that was in effect when PC Selection mode was toggled on.")
+
+(defvar pc-select-key-bindings-alist nil
+ "This alist holds all the key bindings PC Selection mode sets.")
+
+(defvar pc-select-default-key-bindings nil
+ "These key bindings always get set by PC Selection mode.")
+
+(defvar pc-select-extra-key-bindings
+ ;; The following keybindings are for standard ISO keyboards
+ ;; as they are used with IBM compatible PCs, IBM RS/6000,
+ ;; MACs, many X-Stations and probably more.
+ '(;; Commented out since it's been standard at least since Emacs-21.
+ ;;([S-insert] . yank)
+ ;;([C-insert] . copy-region-as-kill)
+ ;;([S-delete] . kill-region)
+
+ ;; The following bindings are useful on Sun Type 3 keyboards
+ ;; They implement the Get-Delete-Put (copy-cut-paste)
+ ;; functions from sunview on the L6, L8 and L10 keys
+ ;; Sam Steingold <sds@gnu.org> says that f16 is copy and f18 is paste.
+ ([f16] . copy-region-as-kill)
+ ([f18] . yank)
+ ([f20] . kill-region)
+
+ ;; The following bindings are from Pete Forman.
+ ([f6] . other-window) ; KNextPane F6
+ ([C-delete] . kill-line) ; KEraseEndLine cDel
+ ("\M-\d" . undo) ; KUndo aBS
+
+ ;; The following binding is taken from pc-mode.el
+ ;; as suggested by RMS.
+ ;; I only used the one that is not covered above.
+ ([C-M-delete] . kill-sexp)
+ ;; Next line proposed by Eli Barzilay
+ ([C-escape] . electric-buffer-list))
+ "Key bindings to set only if `pc-select-selection-keys-only' is nil.")
+
+(defvar pc-select-meta-moves-sexps-key-bindings
+ '((([M-right] . forward-sexp)
+ ([M-left] . backward-sexp))
+ (([M-right] . forward-word)
+ ([M-left] . backward-word)))
+ "The list of key bindings controlled by `pc-select-meta-moves-sexp'.
+The bindings in the car of this list get installed if
+`pc-select-meta-moves-sexp' is t, the bindings in the cadr of this
+list get installed otherwise.")
+
+;; This is for tty. We don't turn on normal-erase-is-backspace,
+;; but bind keys as pc-selection-mode did before
+;; normal-erase-is-backspace was invented, to keep us back
+;; compatible.
+(defvar pc-select-tty-key-bindings
+ '(([delete] . delete-char) ; KDelete Del
+ ([C-backspace] . backward-kill-word))
+ "The list of key bindings controlled by `pc-select-selection-keys-only'.
+These key bindings get installed when running in a tty, but only if
+`pc-select-selection-keys-only' is nil.")
+
+(defvar pc-select-old-M-delete-binding nil
+ "Holds the old mapping of [M-delete] in the `function-key-map'.
+This variable holds the value associated with [M-delete] in the
+`function-key-map' before PC Selection mode had changed that
+association.")
+
+;;;;
+;; misc
+;;;;
+
+(provide 'pc-select)
+
+(defun pc-select-define-keys (alist keymap)
+ "Make KEYMAP have the key bindings specified in ALIST."
+ (let ((lst alist))
+ (while lst
+ (define-key keymap (caar lst) (cdar lst))
+ (setq lst (cdr lst)))))
+
+(defun pc-select-restore-keys (alist keymap saved-map)
+ "Use ALIST to restore key bindings from SAVED-MAP into KEYMAP.
+Go through all the key bindings in ALIST, and, for each key
+binding, if KEYMAP and ALIST still agree on the key binding,
+restore the previous value of that key binding from SAVED-MAP."
+ (let ((lst alist))
+ (while lst
+ (when (equal (lookup-key keymap (caar lst)) (cdar lst))
+ (define-key keymap (caar lst) (lookup-key saved-map (caar lst))))
+ (setq lst (cdr lst)))))
+
+(defmacro pc-select-add-to-alist (alist var val)
+ "Ensure that ALIST contains the cons cell (VAR . VAL).
+If a cons cell whose car is VAR is already on the ALIST, update the
+cdr of that cell with VAL. Otherwise, make a new cons cell
+\(VAR . VAL), and prepend it onto ALIST."
+ (let ((elt (make-symbol "elt")))
+ `(let ((,elt (assq ',var ,alist)))
+ (if ,elt
+ (setcdr ,elt ,val)
+ (setq ,alist (cons (cons ',var ,val) ,alist))))))
+
+(defmacro pc-select-save-and-set-var (var newval)
+ "Set VAR to NEWVAL; save the old value.
+The old value is saved on the `pc-select-saved-settings-alist'."
+ `(when (boundp ',var)
+ (pc-select-add-to-alist pc-select-saved-settings-alist ,var ,var)
+ (setq ,var ,newval)))
+
+(defmacro pc-select-save-and-set-mode (mode &optional arg mode-var)
+ "Call the function MODE; save the old value of the variable MODE.
+MODE is presumed to be a function which turns on a minor mode. First,
+save the value of the variable MODE on `pc-select-saved-settings-alist'.
+Then, if ARG is specified, call MODE with ARG, otherwise call it with
+nil as an argument. If MODE-VAR is specified, save the value of the
+variable MODE-VAR (instead of the value of the variable MODE) on
+`pc-select-saved-settings-alist'."
+ (unless mode-var (setq mode-var mode))
+ `(when (fboundp ',mode)
+ (pc-select-add-to-alist pc-select-saved-settings-alist
+ ,mode-var ,mode-var)
+ (,mode ,arg)))
+
+(defmacro pc-select-restore-var (var)
+ "Restore the previous value of the variable VAR.
+Look up VAR's previous value in `pc-select-saved-settings-alist', and,
+if the value is found, set VAR to that value."
+ (let ((elt (make-symbol "elt")))
+ `(let ((,elt (assq ',var pc-select-saved-settings-alist)))
+ (unless (null ,elt)
+ (setq ,var (cdr ,elt))))))
+
+(defmacro pc-select-restore-mode (mode)
+ "Restore the previous state (either on or off) of the minor mode MODE.
+Look up the value of the variable MODE on `pc-select-saved-settings-alist'.
+If the value is non-nil, call the function MODE with an argument of
+1, otherwise call it with an argument of -1."
+ (let ((elt (make-symbol "elt")))
+ `(when (fboundp ',mode)
+ (let ((,elt (assq ',mode pc-select-saved-settings-alist)))
+ (unless (null ,elt)
+ (,mode (if (cdr ,elt) 1 -1)))))))
+
+
+;;;###autoload
+(define-minor-mode pc-selection-mode
+ "Change mark behavior to emulate Motif, Mac or MS-Windows cut and paste style.
+
+This mode enables Delete Selection mode and Transient Mark mode.
+
+The arrow keys (and others) are bound to new functions
+which modify the status of the mark.
+
+The ordinary arrow keys disable the mark.
+The shift-arrow keys move, leaving the mark behind.
+
+C-LEFT and C-RIGHT move back or forward one word, disabling the mark.
+S-C-LEFT and S-C-RIGHT move back or forward one word, leaving the mark behind.
+
+M-LEFT and M-RIGHT move back or forward one word or sexp, disabling the mark.
+S-M-LEFT and S-M-RIGHT move back or forward one word or sexp, leaving the mark
+behind. To control whether these keys move word-wise or sexp-wise set the
+variable `pc-select-meta-moves-sexps' after loading pc-select.el but before
+turning PC Selection mode on.
+
+C-DOWN and C-UP move back or forward a paragraph, disabling the mark.
+S-C-DOWN and S-C-UP move back or forward a paragraph, leaving the mark behind.
+
+HOME moves to beginning of line, disabling the mark.
+S-HOME moves to beginning of line, leaving the mark behind.
+With Ctrl or Meta, these keys move to beginning of buffer instead.
+
+END moves to end of line, disabling the mark.
+S-END moves to end of line, leaving the mark behind.
+With Ctrl or Meta, these keys move to end of buffer instead.
+
+PRIOR or PAGE-UP scrolls and disables the mark.
+S-PRIOR or S-PAGE-UP scrolls and leaves the mark behind.
+
+S-DELETE kills the region (`kill-region').
+S-INSERT yanks text from the kill ring (`yank').
+C-INSERT copies the region into the kill ring (`copy-region-as-kill').
+
+In addition, certain other PC bindings are imitated (to avoid this, set
+the variable `pc-select-selection-keys-only' to t after loading pc-select.el
+but before calling PC Selection mode):
+
+ F6 other-window
+ DELETE delete-char
+ C-DELETE kill-line
+ M-DELETE kill-word
+ C-M-DELETE kill-sexp
+ C-BACKSPACE backward-kill-word
+ M-BACKSPACE undo"
+ ;; FIXME: bring pc-bindings-mode here ?
+ nil nil nil
+
+ :group 'pc-select
+ :global t
+
+ (if pc-selection-mode
+ (if (null pc-select-key-bindings-alist)
+ (progn
+ (setq pc-select-saved-global-map (copy-keymap (current-global-map)))
+ (setq pc-select-key-bindings-alist
+ (append pc-select-default-key-bindings
+ (if pc-select-selection-keys-only
+ nil
+ pc-select-extra-key-bindings)
+ (if pc-select-meta-moves-sexps
+ (car pc-select-meta-moves-sexps-key-bindings)
+ (cadr pc-select-meta-moves-sexps-key-bindings))
+ (if (or pc-select-selection-keys-only
+ (eq window-system 'x)
+ (memq system-name '(ms-dos windows-nt)))
+ nil
+ pc-select-tty-key-bindings)))
+
+ (pc-select-define-keys pc-select-key-bindings-alist
+ (current-global-map))
+
+ (unless (or pc-select-selection-keys-only
+ (eq window-system 'x)
+ (memq system-name '(ms-dos windows-nt)))
+ ;; it is not clear that we need the following line
+ ;; I hope it doesn't do too much harm to leave it in, though...
+ (setq pc-select-old-M-delete-binding
+ (lookup-key function-key-map [M-delete]))
+ (define-key function-key-map [M-delete] [?\M-d]))
+
+ (when (and (not pc-select-selection-keys-only)
+ (or (eq window-system 'x)
+ (memq system-name '(ms-dos windows-nt)))
+ (fboundp 'normal-erase-is-backspace-mode))
+ (pc-select-save-and-set-mode normal-erase-is-backspace-mode 1
+ normal-erase-is-backspace))
+ ;; the original author also had this above:
+ ;; (setq-default normal-erase-is-backspace t)
+ ;; However, the documentation for the variable says that
+ ;; "setting it with setq has no effect", so I'm removing it.
+
+ (pc-select-save-and-set-var highlight-nonselected-windows nil)
+ (pc-select-save-and-set-var transient-mark-mode t)
+ (pc-select-save-and-set-var shift-select-mode t)
+ (pc-select-save-and-set-var mark-even-if-inactive t)
+ (pc-select-save-and-set-mode delete-selection-mode 1))
+ ;;else
+ ;; If the user turned on pc-selection-mode a second time
+ ;; do not clobber the values of the variables that were
+ ;; saved from before pc-selection mode was activated --
+ ;; just make sure the values are the way we like them.
+ (pc-select-define-keys pc-select-key-bindings-alist
+ (current-global-map))
+ (unless (or pc-select-selection-keys-only
+ (eq window-system 'x)
+ (memq system-name '(ms-dos windows-nt)))
+ ;; it is not clear that we need the following line
+ ;; I hope it doesn't do too much harm to leave it in, though...
+ (define-key function-key-map [M-delete] [?\M-d]))
+ (when (and (not pc-select-selection-keys-only)
+ (or (eq window-system 'x)
+ (memq system-name '(ms-dos windows-nt)))
+ (fboundp 'normal-erase-is-backspace-mode))
+ (normal-erase-is-backspace-mode 1))
+ (setq highlight-nonselected-windows nil)
+ (setq transient-mark-mode t)
+ (setq mark-even-if-inactive t)
+ (delete-selection-mode 1))
+ ;;else
+ (when pc-select-key-bindings-alist
+ (when (and (not pc-select-selection-keys-only)
+ (or (eq window-system 'x)
+ (memq system-name '(ms-dos windows-nt))))
+ (pc-select-restore-mode normal-erase-is-backspace-mode))
+
+ (pc-select-restore-keys
+ pc-select-key-bindings-alist (current-global-map)
+ pc-select-saved-global-map)
+
+ (pc-select-restore-var highlight-nonselected-windows)
+ (pc-select-restore-var transient-mark-mode)
+ (pc-select-restore-var shift-select-mode)
+ (pc-select-restore-var mark-even-if-inactive)
+ (pc-select-restore-mode delete-selection-mode)
+ (and pc-select-old-M-delete-binding
+ (define-key function-key-map [M-delete]
+ pc-select-old-M-delete-binding))
+ (setq pc-select-key-bindings-alist nil
+ pc-select-saved-settings-alist nil))))
+(make-obsolete 'pc-selection-mode 'delete-selection-mode "24.1")
+
+;;; pc-select.el ends here
diff --git a/lisp/pgg-def.el b/lisp/obsolete/pgg-def.el
index 703d8d5eb71..39aef5fd278 100644
--- a/lisp/pgg-def.el
+++ b/lisp/obsolete/pgg-def.el
@@ -1,11 +1,12 @@
;;; pgg-def.el --- functions/macros for defining PGG functions
-;; Copyright (C) 1999, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2002-2011 Free Software Foundation, Inc.
;; Author: Daiki Ueno <ueno@unixuser.org>
;; Created: 1999/11/02
;; Keywords: PGP, OpenPGP, GnuPG
+;; Package: pgg
+;; Obsolete-since: 24.1
;; 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/obsolete/pgg-gpg.el
index 0666b209aba..064985f4566 100644
--- a/lisp/pgg-gpg.el
+++ b/lisp/obsolete/pgg-gpg.el
@@ -1,13 +1,14 @@
;;; pgg-gpg.el --- GnuPG support for PGG.
-;; Copyright (C) 1999, 2000, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2000, 2002-2011 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
+;; Obsolete-since: 24.1
;; This file is part of GNU Emacs.
@@ -130,8 +131,7 @@
(if (and process (eq 'run (process-status process)))
(interrupt-process process))
(if (file-exists-p output-file-name)
- (let ((delete-by-moving-to-trash nil))
- (delete-file output-file-name)))
+ (delete-file output-file-name))
(set-default-file-modes orig-mode))))
(defun pgg-gpg-possibly-cache-passphrase (passphrase &optional key notruncate)
@@ -407,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/obsolete/pgg-parse.el
index 04c148ee175..3d4539d9466 100644
--- a/lisp/pgg-parse.el
+++ b/lisp/obsolete/pgg-parse.el
@@ -1,11 +1,12 @@
;;; pgg-parse.el --- OpenPGP packet parsing
-;; Copyright (C) 1999, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2002-2011 Free Software Foundation, Inc.
;; Author: Daiki Ueno <ueno@unixuser.org>
;; Created: 1999/10/28
;; Keywords: PGP, OpenPGP, GnuPG
+;; Package: pgg
+;; Obsolete-since: 24.1
;; 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/obsolete/pgg-pgp.el
index e36c1efb138..7a9c70249a1 100644
--- a/lisp/pgg-pgp.el
+++ b/lisp/obsolete/pgg-pgp.el
@@ -1,11 +1,12 @@
;;; pgg-pgp.el --- PGP 2.* and 6.* support for PGG.
-;; Copyright (C) 1999, 2000, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2000, 2002-2011 Free Software Foundation, Inc.
;; Author: Daiki Ueno <ueno@unixuser.org>
;; Created: 1999/11/02
;; Keywords: PGP, OpenPGP
+;; Package: pgg
+;; Obsolete-since: 24.1
;; This file is part of GNU Emacs.
@@ -108,8 +109,7 @@ Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"."
(if (and process (eq 'run (process-status process)))
(interrupt-process process))
(condition-case nil
- (let ((delete-by-moving-to-trash nil))
- (delete-file errors-file-name))
+ (delete-file errors-file-name)
(file-error nil)))))
(defun pgg-pgp-lookup-key (string &optional type)
@@ -216,11 +216,8 @@ passphrase cache or user."
(setq args (concat args " " (shell-quote-argument signature)))))
(setq args (concat args " " (shell-quote-argument orig-file)))
(pgg-pgp-process-region (point)(point) nil pgg-pgp-program args)
- (let ((delete-by-moving-to-trash nil))
- (delete-file orig-file))
- (if signature
- (let ((delete-by-moving-to-trash nil))
- (delete-file signature)))
+ (delete-file orig-file)
+ (if signature (delete-file signature))
(pgg-process-when-success
(goto-char (point-min))
(let ((case-fold-search t))
@@ -252,11 +249,9 @@ passphrase cache or user."
(let ((coding-system-for-write 'raw-text-dos))
(write-region start end key-file))
(pgg-pgp-process-region start end nil pgg-pgp-program args)
- (let ((delete-by-moving-to-trash nil))
- (delete-file key-file))
+ (delete-file key-file)
(pgg-process-when-success nil)))
(provide 'pgg-pgp)
-;; arch-tag: 076b7801-37b2-49a6-97c3-218fdecde33c
;;; pgg-pgp.el ends here
diff --git a/lisp/pgg-pgp5.el b/lisp/obsolete/pgg-pgp5.el
index baa0f95265d..796310bcfdc 100644
--- a/lisp/pgg-pgp5.el
+++ b/lisp/obsolete/pgg-pgp5.el
@@ -1,11 +1,12 @@
;;; pgg-pgp5.el --- PGP 5.* support for PGG.
-;; Copyright (C) 1999, 2000, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2000, 2002-2011 Free Software Foundation, Inc.
;; Author: Daiki Ueno <ueno@unixuser.org>
;; Created: 1999/11/02
;; Keywords: PGP, OpenPGP
+;; Package: pgg
+;; Obsolete-since: 24.1
;; This file is part of GNU Emacs.
@@ -124,8 +125,7 @@ Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"."
(if (and process (eq 'run (process-status process)))
(interrupt-process process))
(condition-case nil
- (let ((delete-by-moving-to-trash nil))
- (delete-file errors-file-name))
+ (delete-file errors-file-name)
(file-error nil)))))
(defun pgg-pgp5-lookup-key (string &optional type)
@@ -220,11 +220,8 @@ Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"."
(copy-file signature (setq signature (concat orig-file ".asc")))
(setq args (append args (list signature))))
(pgg-pgp5-process-region (point)(point) nil pgg-pgp5-pgpv-program args)
- (let ((delete-by-moving-to-trash nil))
- (delete-file orig-file))
- (if signature
- (let ((delete-by-moving-to-trash nil))
- (delete-file signature)))
+ (delete-file orig-file)
+ (if signature (delete-file signature))
(with-current-buffer pgg-errors-buffer
(goto-char (point-min))
(if (re-search-forward "^Good signature" nil t)
@@ -253,11 +250,9 @@ Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"."
(let ((coding-system-for-write 'raw-text-dos))
(write-region start end key-file))
(pgg-pgp5-process-region start end nil pgg-pgp5-pgpk-program args)
- (let ((delete-by-moving-to-trash nil))
- (delete-file key-file))
+ (delete-file key-file)
(pgg-process-when-success nil)))
(provide 'pgg-pgp5)
-;; arch-tag: 3dbd1073-6b3a-466c-9f55-5c587ffa6d7b
;;; pgg-pgp5.el ends here
diff --git a/lisp/pgg.el b/lisp/obsolete/pgg.el
index 26eafc132fa..42030f7d502 100644
--- a/lisp/pgg.el
+++ b/lisp/obsolete/pgg.el
@@ -1,12 +1,12 @@
;;; pgg.el --- glue for the various PGP implementations.
-;; Copyright (C) 1999, 2000, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2000, 2002-2011 Free Software Foundation, Inc.
;; Author: Daiki Ueno <ueno@unixuser.org>
;; Symmetric encryption added by: Sascha Wilde <wilde@sha-bang.de>
;; Created: 1999/10/28
;; Keywords: PGP
+;; Obsolete-since: 24.1
;; This file is part of GNU Emacs.
@@ -23,11 +23,6 @@
;; 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 is on its way to obsolescence, waiting for allout.el to
-;; switch to EPG.
-
;;; Code:
(require 'pgg-def)
@@ -36,6 +31,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 +39,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 +69,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 +469,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 +596,4 @@ within the region."
(provide 'pgg)
-;; arch-tag: 9cc705dd-1e6a-4c90-8dce-c3561f9a2cf4
;;; pgg.el ends here
diff --git a/lisp/obsolete/resume.el b/lisp/obsolete/resume.el
index 64031533dad..c9df1184d90 100644
--- a/lisp/obsolete/resume.el
+++ b/lisp/obsolete/resume.el
@@ -1,11 +1,11 @@
;;; resume.el --- process command line args from within a suspended Emacs job
-;; Copyright (C) 1992, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 2001-2011 Free Software Foundation, Inc.
;; Author: Joe Wells <jbw@bucsf.bu.edu>
;; Adapted-By: ESR
;; Keywords: processes
+;; Obsolete-since: 23.1
;; This file is part of GNU Emacs.
@@ -24,8 +24,6 @@
;;; Commentary:
-;; This file has been obsolete since Emacs 23.1.
-
;; The purpose of this library is to handle command line arguments
;; when you resume an existing Emacs job.
@@ -124,5 +122,4 @@
(provide 'resume)
-;; arch-tag: c90b2761-4803-4e58-a0ae-c4721368b628
;;; resume.el ends here
diff --git a/lisp/obsolete/rnews.el b/lisp/obsolete/rnews.el
deleted file mode 100644
index 3cde95e923c..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, 2011 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 c02c7e15083..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, 2011 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 a41674813a4..b06861c0efc 100644
--- a/lisp/s-region.el
+++ b/lisp/obsolete/s-region.el
@@ -1,11 +1,11 @@
;;; s-region.el --- set region using shift key
-;; Copyright (C) 1994, 1995, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1995, 2001-2011 Free Software Foundation, Inc.
;; 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.
@@ -120,5 +120,4 @@ to global keymap."
(provide 's-region)
-;; arch-tag: a471e912-18d7-4247-a29b-2100bca180ff
;;; s-region.el ends here
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/scribe.el b/lisp/obsolete/scribe.el
index 8820aff3ef0..1fbc9bc4158 100644
--- a/lisp/obsolete/scribe.el
+++ b/lisp/obsolete/scribe.el
@@ -1,12 +1,12 @@
;;; scribe.el --- scribe mode, and its idiosyncratic commands
-;; Copyright (C) 1985, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 2001-2011 Free Software Foundation, Inc.
;; Author: William Sommerfeld
;; (according to ack.texi)
;; Maintainer: FSF
;; Keywords: wp
+;; Obsolete-since: 22.1
;; This file is part of GNU Emacs.
@@ -25,8 +25,6 @@
;;; Commentary:
-;; This file has been obsolete since Emacs 22.1.
-
;; A major mode for editing source in written for the Scribe text formatter.
;; Knows about Scribe syntax and standard layout rules. The command to
;; run Scribe on a buffer is bogus; someone interested should fix it.
@@ -326,5 +324,4 @@ preceding text is of the form @Command."
(provide 'scribe)
-;; arch-tag: 64f454c4-7544-4ea2-9d14-f0b668f2cdc6
;;; scribe.el ends here
diff --git a/lisp/textmodes/spell.el b/lisp/obsolete/spell.el
index bccd4a5646c..ec7f912455b 100644
--- a/lisp/textmodes/spell.el
+++ b/lisp/obsolete/spell.el
@@ -1,10 +1,11 @@
;;; spell.el --- spelling correction interface for Emacs
-;; Copyright (C) 1985, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: wp, unix
+;; Obsolete-since: 23.1
+;; (not in obsolete/ directory then, but all functions marked obsolete)
;; This file is part of GNU Emacs.
@@ -37,12 +38,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)
@@ -146,27 +147,25 @@ for example, \"word\"."
(defun spell-string (string)
"Check spelling of string supplied as argument."
(interactive "sSpell string: ")
- (let ((buf (get-buffer-create " *temp*")))
- (with-current-buffer buf
- (widen)
- (erase-buffer)
- (insert string "\n")
- (if (string= "spell" spell-command)
- (call-process-region (point-min) (point-max) "spell"
- t t)
- (call-process-region (point-min) (point-max) shell-file-name
- t t nil "-c" spell-command))
- (if (= 0 (buffer-size))
- (message "%s is correct" string)
- (goto-char (point-min))
- (while (search-forward "\n" nil t)
- (replace-match " "))
- (message "%sincorrect" (buffer-substring 1 (point-max)))))))
+ (with-temp-buffer
+ (widen)
+ (erase-buffer)
+ (insert string "\n")
+ (if (string= "spell" spell-command)
+ (call-process-region (point-min) (point-max) "spell"
+ t t)
+ (call-process-region (point-min) (point-max) shell-file-name
+ t t nil "-c" spell-command))
+ (if (= 0 (buffer-size))
+ (message "%s is correct" string)
+ (goto-char (point-min))
+ (while (search-forward "\n" nil t)
+ (replace-match " "))
+ (message "%sincorrect" (buffer-substring 1 (point-max))))))
;;;###autoload
(make-obsolete 'spell-string "The `spell' package is obsolete - use `ispell'."
"23.1")
(provide 'spell)
-;; arch-tag: 7eabb848-9c76-431a-bcdb-0e0592d2db04
;;; spell.el ends here
diff --git a/lisp/emacs-lisp/sregex.el b/lisp/obsolete/sregex.el
index 3163cca3c3d..d1c80a65672 100644
--- a/lisp/emacs-lisp/sregex.el
+++ b/lisp/obsolete/sregex.el
@@ -1,11 +1,11 @@
;;; sregex.el --- symbolic regular expressions
-;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-1998, 2000-2011 Free Software Foundation, Inc.
;; Author: Bob Glickstein <bobg+sregex@zanshin.com>
;; Maintainer: Bob Glickstein <bobg+sregex@zanshin.com>
;; Keywords: extensions
+;; Obsolete-since: 24.1
;; This file is part of GNU Emacs.
@@ -604,5 +604,4 @@ has one of the following forms:
(provide 'sregex)
-;; arch-tag: 460c1f5a-eb6e-42ec-a451-ffac78bdf492
;;; sregex.el ends here
diff --git a/lisp/obsolete/swedish.el b/lisp/obsolete/swedish.el
index e753e93b113..c31af8697ef 100644
--- a/lisp/obsolete/swedish.el
+++ b/lisp/obsolete/swedish.el
@@ -1,11 +1,11 @@
;;; swedish.el --- miscellaneous functions for dealing with Swedish
-;; Copyright (C) 1988, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1988, 2001-2011 Free Software Foundation, Inc.
;; Author: Howard Gayle
;; Maintainer: FSF
;; Keywords: i18n
+;; Obsolete-since: 22.1
;; This file is part of GNU Emacs.
@@ -24,8 +24,6 @@
;;; Commentary:
-;; This file has been obsolete since Emacs 22.1.
-
;; Fixme: Is this actually used? if so, it should be in language,
;; possibly as a feature property of Swedish, probably defining a
;; `swascii' coding system.
@@ -159,5 +157,4 @@ Leaves point just after the word that looks Swedish."
(provide 'swedish)
-;; arch-tag: a117019d-acac-4ac4-8eac-0dbd49a41d32
;;; swedish.el ends here
diff --git a/lisp/obsolete/sym-comp.el b/lisp/obsolete/sym-comp.el
index c77d53c0dd2..7e9a460ea14 100644
--- a/lisp/obsolete/sym-comp.el
+++ b/lisp/obsolete/sym-comp.el
@@ -1,6 +1,6 @@
;;; sym-comp.el --- mode-dependent symbol completion
-;; Copyright (C) 2004, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2004, 2008-2011 Free Software Foundation, Inc.
;; Author: Dave Love <fx@gnu.org>
;; Keywords: extensions
@@ -227,5 +227,4 @@ completion:
(provide 'sym-comp)
-;; arch-tag: 6fcce616-f3c4-4751-94b4-710e83144124
;;; sym-comp.el ends here
diff --git a/lisp/obsolete/vc-mcvs.el b/lisp/obsolete/vc-mcvs.el
index f3859ec07df..980cdbfd71b 100644
--- a/lisp/obsolete/vc-mcvs.el
+++ b/lisp/obsolete/vc-mcvs.el
@@ -1,10 +1,10 @@
;;; vc-mcvs.el --- VC backend for the Meta-CVS version-control system
-;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2003-2011 Free Software Foundation, Inc.
;; Author: FSF (see vc.el for full credits)
;; Maintainer: None
+;; Obsolete-since: 23.1
;; This file is part of GNU Emacs.
@@ -31,9 +31,6 @@
;;
;; ********** READ THIS! **********
-;; This file has been obsolete and unsupported since Emacs 23.1.
-
-
;; The home page of the Meta-CVS version control system is at
;;
;; http://users.footprints.net/~kaz/mcvs.html
@@ -102,10 +99,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)
@@ -586,5 +582,4 @@ and that it passes `vc-mcvs-global-switches' to it before FLAGS."
;;
;; ********** READ THIS! **********
-;; arch-tag: a39c7c1c-5247-429d-88df-dd7187d2e704
;;; vc-mcvs.el ends here
diff --git a/lisp/obsolete/x-menu.el b/lisp/obsolete/x-menu.el
deleted file mode 100644
index 548679f68f6..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, 2011 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 7b5f9fc6a15..ba05f894d50 100644
--- a/lisp/org/ChangeLog
+++ b/lisp/org/ChangeLog
@@ -1,31 +1,6522 @@
+2011-03-15 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * org-src.el (org-src-switch-to-buffer):
+ * org-plot.el (org-plot/gnuplot-script, org-plot/gnuplot):
+ * org-mouse.el (org-mouse-agenda-type):
+ * org-freemind.el (org-freemind-node-to-org):
+ * ob-sql.el (org-babel-execute:sql):
+ * ob-exp.el (org-babel-exp-do-export, org-babel-exp-code):
+ * ob-ref.el (org-babel-ref-resolve): Fix use of case.
+
2011-03-07 Chong Yidong <cyd@stupidchicken.com>
* Version 23.3 released.
-2011-02-23 Juanma Barranquero <lekktu@gmail.com>
+2011-03-06 Juanma Barranquero <lekktu@gmail.com>
- * org.el (org-maybe-keyword-time-regexp):
- * org-icalendar.el (org-icalendar-store-UID):
- * org-agenda.el (org-agenda-scheduled-leaders)
- (org-agenda-deadline-leaders, org-agenda-filter-preset):
- * org-table.el (org-table-current-line-types)
- (org-table-current-begin-line, org-table-current-begin-pos):
- (org-table-current-field-formula):
+ * org.el (org-blank-before-new-entry, org-context-in-file-links)
+ (org-refile-targets, org-log-repeat, org-insert-link)
+ (org-speed-command-default-hook, org-speed-command-hook)
+ (org-in-regexps-block-p, org-yank-generic, org-goto-first-child):
Fix typos in docstrings.
+ (org-toggle-pretty-entities): Fix typo in message.
+
+2011-03-06 Juanma Barranquero <lekktu@gmail.com>
+
+ * org-id.el: Don't set `kill-emacs-hook' on noninteractive sessions.
+
+2011-02-10 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * org-remember.el (org-remember-mode-map):
+ * org-src.el (org-src-mode-map): Move initialization into declaration.
+
+2011-01-13 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * org-remember.el (org-remember-mode):
+ * org-capture.el (org-capture-mode): Don't run hook redundantly.
+
+2011-01-09 Chong Yidong <cyd@stupidchicken.com>
+
+ * org-faces.el (org-link): Inherit from link face.
+ Suggested by Joakim Verona.
+
+2010-12-11 Tassilo Horn <tassilo@member.fsf.org>
+
+ * org-footnote.el (org-footnote-create-definition): Place
+ Footnotes section before message-signature-separator also in modes
+ derived from message-mode.
+
+2010-12-11 Julien Danjou <julien@danjou.info>
+
+ * org.el (org-make-tags-matcher): Remove useless cat-p value.
+
+2010-12-11 Julien Danjou <julien@danjou.info>
+
+ * org.el (org-entry-properties): Enhance docstring.
+
+2010-12-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-list-top-point-with-indent)
+ (org-list-bottom-point-with-indent): Pay also attention to
+ 'original-indentation property of text, as blocks are put to
+ column 0 upon exporting.
+
+2010-12-11 Dan Davison <dandavison7@gmail.com>
+
+ * ob.el (org-babel-remove-temporary-directory): Handle exception
+ with message informing of failure to remove directory.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-clojure.el (org-babel-header-arg-names:clojure): Add
+ `package' to the list of Clojure header arguments which will be read
+ from heading properties.
+
+2010-12-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-inlinetask.el (org-inlinetask-export-templates): Add
+ Sébastien Vauban's suggestion for LaTeX export in docstring. This is
+ not default as it requires an additional LaTeX package: "todonotes".
+
+2010-12-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-inlinetask.el (org-inlinetask-export-templates): New variable.
+
+ * org-inlinetask.el (org-inlinetask-export-handler): Make use of
+ templates to export inline tasks.
+
+2010-12-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org.el (org-current-level): Ignore inline tasks when getting current
+ level of entry.
+
+2010-12-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org.el (org-indent-line-function): Ignore drawers inside inline
+ tasks if the line to indent isn't inside an inline task itself.
+
+2010-12-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-inlinetask.el (org-inlinetask-get-task-level): New function.
+
+ * org-indent.el (org-indent-add-properties): Find true level of
+ indentation wrt inline tasks.
+
+2010-12-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-inlinetask.el (org-inlinetask-outline-regexp): New function.
+
+ * org-inlinetask.el (org-inlinetask-goto-beginning): New function.
+
+ * org-inlinetask.el (org-inlinetask-goto-end): New function.
+
+ * org.el (org-mark-subtree): New command.
+
+ * org.el (org-speed-commands-default, org-mode-map): Make use of
+ new command.
+
+2010-12-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-inlinetask.el (org-inlinetask-export-handler): Remove protection
+ from @<span class...> so it can be removed during LaTeX export.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-insert-result): More informative code block
+ evaluation messages.
+
+2010-12-11 Matt Lundin <mdl@imapmail.org>
+
+ * org.el (org-make-heading-search-string): Optionally limit number
+ of lines stored in file link search strings.
+ (org-context-in-file-links): Add option to set to integer specifying
+ number of lines.
+
+2010-12-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-capture.el (org-capture-finalize): New prefix argument
+ STAY-WITH-CAPTURE.
+ (org-capture-refile): Improve docstring.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-sql.el (org-babel-execute:sql): Add msosql as optional sql
+ interaction engine.
+
+2010-12-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-agenda-list):
+ (org-agenda-goto-today): Use `org-today'.
+
+2010-12-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-latex.el (org-export-latex-make-header): Swap \begin{document}
+ and the title/author definitions.
+
+2010-12-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-macs.el: Better backup definition for
+ `with-silent-modifications'.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-python.el (org-babel-execute:python): Rename "prefix" to
+ "preamble".
+ (org-babel-python-evaluate): Rename "prefix" to "preamble".
+ (org-babel-python-evaluate-external-process): Rename "prefix" to
+ "preamble".
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-examplize-region): Check if `end' is a marker
+ or a point and handle appropriately.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-sql.el (org-babel-execute:sql): Explicitly set field
+ separator to \t when importing tabular data.
+
+2010-12-11 Julien Danjou <julien@danjou.info>
+
+ * org-agenda.el (org-agenda-custom-commands-local-options):
+ Allow org-agenda-span to be a symbol.
+ (org-agenda-ndays): Make obsolete.
+ (org-agenda-span): New variable superseding org-agenda-ndays.
+ (org-agenda-menu): Use org-agenda-current-span.
+ (org-agenda-current-span): New local variable storing current
+ span.
+ (org-agenda-list): Take a span instead of ndays as argument.
+ This function is now responsible for computing the ndays based
+ on span.
+ (org-agenda-ndays-to-span): Return span only if number of days
+ really matches.
+ (org-agenda-span-to-ndays): New function.
+ (org-agenda-manipulate-query): Use org-agenda-compute-starting-span.
+ (org-agenda-goto-today): Use org-agenda-compute-starting-span.
+ (org-agenda-later): Do not give compute a new span, use the
+ current one.
+ (org-agenda-day-view, org-agenda-week-view)
+ (org-agenda-month-view, org-agenda-year-view): Stop touching
+ org-agenda-ndays.
+ (org-agenda-change-time-span): Only compute starting-span.
+ (org-agenda-compute-starting-span): New function derived from
+ the old org-agenda-compute-time-span.
+ (org-agenda-set-mode-name): Compute mode based on
+ org-agenda-current-span.
+ (org-agenda-span-name): New function.
+
+2010-12-11 Robert Pluim <rpluim@gmail.com> (tiny change)
+
+ * org-agenda.el (org-agenda-toggle-deadlines): Fix docstring.
+
+2010-12-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-clock.el (org-quarter-to-date): Define variables.
+ (org-clock-special-range): Defin variables. Use org-floor*.
+ (org-clocktable-write-default): Define tcol.
+
+ * org-compat.el (org-floor*): New function.
+
+2010-12-11 Carsten Dominik <carsten.dominik@gmail.com>
+ John Wiegley <jwiegley@gmail.com>
+
+ * org-complete.el: New file.
+
+2010-12-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-clock.el (org-clocktable-write-default): Fix the % formula.
+
+2010-12-11 Matt Lundin <mdl@imapmail.org>
+
+ * org-agenda.el (org-format-agenda-item): The value of
+ org-category is not converted to a string unless it is defined.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-python.el (org-babel-execute:python): Pass the new "prefix"
+ header argument through to external evaluation.
+ (org-babel-python-evaluate): Pass the new "prefix" header argument
+ through to external evaluation.
+ (org-babel-python-evaluate-external-process): When specified prepend
+ "prefix" to the file used in external evaluation.
+
+2010-12-11 Dan Davison <dandavison7@gmail.com>
+
+ * ob-python.el (org-babel-python-evaluate-session): Change python
+ module name from 'pp' to 'pprint'.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-R.el (org-babel-R-evaluate-session): Removing empty lines
+ from R session output, these are often the result of variable
+ assignments.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-sql.el (orgtbl-to-csv): Declaring an external function to
+ fix a compiler warning.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-eval.el (require): No longer require ob.el to allow
+ requiring by ob.el.
+
+ * ob.el (ob-eval): Require ob-eval.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-confirm-evaluate): Show code block's name when
+ it is available during evaluation query.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-sql.el (org-babel-expand-body:sql): Expand the body of a sql
+ code block.
+ (org-babel-execute:sql): Use sql specific body expansion function.
+ (org-babel-sql-expand-vars): Insert variables into a sql code block.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-insert-result): Using markers instead of
+ points for more robust buffer anchors.
+
+2010-12-11 Julien Danjou <julien@danjou.info>
+
+ * org-capture.el: Use org-today.
+
+2010-12-11 Julien Danjou <julien@danjou.info>
+
+ * org-habit.el: Use org-today.
+
+2010-12-11 Julien Danjou <julien@danjou.info>
+
+ * org.el (org-auto-repeat-maybe): Use org-today.
+
+2010-12-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-clock.el (org-day-of-week): New function.
+ (org-quarter-to-date): New function.
+ (org-clock-special-range): Implement quarters.
+
+2010-12-11 Sébastien Vauban <wxhgmqzgwmuf@spammotel.com>
+
+ * org.el (org-complete-tags-always-offer-all-agenda-tags):
+ Fix docstring.
+
+2010-12-11 Julien Danjou <julien@danjou.info>
+
+ * org-agenda.el (org-format-agenda-item): Convert category to a string
+ if it is a symbol. This fixes the following call to
+ org-agenda-get-category-icon which fails if category is not a string.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-clojure.el: Updated requirements documentation to mention
+ the minimum version of Clojure.
+ (org-babel-expand-body:clojure): Fully qualified function name.
+
+2010-12-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-latex.el (org-export-latex-lists): Do not add an
+ unnecessary newline character after a list.
+
+ * org-list.el (org-list-bottom-point-with-indent): Ensure bottom
+ point is just after a non blank line.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-examplize-region): Remove old assertion which
+ no longer applies to the result insertion code.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-python.el (org-babel-execute:python): Use a :return header
+ argument for external evaluation in which the code block body need
+ to be wrapped in a function.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-clojure.el (org-babel-expand-body:clojure): Trapped free
+ variable.
+
+2010-12-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-edit-special): Edit formulas when in TBLMF line.
+
+2010-12-11 Allen S. Rout <asr@ufl.edu> (tiny change)
+
+ * org-capture.el (org-capture-after-finalize-hook): New hook.
+ (org-capture-finalize): Run the new hook.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-clojure.el (org-babel-expand-body:clojure): Support for
+ pretty printing of Clojure code and data.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-insert-result): No longer escape results which
+ will be wrapped in a block.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-eval.el (org-babel-eval-wipe-error-buffer): Fix compiler
+ warning and added documentation string.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-clojure.el (org-babel-execute:clojure): Remade using slime
+ for all code evaluation.
+
+2010-12-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-beamer.el (org-beamer-sectioning): Allow overlay arguments for
+ the column as well.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-confirm-evaluate): More descriptive message
+ when evaluation is aborted or disabled.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-insert-result): Responds to new "wrap" header
+ argument.
+ (org-babel-merge-params): Includes new "wrap" header argument in
+ one of the results header argument exclusive groups.
+
+2010-12-11 David Maus <dmaus@ictsoc.de>
+
+ * org-macs.el (with-silent-modifications): Fix condition for
+ with-silent-modification.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-parse-header-arguments): Stripping trailing
+ spaces off of header arguments (even the first one).
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-sh.el (org-babel-sh-var-to-sh): Wrap end token of heredoc in
+ single quotes which is the best practice.
+ (org-babel-sh-table-or-results): Use `org-babel-script-escape' for
+ more robust parsing of shell output.
+
+2010-12-11 Dan Davison <dandavison7@gmail.com>
+
+ * org.el (org-additional-option-like-keywords): Add more keywords,
+ and colons to some old ones.
+
+2010-12-11 Dan Davison <dandavison7@gmail.com>
+
+ * ob-eval.el (org-babel-error-buffer-name): Define new variable.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-python.el (org-babel-python-table-or-string):
+ Using `org-babel-script-escape' for reading string input from scripting
+ languages.
+
+2010-12-11 Achim Gratz <Stromeko@nexgo.de> (tiny change)
+
+ * org-macs.el (org-called-interactively-p): Wrap function call in
+ with-no-warnings.
+ (with-silent-modifications): Declare macro for Emacs < 23.2.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-parse-header-arguments): Remove addition of
+ ":" to singleton first header arguments as it was leading to errors.
+
+2010-12-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-latex.el (org-export-latex-make-header): Run the title through
+ `org-export-latex-fontify-headline'.
+ (org-export-latex-fontify-headline): Do the protection of math
+ snippets also here.
+
+2010-12-11 Richard Lawrence <richard.lawrence@berkeley.edu>
+
+ * org-latex.el (org-export-as-latex): Sent the section title
+ through the preprocessor.
+
+2010-12-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-html.el (org-html-level-start): Mark listified headings
+ with a custom id.
+
+2010-12-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-open-at-point): Don't do footnote action if cursor is
+ on a bracket link.
+
+2010-12-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-edit-special): Check also for TBLFM line.
+
+2010-12-11 Achim Gratz <Stromeko@Stromeko.DE> (tiny change)
+
+ * org-clock.el (org-get-clocktable): Previous patch incorrectly
+ required whitespace in front of #+BEGIN: and #+END:.
+
+2010-12-11 Dan Davison <dandavison7@gmail.com>
+
+ * org-src.el (org-edit-src-code): Allow region to be inherited by
+ edit buffer when mark is one character beyond end of src block.
+
+2010-12-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-cycle-list-bullet): Ensure point is at bol before
+ checking item indentation.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-map-src-blocks): Move to earlier in the file
+ and now autoloading.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-ref.el (org-babel-ref-at-ref-p): Use higher level function
+ for testing list membership.
+
+ * ob.el (org-babel-read-result): Use higher level function for
+ testing list membership.
+ (org-babel-result-end): Use higher level function for testing list
+ membership.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-sqlite.el (ob-eval): Require ob-eval for external command
+ execution.
+ (org-babel-execute:sqlite): No longer uses the init option for
+ passing commands to sqlite.
+
+2010-12-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org.el (org-indent-line-function): Drawers and blocks have no
+ influence on indentation of text below. Also fix indentation
+ problem with a block at column 0 and add a special case for
+ literal examples.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-map-src-blocks): Ensure that the file argument
+ is only evaluated once.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-ref.el (org-babel-ref-resolve): Recognize `list' as a unique
+ type of data
+ (org-babel-ref-at-ref-p): Recognize `list' as a unique type of data.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-tangle.el (org-babel-load-file): Can be called interactively.
+
+2010-12-11 Carsten Dominik <carsten.dominik@gmail.com> (tiny change)
+
+ * org-table.el (orgtbl-after-send-table-hook): New hook.
+ (orgtbl-ctrl-c-ctrl-c): Run `orgtbl-after-send-table-hook' when a
+ table was sent.
+ (orgtbl-send-table): Return the number of sent tables, or nil if no
+ sending has happened.
+
+2010-12-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-get-priority-function): New option.
+ (org-get-priority): Call `org-get-priority-function' if that
+ has been set.
+
+2010-12-11 Dan Davison <dandavison7@gmail.com>
+
+ * ob-table.el (org-babel-table-truncate-at-newline): Only add
+ "..." if there is something after the newline.
+
+2010-12-11 Achim Gratz <Stromeko@nexgo.de> (tiny change)
+
+ * org-clock.el (org-get-clocktable):
+ (org-in-clocktable-p):
+ (org-clocktable-shift):
+ (org-clocktable-steps): Fix regexp to allow for indented clock tables.
+
+2010-12-11 Puneeth Chaganti <punchagan@gmail.com>
+
+ * org-exp.el (org-export-handle-include-files): Support :minlevel
+ property.
+ (org-get-file-contents): New argument minlevel to demote included
+ content.
+
+2010-12-11 Noorul Islam <noorul@noorul.com>
+
+ * org-latex.el (org-export-latex-hyperref-format): New option.
+ (org-export-latex-href-format): Rename the existing variable
+ `org-export-latex-hyperref-format' as `org-export-latex-href-format'
+ (org-export-latex-links): Use `org-export-latex-hyperref-format' and
+ `org-export-latex-href-format'.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-calc.el (org-babel-execute:calc): Ensure the *Calculator*
+ buffer exists before it is used.
+
+2010-12-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-exp.el (org-export-preprocess-string): delaying code block
+ processing a bit to allow correct list parsing in the export string.
+
+2010-12-11 Christopher Allan Webber <cwebber@dustycloud.org>
+
+ * org-agenda.el (org-agenda-timegrid-use-ampm): New option.
+ (org-agenda-time-of-day-to-ampm): New function.
+ (org-agenda-time-of-day-to-ampm-maybe): New function.
+ (org-format-agenda-item): Call org-agenda-time-of-day-to-ampm-maybe.
+
+2010-12-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-faces.el (org-cycle-level-faces): New option.
+
+ * org.el (org-get-level-face): Honor org-cycle-level-faces.
+
+2010-12-11 Julien Danjou <julien@danjou.info>
+
+ * org-agenda.el (org-agenda-today): New function.
+ (org-agenda-get-day-face): New function.
+ (org-timeline): Use org-agenda-today and org-agenda-get-day-face.
+ (org-agenda-list): Use org-agenda-today and org-agenda-get-day-face.
+ (org-todo-list): Use org-agenda-today.
+ (org-get-all-dates): Use org-agenda-today.
+ (org-agenda-day-face-function): New variable.
+ (org-agenda-get-day-face): Use org-agenda-day-face-function.
+
+2010-12-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-ctrl-c-ctrl-c): Consider sending a radio table also
+ in Org.
+
+2010-12-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-html.el (org-export-as-html): Do not treat partially
+ protected lines as if they were fully protected.
+
+2010-12-11 Dan Davison <dandavison7@gmail.com>
+
+ * org-exp.el (org-export-format-source-code-or-example):
+ Remove hard-wired configuration of minted export
+ (org-export-latex-minted-with-line-numbers): Remove variable.
+
+2010-12-11 Bastien Guerry <bzg@altern.org>
+
+ * org-clock.el (org-dblock-write:clocktable): Fix double
+ reference to `link' in let construct.
+ (org-clock-clocktable-formatter): Fix typo in docstring.
+ (org-clocktable-write-default): Fix typo in docstring.
+
+2010-12-11 David Maus <dmaus@ictsoc.de>
+
+ * org-protocol.el (org-protocol-unhex-string): Normalize percent
+ escape sequence to upper case letters.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-lob.el (org-babel-lob-get-info): including pass-through
+ header arguments in results variable header argument string.
+
+2010-12-11 David Maus <dmaus@ictsoc.de>
+
+ * org-exp.el (org-export-visible): Limit search for in-buffer options
+ beginning of first headline.
+
+2010-12-11 David Maus <dmaus@ictsoc.de>
+
+ * org.el (org-open-at-point): Remove stale link handler for news:
+ links.
+
+2010-12-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-clock.el (org-clocktable-write-default): Better handling of
+ narrowing.
+
+2010-12-11 Julien Danjou <julien@danjou.info>
+
+ * org-agenda.el (org-agenda-category-icon-alist): Fix defcustom type.
+
+2010-12-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org.el (org-indent-line-function): simplify code and remove bug that
+ would insert a tab at the beginning of the line when trying to
+ indent the item.
+
+2010-12-11 Julien Danjou <julien@danjou.info>
+
+ * org.el (org-diary-sexp-entry): Split sexp result strings at semicolon.
+
+2010-12-11 Julien Danjou <julien@danjou.info>
+
+ * org-agenda.el (org-agenda-prefix-format): Insert place holder
+ for icon.
+ (org-agenda-category-icon-alist): New option.
+ (org-agenda-get-category-icon): New function.
+ (org-format-agenda-item): Support for icons.
+ (org-compile-prefix-format): Support for icons.
+
+2010-12-11 Julien Danjou <julien@danjou.info>
+
+ * org-compat.el: Create defalias for `string-match-p' and
+ looking-at-p.
+
+2010-12-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-calc.el (org-babel-execute:calc): support for variables --
+ converts :var variables in calc variables.
+
+2010-12-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-sparse-tree): Mention [r] in dispatch menu.
+
+2010-12-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-list.el (org-list-parse-list): Use `org-looking-at-p'.
+
+2010-12-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-id.el (org-id-store-link): Test for org-mode before checking
+ for IDs.
+
+2010-12-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-shorten-string): New function.
+
+ * org-exp.el (org-export-convert-protected-spaces): New function.
+ (org-export-preprocess-string):
+ Call `org-export-convert-protected-spaces' to handle new hard spaces.
+
+2010-12-11 David Maus <dmaus@ictsoc.de>
+
+ * org.el (org-narrow-to-subtree): Check for heading that ends at end
+ of buffer.
+
+2010-11-12 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-capture.el (org-capture-templates): Remove autoload from
+ defcustom.
+
+ * ob-lisp.el (slime): Don't expect slime to be present.
+
+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):
+ Fix 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): Fix 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-modificatons'.
+ (org-indent-remove-properties): Use `with-silent-modificatons'.
+
+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): Remove 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): Fix 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): Fix order or precedence for
+ variables.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-C.el (org-babel-expand-body:c++, org-babel-C-expand):
+ * ob-R.el (org-babel-expand-body:R, org-babel-execute:R)
+ (org-babel-R-variable-assignments):
+ * ob-asymptote.el (org-babel-expand-body:asymptote)
+ (org-babel-execute:asymptote):
+ * ob-clojure.el (org-babel-expand-body:clojure)
+ (org-babel-execute:clojure):
+ * ob-css.el (org-babel-expand-body:css):
+ * ob-ditaa.el (org-babel-expand-body:ditaa):
+ * ob-dot.el (org-babel-expand-body:dot, org-babel-execute:dot):
+ * ob-emacs-lisp.el (org-babel-expand-body:emacs-lisp)
+ (org-babel-execute:emacs-lisp):
+ * ob-gnuplot.el (org-babel-expand-body:gnuplot)
+ * ob-haskell.el (org-babel-expand-body:haskell)
+ (org-babel-execute:haskell, org-babel-load-session:haskell)
+ (org-babel-prep-session:haskell):
+ * ob-js.el (org-babel-expand-body:js, org-babel-execute:js):
+ * ob-latex.el (org-babel-expand-body:latex):
+ * ob-lisp.el (org-babel-expand-body:lisp, org-babel-execute:lisp):
+ * ob-mscgen.el (org-babel-expand-body:mscgen):
+ * ob-ocaml.el (org-babel-expand-body:ocaml, org-babel-execute:ocaml):
+ * ob-octave.el (org-babel-expand-body:matlab)
+ (org-babel-expand-body:octave, org-babel-execute:octave)
+ (org-babel-octave-variable-assignments):
+ * ob-org.el (org-babel-expand-body:org):
+ * ob-perl.el (org-babel-expand-body:perl, org-babel-execute:perl):
+ * ob-plantuml.el (org-babel-expand-body:plantuml):
+ * ob-python.el (org-babel-expand-body:python, org-babel-execute:python)
+ (org-babel-python-variable-assignments):
+ * ob-ruby.el (org-babel-expand-body:ruby, org-babel-execute:ruby):
+ * ob-sass.el (org-babel-expand-body:sass):
+ * ob-scheme.el (org-babel-expand-body:scheme, org-babel-execute:scheme):
+ * ob-screen.el (org-babel-expand-body:screen):
+ * ob-sh.el (org-babel-expand-body:sh, org-babel-execute:sh)
+ (org-babel-sh-variable-assignments):
+ * ob-sql.el (org-babel-expand-body:sql):
+ * ob-sqlite.el (org-babel-expand-body:sqlite, org-babel-execute:sqlite):
+ * 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): Fix 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): Fix 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): Fix 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): Fix 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): Add 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
+ advertise %: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): Remove 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): Remove 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): Add 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): Remove 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): Remove 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): Remove 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): Remove useless hack now
+ `org-in-item-p' is fixed.
+
+ * org-timer.el (org-timer-item): Remove 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): Add 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 occurrence was enclosed.
+
+ * org-list.el (org-search-backward-unenclosed): Fix behavior when
+ last occurrence 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.
-2010-10-22 Juanma Barranquero <lekktu@gmail.com>
+ * org-docview.el: Require doc-view when compiling.
+ (doc-view-goto-page): Autoload rather than declaring.
+ (doc-view-current-page): Remove macro declaration.
- * org-exp.el (org-export-visible): Fix typo in docstring.
+ * 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.
-2010-10-12 Juanma Barranquero <lekktu@gmail.com>
+ * 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.
- * org-agenda.el (org-prefix-category-length)
- (org-prefix-category-max-length): Fix typos in docstrings.
+ * 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): Remove 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): Move 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): Remove 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): Fix 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)
@@ -52,8 +6543,8 @@
2009-11-20 Carsten Dominik <carsten.dominik@gmail.com>
- * org-agenda.el (org-agenda-diary-entry-in-org-file): Rebuild
- agenda after adding new entry.
+ * org-agenda.el (org-agenda-diary-entry-in-org-file):
+ Rebuild agenda after adding new entry.
* org-datetree.el (org-datetree-find-day-create): Fix regular
expression.
@@ -90,8 +6581,8 @@
* org-agenda.el (org-agenda-insert-diary-strategy): New variable.
(org-agenda-insert-diary-as-top-level): New function.
- (org-agenda-add-entry-to-org-agenda-diary-file): Call
- `org-agenda-insert-diary-as-top-level'.
+ (org-agenda-add-entry-to-org-agenda-diary-file):
+ Call `org-agenda-insert-diary-as-top-level'.
* org.el (org-occur-in-agenda-files): Make sure none of the
buffers is narrowed.
@@ -158,8 +6649,8 @@
* org-agenda.el (org-agenda-show-outline-path): New option.
(org-agenda-do-context-action): New function.
- (org-agenda-next-line, org-agenda-previous-line): Use
- `org-agenda-do-context-action'.
+ (org-agenda-next-line, org-agenda-previous-line):
+ Use `org-agenda-do-context-action'.
* org.el (org-use-speed-commands): Allow function value.
(org-speed-commands-default): Make headline motion safe, so that
@@ -236,8 +6727,8 @@
* org-latex.el (org-export-latex-links): Check for protectedness
in the last matched character, not after the match.
- * org-datetree.el (org-datetree-find-date-create): Respect
- restriction when KEEP-RESTRICTION is set.
+ * org-datetree.el (org-datetree-find-date-create):
+ Respect restriction when KEEP-RESTRICTION is set.
(org-datetree-file-entry-under): New function.
(org-datetree-cleanup): New command.
@@ -275,8 +6766,8 @@
* org-agenda.el (org-agenda-diary-entry-in-org-file)
(org-agenda-add-entry-to-org-agenda-diary-file)
(org-agenda-insert-diary-make-new-entry): New functions.
- (org-agenda-diary-entry): Call
- `org-agenda-diary-entry-in-org-file' when appropriate.
+ (org-agenda-diary-entry):
+ Call `org-agenda-diary-entry-in-org-file' when appropriate.
* org.el (org-calendar-insert-diary-entry-key): New option.
(org-agenda-diary-file): New option.
@@ -327,16 +6818,15 @@
2009-11-13 Dan Davison <davison@stats.ox.ac.uk>
- * 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-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.
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'.
@@ -349,14 +6839,14 @@
2009-11-13 Carsten Dominik <carsten.dominik@gmail.com>
- * org-icalendar.el (org-print-icalendar-entries): Use
- org-icalendar-verify-function only if non-nil.
+ * org-icalendar.el (org-print-icalendar-entries):
+ Use org-icalendar-verify-function only if non-nil.
* org.el (org-refile): Refile to clock only if the prefix arg is
2.
(org-sparse-tree): Fix docstring to be in line with prompt.
- (org-update-parent-todo-statistics): Call
- `org-after-todo-statistics-hook' on each level.
+ (org-update-parent-todo-statistics):
+ Call `org-after-todo-statistics-hook' on each level.
2009-11-13 Carsten Dominik <carsten.dominik@gmail.com>
@@ -387,8 +6877,8 @@
* org-clock.el (org-clock-play-sound): Expand file in
org-clock-sound, to allow ~ for home.
- * org-remember.el (org-remember-handler): Set
- text-before-node-creation even if this already looks like a node,
+ * org-remember.el (org-remember-handler):
+ Set text-before-node-creation even if this already looks like a node,
because the string might be needed on non-org-mode target files.
* org-agenda.el (org-agenda-open-link): Make this work in agenda
@@ -399,7 +6889,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>
@@ -417,12 +6907,12 @@
* org-src.el (org-src-preserve-indentation): Document that this
variable is also used during export.
- * org-exp.el (org-export-format-source-code-or-example): Preserve
- indentation if a block has a -i option, or if
+ * org-exp.el (org-export-format-source-code-or-example):
+ Preserve indentation if a block has a -i option, or if
`org-src-preserve-indentation' is set.
- * org-exp-blocks.el (org-export-blocks-preprocess): Preserve
- indentation if a block has a -i option, or if
+ * org-exp-blocks.el (org-export-blocks-preprocess):
+ Preserve indentation if a block has a -i option, or if
`org-src-preserve-indentation' is set.
2009-11-13 Carsten Dominik <carsten.dominik@gmail.com>
@@ -439,8 +6929,8 @@
(org-agenda-menu): Add the new archiving commands to the menu.
(org-agenda-archive-default)
(org-agenda-archive-default-with-confirmation): New commands.
- (org-agenda-archive, org-agenda-archive-to-archive-sibling): Just
- call `org-agenda-archive-with'.
+ (org-agenda-archive, org-agenda-archive-to-archive-sibling):
+ Just call `org-agenda-archive-with'.
(org-agenda-archive-with): New function.
* org-table.el (org-table-convert-region): Inert spaces around "|"
@@ -460,8 +6950,8 @@
IF-EXISTS, which avoids creating the attachment directory if it
does not yet exist.
- * org-agenda.el (org-agenda, org-run-agenda-series): Evaluate
- MATCH.
+ * org-agenda.el (org-agenda, org-run-agenda-series):
+ Evaluate MATCH.
2009-11-13 Carsten Dominik <carsten.dominik@gmail.com>
@@ -540,12 +7030,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
@@ -574,8 +7064,8 @@
2009-11-13 John Wiegley <jwiegley@gmail.com>
- * org-clock.el (org-clock-display, org-clock-put-overlay): Use
- `org-time-clock-use-fractional'.
+ * org-clock.el (org-clock-display, org-clock-put-overlay):
+ Use `org-time-clock-use-fractional'.
* org.el (org-time-clocksum-use-fractional)
(org-time-clocksum-fractional-format): Two new customizable
@@ -606,7 +7096,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
@@ -648,14 +7138,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
@@ -672,8 +7162,8 @@
* org-agenda.el (org-agenda-next-line): New command.
(org-agenda-previous-line): New commands.
- (org-agenda-show-and-scroll-up, org-agenda-show-scroll-down): New
- commands.
+ (org-agenda-show-and-scroll-up, org-agenda-show-scroll-down):
+ New commands.
(org-agenda-follow-mode): Do the follow immediately if the mode is
turned on here.
(previous-line, next-line): Replace keys with the corresponding
@@ -689,7 +7179,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>
@@ -704,8 +7194,8 @@
2009-11-13 John Wiegley <johnw@newartisans.com>
- * org-clock.el (org-clock-disable-clock-resolution): New
- customization variable that disable automatic clock resolution on
+ * org-clock.el (org-clock-disable-clock-resolution):
+ New customization variable that disable automatic clock resolution on
clock in.
(org-clock-in): If `org-clock-disable-clock-resolution' is set, do
not automatically resolve anything. This is does not affect
@@ -720,29 +7210,29 @@
(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.
2009-11-13 John Wiegley <johnw@newartisans.com>
- * org-agenda.el (org-agenda-auto-exclude-function): New
- customization variable for allowing the user to create an "auto
+ * org-agenda.el (org-agenda-auto-exclude-function):
+ New customization variable for allowing the user to create an "auto
exclusion" filter for doing context-aware auto tag filtering.
(org-agenda-filter-by-tag): Changes to support the use of
- `org-agenda-auto-exclude-function'. See the new manual addition,.
+ `org-agenda-auto-exclude-function'. See the new manual addition.
2009-11-13 John Wiegley <johnw@newartisans.com>
* 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>
@@ -764,7 +7254,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>
@@ -792,15 +7282,15 @@
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
resolves a clock to a specific time, closing or resuming as need
be, and possibly even starting a new clock.
(org-clock-resolve): New function used by `org-resolve-clocks'
- that sets up for the call to `org-clock-resolve-clock'. It
- determines the time to resolve to based on a single-character
+ that sets up for the call to `org-clock-resolve-clock'.
+ It determines the time to resolve to based on a single-character
selection from the user to either keep time, subtract away time or
cancel the clock.
(org-resolve-clocks): New user command which resolves dangling
@@ -909,8 +7399,8 @@
2009-11-13 Carsten Dominik <carsten.dominik@gmail.com>
* org-src.el (org-edit-src-code)
- (org-edit-src-find-region-and-lang, org-edit-src-exit): Handle
- macro editing.
+ (org-edit-src-find-region-and-lang, org-edit-src-exit):
+ Handle macro editing.
* org-agenda.el (org-prefix-category-max-length): New variable.
(org-format-agenda-item): Use `org-prefix-category-max-length'.
@@ -933,7 +7423,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
@@ -1063,12 +7553,12 @@
(org-agenda-show-new-time, org-agenda-date-prompt)
(org-agenda-schedule, org-agenda-deadline, org-agenda-action)
(org-agenda-clock-in, org-agenda-bulk-mark)
- (org-agenda-bulk-unmark, org-agenda-show-the-flagging-note): Use
- `org-get-at-bol'.
+ (org-agenda-bulk-unmark, org-agenda-show-the-flagging-note):
+ Use `org-get-at-bol'.
* org-colview.el (org-columns-display-here)
- (org-columns-edit-allowed, org-agenda-columns): Use
- `org-get-at-bol'.
+ (org-columns-edit-allowed, org-agenda-columns):
+ Use `org-get-at-bol'.
2009-10-01 Carsten Dominik <carsten.dominik@gmail.com>
@@ -1103,13 +7593,13 @@
2009-10-01 Carsten Dominik <carsten.dominik@gmail.com>
- * org-agenda.el (org-prepare-agenda): Reset
- `org-drawers-for-agenda'.
+ * org-agenda.el (org-prepare-agenda):
+ Reset `org-drawers-for-agenda'.
(org-prepare-agenda): Uniquify list of drawers.
* org.el (org-complex-heading-regexp-format): New variable.
- (org-set-regexps-and-options): Define
- `org-complex-heading-regexp-format'.
+ (org-set-regexps-and-options):
+ Define `org-complex-heading-regexp-format'.
(org-drawers-for-agenda): New variable.
(org-map-entries): Bind `org-drawers-for-agenda'.
(org-prepare-agenda-buffers): Add to `org-drawers-for-agenda'.
@@ -1154,10 +7644,10 @@
* org-archive.el (org-archive-set-tag)
(org-archive-subtree-default): New commands.
- * org-clock.el (org-clock-clocktable-default-properties): New
- option.
- (org-clock-report): Use
- `org-clock-clocktable-default-properties'.
+ * org-clock.el (org-clock-clocktable-default-properties):
+ New option.
+ (org-clock-report):
+ Use `org-clock-clocktable-default-properties'.
2009-10-01 Carsten Dominik <carsten.dominik@gmail.com>
@@ -1222,7 +7712,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>
@@ -1260,8 +7750,8 @@
2009-10-01 Carsten Dominik <carsten.dominik@gmail.com>
- * org-agenda.el (org-agenda-entry-text-exclude-regexps): New
- variable.
+ * org-agenda.el (org-agenda-entry-text-exclude-regexps):
+ New variable.
(org-agenda-entry-text-cleanup-hook): New hook.
(org-agenda-get-some-entry-text): Remove matches of
`org-agenda-entry-text-exclude-regexps' and run the hook
@@ -1411,8 +7901,8 @@
2009-09-02 Carsten Dominik <carsten.dominik@gmail.com>
- * org.el (org-eval-in-calendar): Use
- `org-select-frame-set-input-focus'.
+ * org.el (org-eval-in-calendar):
+ Use `org-select-frame-set-input-focus'.
* org-compat.el (org-select-frame-set-input-focus): New function.
@@ -1458,8 +7948,8 @@
(org-agenda-menu): Add effort setting commands to menu.
(org-agenda-set-property, org-agenda-set-effort): New functions.
- * org-latex.el (org-export-latex-tables): Fix
- `org-table-last-alignment' and `org-table-last-column-widths' if
+ * org-latex.el (org-export-latex-tables):
+ Fix `org-table-last-alignment' and `org-table-last-column-widths' if
the first column has been removed.
2009-09-02 Carsten Dominik <carsten.dominik@gmail.com>
@@ -1481,8 +7971,8 @@
(org-get-last-sibling): New function.
(org-refile): Use `org-get-next-sibling' instead of the outline
version of this function.
- (org-clean-visibility-after-subtree-move): Use
- `org-get-next-sibling' and `org-get-last-sibling' instead of the
+ (org-clean-visibility-after-subtree-move):
+ Use `org-get-next-sibling' and `org-get-last-sibling' instead of the
outline versions of these functions.
2009-09-02 Carsten Dominik <carsten.dominik@gmail.com>
@@ -1510,8 +8000,8 @@
(org-table-get-specials, org-table-rotate-recalc-marks)
(org-table-get-range, org-table-recalculate)
(org-table-edit-formulas, org-table-fedit-convert-buffer)
- (org-table-show-reference, org-table-highlight-rectangle): Don't
- use `goto-line'.
+ (org-table-show-reference, org-table-highlight-rectangle):
+ Don't use `goto-line'.
* org-src.el (org-edit-src-code, org-edit-fixed-width-region)
(org-edit-src-exit): Don't use `goto-line'.
@@ -1526,8 +8016,8 @@
* org-colview.el (org-columns, org-columns-redo)
(org-agenda-columns): Don't use `goto-line'.
- * org-colview-xemacs.el (org-columns, org-agenda-columns): Don't
- use `goto-line'.
+ * org-colview-xemacs.el (org-columns, org-agenda-columns):
+ Don't use `goto-line'.
* org-agenda.el (org-agenda-mode): Force visual line motion off.
(org-agenda-add-entry-text-maxlines): Improve docstring.
@@ -1569,8 +8059,8 @@
2009-09-02 Carsten Dominik <carsten.dominik@gmail.com>
* org-agenda.el (org-agenda-get-some-entry-text): New function.
- (org-agenda-add-entry-text): Use
- `org-agenda-get-some-entry-text'.
+ (org-agenda-add-entry-text):
+ Use `org-agenda-get-some-entry-text'.
* org.el (org-cycle-separator-lines): Update docstring.
(org-cycle-show-empty-lines): Handle negative values for
@@ -1598,10 +8088,10 @@
2009-09-02 Carsten Dominik <carsten.dominik@gmail.com>
- * org-exp.el (org-export-format-source-code-or-example): Translate
- language.
+ * 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
@@ -1625,8 +8115,8 @@
2009-09-02 Carsten Dominik <carsten.dominik@gmail.com>
- * org-remember.el (org-remember-apply-template): Use
- org-icompleting-read.
+ * org-remember.el (org-remember-apply-template):
+ Use org-icompleting-read.
* org-publish.el (org-publish): Use org-icompleting-read.
@@ -1634,11 +8124,11 @@
(org-insert-columns-dblock): Use org-icompleting-read.
* org-colview-xemacs.el (org-columns-edit-value)
- (org-columns-new, org-insert-columns-dblock): Use
- org-icompleting-read.
+ (org-columns-new, org-insert-columns-dblock):
+ Use org-icompleting-read.
- * org-attach.el (org-attach-delete-one, org-attach-open): Use
- org-icompleting-read.
+ * org-attach.el (org-attach-delete-one, org-attach-open):
+ Use org-icompleting-read.
2009-09-02 Carsten Dominik <carsten.dominik@gmail.com>
@@ -1647,8 +8137,8 @@
(org-org-menu): Add a menu entry for the new bug reporter.
(org-submit-bug-report): New command.
- * org-list.el (org-hierarchical-checkbox-statistics): Improve
- docstring.
+ * org-list.el (org-hierarchical-checkbox-statistics):
+ Improve docstring.
* org.el (org-emphasis-regexp-components): Add "`" to set of
pre-emphasis characters.
@@ -1657,16 +8147,16 @@
package.
(org-export-latex-emphasis-alist): Use \st for strikethough.
- * org-exp-blocks.el (org-export-blocks-preprocess): Use
- `indent-code-rigidly' to indent.
+ * org-exp-blocks.el (org-export-blocks-preprocess):
+ Use `indent-code-rigidly' to indent.
- * org-agenda.el (org-agenda-get-restriction-and-command): Remove
- properties only if MATCH really is a string.
+ * org-agenda.el (org-agenda-get-restriction-and-command):
+ Remove properties only if MATCH really is a string.
2009-09-02 Carsten Dominik <carsten.dominik@gmail.com>
- * org-latex.el (org-export-latex-packages-alist): Fix
- customization type.
+ * org-latex.el (org-export-latex-packages-alist):
+ Fix customization type.
* org.el (org-create-formula-image): Also use
`org-export-latex-packages-alist'.
@@ -1679,8 +8169,8 @@
* org.el (org-fast-tag-selection): Avoid text properties on tags
in the alist.
- * org-agenda.el (org-agenda-get-restriction-and-command): Avoid
- text properties on the match element.
+ * org-agenda.el (org-agenda-get-restriction-and-command):
+ Avoid text properties on the match element.
2009-09-02 Carsten Dominik <carsten.dominik@gmail.com>
@@ -1704,8 +8194,8 @@
2009-09-02 Carsten Dominik <carsten.dominik@gmail.com>
- * org.el (org-export-html-special-string-regexps): Definition
- moved into org.el.
+ * org.el (org-export-html-special-string-regexps):
+ Definition moved into org.el.
* org-exp.el (org-export-preprocess-apply-macros): Allow newlines
in macro calls.
@@ -1715,8 +8205,8 @@
* org-latex.el (org-export-latex-listings)
(org-export-latex-listings-langs): New options.
- * org-exp.el (org-export-format-source-code-or-example): Use
- listing package if requested by the user.
+ * org-exp.el (org-export-format-source-code-or-example):
+ Use listing package if requested by the user.
2009-09-02 Bastien Guerry <bzg@altern.org>
@@ -1729,7 +8219,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
@@ -1739,8 +8229,8 @@
* org.el (org-insert-heading): When respecting content, do not
convert current line to headline.
- * org-clock.el (org-clock-save-markers-for-cut-and-paste): Also
- cheeeeeck the hd marker
+ * org-clock.el (org-clock-save-markers-for-cut-and-paste):
+ Also 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.
@@ -1750,13 +8240,13 @@
* 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.
* org-agenda.el (org-agenda-bulk-marked-p): New function.
- (org-agenda-bulk-mark, org-agenda-bulk-unmark): Use
- `org-agenda-bulk-marked-p'.
+ (org-agenda-bulk-mark, org-agenda-bulk-unmark):
+ Use `org-agenda-bulk-marked-p'.
(org-agenda-bulk-toggle): New command.
2009-09-02 Carsten Dominik <carsten.dominik@gmail.com>
@@ -1822,8 +8312,8 @@
2009-08-06 Carsten Dominik <carsten.dominik@gmail.com>
- * org-list.el (org-list-send-list): Call
- `org-list-goto-true-beginning' instead of
+ * org-list.el (org-list-send-list):
+ Call `org-list-goto-true-beginning' instead of
`org-list-find-true-beginning', which does not exist.
* org-timer.el (org-timer-reset-timers): Use `mapc'.
@@ -1841,8 +8331,8 @@
(org-startup-options): Add new options indent and noindent.
(org-unfontify-region): Remove line-prefix and wrap-prefix
properties.
- (org-after-demote-entry-hook, org-after-promote-entry-hook): New
- hooks.
+ (org-after-demote-entry-hook, org-after-promote-entry-hook):
+ New hooks.
(org-promote, org-demote): Run the new hooks.
* org-table.el (org-table-align): Replace leading \n as well.
@@ -1885,8 +8375,8 @@
2009-08-06 Carsten Dominik <carsten.dominik@gmail.com>
- * org-table.el (org-table-cut-region, org-table-copy-region): Work
- on single field if no active region.
+ * org-table.el (org-table-cut-region, org-table-copy-region):
+ Work on single field if no active region.
2009-08-06 Carsten Dominik <carsten.dominik@gmail.com>
@@ -1928,8 +8418,8 @@
* org.el (org-store-link): Never store a link to an inline task.
- * org-footnote.el (org-footnote-goto-local-insertion-point): Skip
- inline tasks when positioning footnotes.
+ * org-footnote.el (org-footnote-goto-local-insertion-point):
+ Skip inline tasks when positioning footnotes.
* org.el (org-refile): Remove the END line when archiving an
inline task that does have an END line.
@@ -1962,9 +8452,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'.
@@ -1975,8 +8465,8 @@
2009-08-06 Bastien Guerry <bzg@altern.org>
- * org-protocol.el (org-protocol-default-template-key): New
- option.
+ * org-protocol.el (org-protocol-default-template-key):
+ New option.
* org.el (org-refile): Bugfix: save-excursion before reading the
refile target, otherwise cursor moves might confuse `org-refile'.
@@ -2004,8 +8494,8 @@
* org.el (org-mode-map): New key for org-timer-set-timer.
* org-timer.el (org-timer-reset-timers)
- (org-timer-show-remaining-time, org-timer-set-timer): New
- functions.
+ (org-timer-show-remaining-time, org-timer-set-timer):
+ New functions.
* org-clock.el (org-show-notification): Update the docstring.
@@ -2074,8 +8564,8 @@
* org.el (org-get-refile-targets): Fix bug: don't ignore case when
building the list of targets.
- * org-remember.el (org-remember-delete-empty-lines-at-end): New
- option.
+ * org-remember.el (org-remember-delete-empty-lines-at-end):
+ New option.
(org-remember-handler): Use the new option.
2009-08-06 James TD Smith <ahktenzero@mohorovi.cc>
@@ -2102,8 +8592,8 @@
* org-latex.el (org-export-latex-first-lines): Fix problem with
publishing the region.
- * org-exp.el (org-export-format-source-code-or-example): Fix
- bad line numbering when exporting examples in HTML.
+ * org-exp.el (org-export-format-source-code-or-example):
+ Fix bad line numbering when exporting examples in HTML.
2009-08-06 James TD Smith <ahktenzero@mohorovi.cc>
@@ -2149,8 +8639,8 @@
* org-exp.el (org-infile-export-plist): Read BIND lines.
(org-install-letbind): New function.
- (org-export-as-org, org-export-preprocess-string): Call
- `org-install-letbind'.
+ (org-export-as-org, org-export-preprocess-string):
+ Call `org-install-letbind'.
* org-list.el (org-list-demote-modify-bullet): New option.
(org-first-list-item-p): Save point.
@@ -2167,8 +8657,8 @@
* org-footnote.el (org-footnote-auto-adjust): New option.
(org-footnote-auto-adjust-maybe): New function.
- (org-footnote-new, org-footnote-delete): Call
- `org-footnote-auto-adjust-maybe'.
+ (org-footnote-new, org-footnote-delete):
+ Call `org-footnote-auto-adjust-maybe'.
* org.el (org-startup-options): Add new footnote-related
keywords.
@@ -2331,16 +8821,16 @@
in column values.
(org-columns-capture-view): Exclude comment and archived trees.
- * org-colview-xemacs.el (org-columns-capture-view): Protect
- vertical bars in column values.
+ * org-colview-xemacs.el (org-columns-capture-view):
+ Protect vertical bars in column values.
(org-columns-capture-view): Exclude comment and archived trees.
* org.el (org-quote-vert): New function.
* org-latex.el (org-export-latex-verbatim-wrap): New option.
- * org-exp.el (org-export-format-source-code-or-example): Use
- `org-export-latex-verbatim-wrap'.
+ * org-exp.el (org-export-format-source-code-or-example):
+ Use `org-export-latex-verbatim-wrap'.
* org.el (org-clone-subtree-with-time-shift): Also shift inactive
time stamps.
@@ -2372,8 +8862,8 @@
2009-08-06 Carsten Dominik <carsten.dominik@gmail.com>
- * org-icalendar.el (org-icalendar-include-bbdb-anniversaries): New
- option.
+ * org-icalendar.el (org-icalendar-include-bbdb-anniversaries):
+ New option.
(org-export-icalendar): Call `org-bbdb-anniv-export-ical'.
* org-bbdb.el (org-bbdb-anniv-export-ical): New function.
@@ -2395,8 +8885,8 @@
* org-remember.el (org-remember-handler): Abort remember if the
buffer is empty.
- * org-exp.el (org-export-format-source-code-or-example): Run
- `org-src-mode-hook'.
+ * org-exp.el (org-export-format-source-code-or-example):
+ Run `org-src-mode-hook'.
2009-08-06 Carsten Dominik <carsten.dominik@gmail.com>
@@ -2413,8 +8903,8 @@
* org-macs.el (org-replace-match-keep-properties): New function.
- * org-exp.el (org-export-mark-blockquote-verse-center): Better
- preprocessing of center and quote and verse blocks.
+ * org-exp.el (org-export-mark-blockquote-verse-center):
+ Better preprocessing of center and quote and verse blocks.
* org-list.el (org-list-end): Respect the stored "original"
indentation when determining the end of the list.
@@ -2437,8 +8927,8 @@
2009-08-06 Carsten Dominik <carsten.dominik@gmail.com>
- * org-exp.el (org-export-format-source-code-or-example): Remember
- the original indentation of source code snippets and examples.
+ * org-exp.el (org-export-format-source-code-or-example):
+ Remember the original indentation of source code snippets and examples.
* org-latex.el (org-export-as-latex): Relocate the table of
contents.
@@ -2473,8 +8963,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.
@@ -2514,35 +9004,35 @@
(org-table-edit-formulas, orgtbl-ctrl-c-ctrl-c)
(orgtbl-gather-send-defs): Allow indented #+TBLFM line.
- * org.el (org-fontify-meta-lines, org-ctrl-c-ctrl-c): Allow
- indented #+TBLFM line.
+ * org.el (org-fontify-meta-lines, org-ctrl-c-ctrl-c):
+ Allow indented #+TBLFM line.
- * org-footnote.el (org-footnote-goto-local-insertion-point): Allow
- indented #+TBLFM line.
+ * org-footnote.el (org-footnote-goto-local-insertion-point):
+ Allow indented #+TBLFM line.
* org-colview.el (org-dblock-write:columnview): Allow indented
#+TBLFM line.
- * org-colview-xemacs.el (org-dblock-write:columnview): Allow
- indented #+TBLFM line.
+ * org-colview-xemacs.el (org-dblock-write:columnview):
+ Allow indented #+TBLFM line.
* org-clock.el (org-dblock-write:clocktable): Allow indented
#+TBLFM line.
2009-08-06 Carsten Dominik <carsten.dominik@gmail.com>
- * org-exp.el (org-export-format-source-code-or-example): Make
- editing indented blocks work correctly.
+ * org-exp.el (org-export-format-source-code-or-example):
+ Make editing indented blocks work correctly.
* org.el (org-edit-src-nindent): New variable.
(org-edit-src-code, org-edit-fixed-width-region)
- (org-edit-src-find-region-and-lang, org-edit-src-exit): Make
- editing indented blocks work correctly.
+ (org-edit-src-find-region-and-lang, org-edit-src-exit):
+ Make editing indented blocks work correctly.
2009-08-06 Carsten Dominik <carsten.dominik@gmail.com>
- * org-exp.el (org-export-replace-src-segments-and-examples): Find
- indented blocks.
+ * org-exp.el (org-export-replace-src-segments-and-examples):
+ Find indented blocks.
(org-export-format-source-code-or-example): Fix indentation of
blocks.
(org-export-remove-indentation): New function.
@@ -2555,24 +9045,24 @@
(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>
* org.el (org-treat-insert-todo-heading-as-state-change)
- (org-treat-S-cursor-todo-selection-as-state-change): New
- variables.
- (org-insert-todo-heading): Honor
- `org-treat-insert-todo-heading-as-state-change'.
- (org-shiftright, org-shiftleft): Honor
- `org-treat-S-cursor-todo-selection-as-state-change'.
+ (org-treat-S-cursor-todo-selection-as-state-change):
+ New variables.
+ (org-insert-todo-heading):
+ Honor `org-treat-insert-todo-heading-as-state-change'.
+ (org-shiftright, org-shiftleft):
+ Honor `org-treat-S-cursor-todo-selection-as-state-change'.
(org-inhibit-logging): New variable.
2009-08-06 Carsten Dominik <carsten.dominik@gmail.com>
- * org-agenda.el (org-remove-subtree-entries-from-agenda): Reduce
- range for marker position checking.
+ * org-agenda.el (org-remove-subtree-entries-from-agenda):
+ Reduce range for marker position checking.
* org-latex.el (org-export-latex-first-lines): Fix bug when
exporting a region.
@@ -2595,8 +9085,8 @@
* org-latex.el (org-export-latex-low-levels): Fix customization
type.
- * org.el (org-priority, org-shiftup, org-shiftdown): Disable
- priority commands.
+ * org.el (org-priority, org-shiftup, org-shiftdown):
+ Disable priority commands.
* org-agenda.el (org-agenda-priority): Disable priority commands.
@@ -2611,17 +9101,17 @@
* org-exp.el (org-export-push-to-kill-ring): New function.
(org-export-copy-to-kill-ring): New option.
- * org-latex.el (org-export-as-latex): Call
- `org-export-push-to-kill-ring'.
+ * org-latex.el (org-export-as-latex):
+ Call `org-export-push-to-kill-ring'.
- * org-exp.el (org-export-show-temporary-export-buffer): New
- option.
+ * org-exp.el (org-export-show-temporary-export-buffer):
+ New option.
- * org-latex.el (org-export-as-latex): Use
- `org-export-show-temporary-export-buffer'.
+ * org-latex.el (org-export-as-latex):
+ Use `org-export-show-temporary-export-buffer'.
- * org-exp.el (org-export-show-temporary-export-buffer): New
- option.
+ * org-exp.el (org-export-show-temporary-export-buffer):
+ New option.
(org-export-push-to-kill-ring): New function.
* org-colview.el (org-columns-compile-map): New variable.
@@ -2684,8 +9174,8 @@
* org-latex.el (org-export-latex-complex-heading-re): New variable.
(org-export-as-latex): Force the correct regexp in the
preprocessor buffer.
- (org-export-latex-set-initial-vars): Set
- `org-export-latex-complex-heading-re'.
+ (org-export-latex-set-initial-vars):
+ Set `org-export-latex-complex-heading-re'.
* org-agenda.el (org-agenda-start-with-log-mode): New option.
(org-agenda-mode): Use `org-agenda-start-with-log-mode'.
@@ -2719,7 +9209,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'.
@@ -2768,8 +9258,8 @@
* org-clock.el (org-clock-insert-selection-line): Fix prefious
patch.
- * org.el (org-edit-src-code, org-edit-fixed-width-region): Use
- separate buffer instead of indirect buffer to edit source code.
+ * org.el (org-edit-src-code, org-edit-fixed-width-region):
+ Use separate buffer instead of indirect buffer to edit source code.
(org-edit-src-exit): Make this function work with the new setup.
* org-clock.el (org-clock-insert-selection-line): Make sure tasks
@@ -2785,14 +9275,14 @@
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.
* org-list.el (org-reset-checkbox-state-subtree): Move here from
org-checklist.el.
- (org-reset-checkbox-state-subtree): Call
- `org-reset-checkbox-state-subtree'.
+ (org-reset-checkbox-state-subtree):
+ Call `org-reset-checkbox-state-subtree'.
* org-remember.el (org-select-remember-template): For the
selection of a valid template.
@@ -2805,7 +9295,7 @@
(org-export-latex-first-lines): New argument END, to force the end
of the region.
(org-export-region-as-latex): Use the property list.
- (org-export-as-latex):
+ (org-export-as-latex): ????
* org-colview-xemacs.el (org-columns-remove-overlays)
(org-columns): Fix call to `local-variable-p'.
@@ -2860,11 +9350,11 @@
* org.el (org-prepare-agenda-buffers): Catch a throw to nextfile.
* org-protocol.el: Remove dependency on url.el.
- (org-protocol-unhex-compound, org-protocol-open-source): Remove
- dependency on url.el.
+ (org-protocol-unhex-compound, org-protocol-open-source):
+ Remove dependency on url.el.
- * org-latex.el (org-export-as-pdf): Use
- `org-latex-to-pdf-process'.
+ * org-latex.el (org-export-as-pdf):
+ Use `org-latex-to-pdf-process'.
2009-08-06 Carsten Dominik <carsten.dominik@gmail.com>
@@ -2872,8 +9362,8 @@
* org-agenda.el (org-agenda-skip-additional-timestamps-same-entry):
New option.
- (org-agenda-get-timestamps): Honor
- `org-agenda-skip-additional-timestamps-same-entry'.
+ (org-agenda-get-timestamps):
+ Honor `org-agenda-skip-additional-timestamps-same-entry'.
* org-clock.el (org-clock-goto-may-find-recent-task): New option.
(org-clock-goto): Find recent task only if
@@ -2898,8 +9388,8 @@
* org.el (org-tab-first-hook)
(org-tab-after-check-for-table-hook)
(org-tab-after-check-for-cycling-hook): New hooks.
- (org-cycle-internal-global, org-cycle-internal-local): New
- functions, split out from `org-cycle'.
+ (org-cycle-internal-global, org-cycle-internal-local):
+ New functions, split out from `org-cycle'.
(org-cycle): Call the new hooks.
2009-08-06 Carsten Dominik <carsten.dominik@gmail.com>
@@ -2907,13 +9397,13 @@
* org-exp.el (org-export-preprocess-string): Reset the list of
preferred targets for each run of the preprocessor.
- * org.el (org-refile-target-verify-function): Improve
- documentation.
+ * org.el (org-refile-target-verify-function):
+ Improve documentation.
(org-get-refile-targets): Respect point being moved by the
verification function.
- * org-latex.el (org-export-latex-timestamp-keyword-markup): New
- option.
+ * org-latex.el (org-export-latex-timestamp-keyword-markup):
+ New option.
(org-export-latex-keywords): Use new option.
* org.el (org-rear-nonsticky-at): New defsubst.
@@ -2926,8 +9416,8 @@
2009-08-06 Carsten Dominik <carsten.dominik@gmail.com>
* org-protocol.el (server-edit): Declare `server-edit'.
- (org-protocol-unhex-string, org-protocol-unhex-compound): New
- functions.
+ (org-protocol-unhex-string, org-protocol-unhex-compound):
+ New functions.
(org-protocol-check-filename-for-protocol): Call `server-edit'.
* org.el (org-default-properties): New default properteis for
@@ -3108,15 +9598,15 @@
* org-agenda.el (org-agenda-confirm-kill)
(org-agenda-custom-commands-local-options)
(org-timeline-show-empty-dates, org-agenda-ndays)
- (org-agenda-start-on-weekday, org-scheduled-past-days): Fix
- customization type from number to integer.
+ (org-agenda-start-on-weekday, org-scheduled-past-days):
+ Fix customization type from number to integer.
2009-08-06 Carsten Dominik <carsten.dominik@gmail.com>
* org-protocol.el: Declare some functions.
- * org-agenda.el (org-agenda-compare-effort): Honor
- `org-sort-agenda-noeffort-is-high'.
+ * org-agenda.el (org-agenda-compare-effort):
+ Honor `org-sort-agenda-noeffort-is-high'.
(org-agenda-filter-by-tag, org-agenda-filter-make-matcher)
(org-agenda-compare-effort): Implement the "?" operator for
finding entries without effort setting.
@@ -3140,7 +9630,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.
@@ -3150,7 +9640,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.
@@ -3219,8 +9709,8 @@
* org-mac-message.el (org-mac-flagged-mail): New group.
(org-mac-mail-account): New variable.
- (org-mac-create-flagged-mail, org-mac-insert-flagged-mail): New
- commands.
+ (org-mac-create-flagged-mail, org-mac-insert-flagged-mail):
+ New commands.
* org-remember.el (org-remember-backup-directory): New variable.
(org-remember-apply-template): Write file to backup directory.
@@ -3232,16 +9722,16 @@
(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-previous-field, org-table-beginning-of-field): Better
- error messages.
+ (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'.
- * org.el (org-backward-sentence, org-forward-sentence): New
- commands.
+ * org.el (org-backward-sentence, org-forward-sentence):
+ New commands.
- * org-colview.el (org-colview-initial-truncate-line-value): New
- variable.
+ * org-colview.el (org-colview-initial-truncate-line-value):
+ New variable.
(org-columns-remove-overlays): Restore the value of `truncate-lines'.
(org-columns): Remember the value of `truncate-lines'.
@@ -3297,11 +9787,11 @@
sub-projects.
(org-agenda-skip-entry-when-regexp-matches)
(org-agenda-skip-entry-when-regexp-matches-in-subtree): New functions.
- (org-agenda-list-stuck-projects): Use
- `org-agenda-skip-entry-when-regexp-matches-in-subtree'.
+ (org-agenda-list-stuck-projects):
+ Use `org-agenda-skip-entry-when-regexp-matches-in-subtree'.
- * org-latex.el (org-export-latex-preprocess): Improve
- export of verses.
+ * org-latex.el (org-export-latex-preprocess):
+ Improve export of verses.
* org-exp.el (org-export-as-html): Implement centering as a div
rather than a paragraph. Do a better job with line-end in verse
@@ -3316,8 +9806,8 @@
* org-latex.el (org-export-latex-preprocess): Implement the
centering markup.
- * org-exp.el (org-export-mark-blockquote-verse-center): Rename
- from `org-export-mark-blockquote-and-verse'.
+ * org-exp.el (org-export-mark-blockquote-verse-center):
+ Rename from `org-export-mark-blockquote-and-verse'.
(org-export-as-html): Implement the centering markup.
* org-latex.el (org-export-latex-tables): Fix vertical
@@ -3343,16 +9833,16 @@
2009-08-06 Carsten Dominik <carsten.dominik@gmail.com>
- * org-latex.el (org-export-latex-emphasis-alist): Better
- defaults for verbose emphasis.
+ * org-latex.el (org-export-latex-emphasis-alist):
+ Better defaults for verbose emphasis.
(org-export-latex-emph-format): New function.
(org-export-latex-fontify): Call `org-export-latex-emph-format'.
* org-agenda.el (org-agenda-menu): Add new commands to menu.
(org-agenda-do-date-later, org-agenda-do-date-earlier)
(org-agenda-date-later-minutes, org-agenda-date-earlier-minutes)
- (org-agenda-date-later-hours, org-agenda-date-earlier-hours): New
- commands.
+ (org-agenda-date-later-hours, org-agenda-date-earlier-hours):
+ New commands.
* org.el (org-timestamp-change): Move end-time along with start
time.
@@ -3384,8 +9874,8 @@
(org-publish-projects, org-publish-org-index): Change default anme
for the index of file names to "sitemap.org".
- * org-latex.el (org-export-latex-tables): Use
- `org-split-string', for Emacs 21 compatibility.
+ * org-latex.el (org-export-latex-tables):
+ Use `org-split-string', for Emacs 21 compatibility.
2009-08-06 Carsten Dominik <carsten.dominik@gmail.com>
@@ -3398,13 +9888,13 @@
(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
- option.
- (org-agenda-add-entry-text): Honor
- `org-agenda-add-entry-text-descriptive-links'.
+ * org-agenda.el (org-agenda-add-entry-text-descriptive-links):
+ New option.
+ (org-agenda-add-entry-text):
+ Honor `org-agenda-add-entry-text-descriptive-links'.
* org-latex.el (org-export-latex-preprocess): Make all
external preprocess functions use a PARAMETER arg.
@@ -3423,8 +9913,8 @@
`org-export-html-style-include-scripts'.
(org-export-as-html): Honor new option
`org-export-html-style-include-scripts'.
- (org-export-html-scripts, org-export-html-style-default): Fix
- xml issues with the Safari browser.
+ (org-export-html-scripts, org-export-html-style-default):
+ Fix xml issues with the Safari browser.
2009-08-06 Carsten Dominik <carsten.dominik@gmail.com>
@@ -3441,8 +9931,8 @@
2009-08-06 Carsten Dominik <carsten.dominik@gmail.com>
- * org-exp.el (org-export-format-source-code-or-example): Mark
- temporary buffer unmodified, so that it will be killed even if
+ * org-exp.el (org-export-format-source-code-or-example):
+ Mark temporary buffer unmodified, so that it will be killed even if
mode like message mode has decided to assign a file name.
* org.el (org-scan-tags): Improve tag inheritance.
@@ -3461,8 +9951,8 @@
* org.el (org-add-planning-info): Fix bug with looking for keyword
only at column 0.
- * org-agenda.el (org-agenda-custom-commands-local-options): Add
- option for tags filter preset.
+ * org-agenda.el (org-agenda-custom-commands-local-options):
+ Add option for tags filter preset.
(org-prepare-agenda): Store filter preset as a property on the
filter variable.
(org-finalize-agenda): Call the filter, if there is a preset.
@@ -3481,8 +9971,8 @@
(org-agenda-fontify-priorities): Rename from
org-fontify-priorities.
- * org.el (org-set-font-lock-defaults): Call
- `org-font-lock-add-priority-faces'.
+ * org.el (org-set-font-lock-defaults):
+ Call `org-font-lock-add-priority-faces'.
(org-font-lock-add-priority-faces): New function.
* org-faces.el (org-set-tag-faces): New option.
@@ -3539,8 +10029,8 @@
* org.el (org-blank-before-new-entry): Mention the dependence on
`org-empty-line-terminates-plain-lists' in the docstring.
- * org-publish.el (org-publish-get-project-from-filename): New
- optional argument UP. Only find the top project if UP is set.
+ * org-publish.el (org-publish-get-project-from-filename):
+ New optional argument UP. Only find the top project if UP is set.
(org-publish-current-project): Find the top encloding project.
* org-agenda.el (org-agenda-before-write-hook)
@@ -3554,15 +10044,15 @@
* org-exp.el (org-export-ascii-links-to-notes): New option.
(org-export-as-ascii): Handle links better.
- (org-export-ascii-wrap, org-export-ascii-push-links): New
- functions.
+ (org-export-ascii-wrap, org-export-ascii-push-links):
+ New functions.
2009-08-06 Carsten Dominik <carsten.dominik@gmail.com>
* org-agenda.el (org-agenda): Make prefix arg optional.
(org-agenda-search-headline-for-time): New option.
- (org-format-agenda-item): Honor
- `org-agenda-search-headline-for-time'.
+ (org-format-agenda-item):
+ Honor `org-agenda-search-headline-for-time'.
* org-table.el (orgtbl-self-insert-command): Cluster undo for 20
characters.
@@ -3584,9 +10074,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'.
@@ -3633,8 +10123,8 @@
2009-02-19 Carsten Dominik <dominik@science.uva.nl>
- * org.el (org-block-todo-from-children-or-siblings): Use
- `org-up-heading-all' so that this will work correctly with hidden
+ * org.el (org-block-todo-from-children-or-siblings):
+ Use `org-up-heading-all' so that this will work correctly with hidden
property drawers and entries.
(org-end-of-line, org-beginning-of-line): Make prefix arg work, by
falling back to normal, default command.
@@ -3715,8 +10205,8 @@
* org-exp.el (org-export-html-footnotes-section): Make the div id
consistent.
- * org-export-latex.el (org-export-latex-classes): Remove
- paper size option from LaTeX classes.
+ * org-export-latex.el (org-export-latex-classes):
+ Remove paper size option from LaTeX classes.
2009-01-31 Carsten Dominik <carsten.dominik@gmail.com>
@@ -3799,8 +10289,8 @@
* org-agenda.el (org-agenda-todo): Call `org-todo' interactively,
to get real errors from the blocker hook.
- * org.el (org-shiftselect-error, org-call-for-shift-select): New
- functions.
+ * org.el (org-shiftselect-error, org-call-for-shift-select):
+ New functions.
(org-set-visibility-according-to-property): Turn off the setting
of `org-show-entry-below', to avoid overruling a FOLDED visibility
property.
@@ -3817,13 +10307,13 @@
* org-footnote.el (org-footnote-normalize): Remove unnecessary
variable.
- (org-insert-footnote-reference-near-definition): Remove
- unnecessary let form.
+ (org-insert-footnote-reference-near-definition):
+ Remove unnecessary let form.
2009-01-26 Carsten Dominik <dominik@science.uva.nl>
- * org-export-latex.el (org-export-as-latex): Call
- `org-export-latex-first-lines' with OPT-PLIST as a parameter.
+ * org-export-latex.el (org-export-as-latex):
+ Call `org-export-latex-first-lines' with OPT-PLIST as a parameter.
(org-export-latex-first-lines): New parameter OPT-PLIST.
* org.el (org-yank): Tell `delete-selection-mode' about
@@ -3831,8 +10321,8 @@
* org-faces.el (org-clock-overlay): Fix face definition.
- * org-export-latex.el (org-export-latex-first-lines): Pass
- timestamp and footnote parameters to the preprocessor.
+ * org-export-latex.el (org-export-latex-first-lines):
+ Pass timestamp and footnote parameters to the preprocessor.
* org-exp.el (org-export-remove-timestamps): Do not remove time
stamps inside tables.
@@ -3841,8 +10331,8 @@
* org-exp.el (org-export-as-html): Turn \par into a paragraph.
- * org.el (org-agenda-tags-todo-honor-ignore-options): Declare
- variable.
+ * org.el (org-agenda-tags-todo-honor-ignore-options):
+ Declare variable.
* org-table.el (org-table-insert-hline): Fix typo in fuction call
to `backward-char'.
@@ -3850,21 +10340,21 @@
* org-exp.el (org-export-as-html): Remove the initial space from
colon examples.
- * org.el (org-scan-tags): Call
- `org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item'.
+ * org.el (org-scan-tags):
+ Call `org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item'.
- * org-agenda.el (org-agenda-todo-list, org-agenda-match-view): New
- customization groups.
+ * org-agenda.el (org-agenda-todo-list, org-agenda-match-view):
+ New customization groups.
(org-agenda-tags-todo-honor-ignore-options): New option.
(org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item):
New function.
- (org-agenda-get-todos): Use
- `org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item'.
+ (org-agenda-get-todos):
+ Use `org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item'.
2009-01-25 Carsten Dominik <carsten.dominik@gmail.com>
- * org-exp.el (org-export-format-source-code-or-example): Escape
- HTML characters also in examples that anre not treated with
+ * org-exp.el (org-export-format-source-code-or-example):
+ Escape HTML characters also in examples that anre not treated with
htmlize. Also, just switch to EXAMPLE processing if we do not
have a good version of htmlize.
@@ -3920,8 +10410,8 @@
2009-01-25 Carsten Dominik <carsten.dominik@gmail.com>
- * org-export-latex.el (org-export-latex-quotation-marks): Use
- `org-if-unprotected-1'.
+ * org-export-latex.el (org-export-latex-quotation-marks):
+ Use `org-if-unprotected-1'.
(org-export-latex-set-initial-vars): Check for class definition in
property.
@@ -3931,8 +10421,8 @@
* org-compat.el (org-count-lines): New function.
- * org-exp.el (org-export-format-source-code-or-example): Handle
- switches related to text areas.
+ * org-exp.el (org-export-format-source-code-or-example):
+ Handle switches related to text areas.
* org.el (org-activate-footnote-links): Don't allow match inside a
link.
@@ -3967,17 +10457,17 @@
* org.el (org-image-file-name-regexp, org-file-image-p): Allow the
list of extensions to be a parameter.
- * org-exp.el (org-export-html-inline-image-extensions): New
- variable.
+ * org-exp.el (org-export-html-inline-image-extensions):
+ New variable.
- * org-agenda.el (org-prepare-agenda): Use
- `org-agenda-block-separator'.
+ * org-agenda.el (org-prepare-agenda):
+ Use `org-agenda-block-separator'.
(org-agenda-block-separator): New option.
2009-01-25 Carsten Dominik <carsten.dominik@gmail.com>
- * org-export-latex.el (org-export-latex-tables): Call
- `org-table-clean-before-export' with the new optional argument.
+ * org-export-latex.el (org-export-latex-tables):
+ Call `org-table-clean-before-export' with the new optional argument.
* org-exp.el (org-table-clean-before-export): New optional
parameter MAYBE-QUOTED, allows for quoted characters like \# in
@@ -3988,8 +10478,8 @@
* org-plot.el (org-plot/gnuplot): Fix text-ind parameter for
histograms.
- * org-colview.el (org-colview-construct-allowed-dates): Better
- error catching when a date/time property does not have allowed
+ * org-colview.el (org-colview-construct-allowed-dates):
+ Better error catching when a date/time property does not have allowed
values defined.
* org-colview-xemacs.el (org-colview-construct-allowed-dates):
@@ -4018,8 +10508,8 @@
2009-01-25 Carsten Dominik <carsten.dominik@gmail.com>
- * org-compat.el (org-fit-window-to-buffer): Use
- `window-full-width-p'.
+ * org-compat.el (org-fit-window-to-buffer):
+ Use `window-full-width-p'.
* org-export-latex.el (org-export-latex-fixed-width): Enforce the
space after the colon in short examples.
@@ -4075,8 +10565,8 @@
(org-timer-stop): New command.
(org-timer-seconds): Return correct time when timer is paused.
(org-timer-mode-line-timer): New variable.
- (org-timer-set-mode-line, org-timer-update-mode-line): New
- functions.
+ (org-timer-set-mode-line, org-timer-update-mode-line):
+ New functions.
* org.el (org-insert-heading): Handle new value `auto' for
`org-blank-before-new-entry'.
@@ -4125,19 +10615,19 @@
* org-exp.el (org-export-preprocess-string): Remove clock lines
and timestamps already in the preprocesor.
- (org-export-remove-timestamps, org-export-remove-clock-lines): New
- functions.
+ (org-export-remove-timestamps, org-export-remove-clock-lines):
+ New functions.
(org-export-as-ascii, org-export-as-html): Add the timestamps
parameter to the preprocessor parameter list.
* org-list.el (org-list-parse-list): Parse for checkboxes.
(org-list-to-generic): Introduce and handle new parameters :cbon
and :cboff.
- (org-list-to-latex, org-list-to-html, org-list-to-texinfo): Add
- optional parameter PARAMS.
+ (org-list-to-latex, org-list-to-html, org-list-to-texinfo):
+ Add optional parameter PARAMS.
- * org-export-latex.el (org-export-latex-special-chars): Fix
- problems with interpreting dollar signs.
+ * org-export-latex.el (org-export-latex-special-chars):
+ Fix problems with interpreting dollar signs.
(org-inside-latex-math-p): New function.
(org-export-latex-preprocess): Protect all the math fragments.
@@ -4149,8 +10639,8 @@
* org-agenda.el (org-run-agenda-series): Have series options set
when finalizing the agenda.
- * org-exp.el (org-export-format-source-code-or-example): Protect
- the converted examples.
+ * org-exp.el (org-export-format-source-code-or-example):
+ Protect the converted examples.
* org.el (org-set-regexps-and-options): Fix the regexp
`org-complex-heading-regexp'.
@@ -4194,8 +10684,8 @@
* org-macs.el (org-re): Handle the [:word:] class.
- * org-exp.el (org-export-preprocess-string): Call
- `org-export-protect-colon-examples'.
+ * org-exp.el (org-export-preprocess-string):
+ Call `org-export-protect-colon-examples'.
(org-export-protect-colon-examples): Rename from
`org-export-protect-examples', and scope limited to lines starting
with a colon.
@@ -4225,8 +10715,8 @@
(org-export-latex-preprocess): Treat multiple references to a
footnote.
- * org-exp.el (org-export-preprocess-string): Call
- `org-footnote-normalize'.
+ * org-exp.el (org-export-preprocess-string):
+ Call `org-footnote-normalize'.
(org-export-as-ascii, org-export-as-html): Pass footnote variable
to preprocessor.
(org-export-as-html): Treat multiple references to a footnote.
@@ -4237,8 +10727,8 @@
links.
* org.el (org-bracket-link-analytic-regexp++): New variable.
- (org-make-link-regexps): Initialize
- `org-bracket-link-analytic-regexp++'.
+ (org-make-link-regexps):
+ Initialize `org-bracket-link-analytic-regexp++'.
(org-store-link): Implement special case in edit-src buffer.
(org-insert-link): No use of ide to insert stored links.
(org-link-search): Implement special case for coderefs.
@@ -4266,8 +10756,8 @@
2009-01-16 Glenn Morris <rgm@gnu.org>
- * org-mouse.el (org-mouse-show-context-menu): Use
- mouse-menu-major-mode-map, if defined, rather than the obsolete
+ * org-mouse.el (org-mouse-show-context-menu):
+ Use mouse-menu-major-mode-map, if defined, rather than the obsolete
mouse-major-mode-menu.
2008-12-23 Carsten Dominik <dominik@science.uva.nl>
@@ -4292,8 +10782,8 @@
2008-12-20 Carsten Dominik <carsten.dominik@gmail.com>
- * org.el (org-get-refile-targets, org-refile-get-location): Use
- expanded file name to improve comparison.
+ * org.el (org-get-refile-targets, org-refile-get-location):
+ Use expanded file name to improve comparison.
2008-12-20 Carsten Dominik <carsten.dominik@gmail.com>
@@ -4305,12 +10795,12 @@
* org-export-latex.el (org-export-latex-links): Fix bug with
undefined label.
- * org-table.el (org-table-get-specials): Set
- `org-table-current-last-data-line'.
+ * org-table.el (org-table-get-specials):
+ Set `org-table-current-last-data-line'.
(org-table-current-last-data-line): New variable.
(org-table-insert-column, org-table-delete-column)
- (org-table-move-column, org-table-fix-formulas): Call
- `org-table-fix-formulas' a second time to fix the $LR references.
+ (org-table-move-column, org-table-fix-formulas):
+ Call `org-table-fix-formulas' a second time to fix the $LR references.
(org-table-get-specials): Add the $LR references to the tables.
(org-table-get-formula): Do not offer last-row names as LHS of
formulas.
@@ -4364,8 +10854,8 @@
* org.el (org-refile): Avoid refiling to within the region to be
refiled.
- * org-export-latex.el (org-export-latex-special-chars): Replace
- special characters also in tables.
+ * org-export-latex.el (org-export-latex-special-chars):
+ Replace special characters also in tables.
* org-agenda.el (org-agenda-change-all-lines): New argument
FORCE-TAGS.
@@ -4413,8 +10903,8 @@
(org-export-as-latex): Pass RBEG to `org-export-latex-first-lines'.
(org-export-latex-make-header): Add some hard space after the
table of contents.
- (org-export-latex-first-lines): Accept RBEG argument. Mark
- exported text so that it will be excuded in further steps.
+ (org-export-latex-first-lines): Accept RBEG argument.
+ Mark exported text so that it will be excuded in further steps.
* org-table.el (org-table-get-specials): Make @0 reference the
last line in a table.
@@ -4434,8 +10924,8 @@
* org-exp.el (org-export-html-style-default): Add style
definitions for the figure div.
- (org-export-preprocess-string, org-export-as-html): Implement
- attribute, label, and caption handling.
+ (org-export-preprocess-string, org-export-as-html):
+ Implement attribute, label, and caption handling.
(org-export-attach-captions-and-attributes): New function.
(org-export-html-format-image): New function.
(org-format-org-table-html): Implement attribute, label, and
@@ -4523,8 +11013,8 @@
* org-w3m.el (w3m-minor-mode-hook): Also add the special copy
command to the `w3m-minor-mode-map'.
- * org-archive.el (org-archive-to-archive-sibling): Protect
- `this-command' to avoid appending kills during archiving.
+ * org-archive.el (org-archive-to-archive-sibling):
+ Protect `this-command' to avoid appending kills during archiving.
* org-exp.el (org-export-with-priority): New variable.
(org-export-add-options-to-plist): Use `org-export-plist-vars'
@@ -4552,8 +11042,8 @@
2008-12-07 Carsten Dominik <carsten.dominik@gmail.com>
* org.el (org-tags-exclude-from-inheritance): New option.
- (org-tag-inherit-p, org-remove-uniherited-tags): Respect
- `org-tags-exclude-from-inheritance'.
+ (org-tag-inherit-p, org-remove-uniherited-tags):
+ Respect `org-tags-exclude-from-inheritance'.
* org-agenda.el (org-agenda-show-inherited-tags): New option.
(org-format-agenda-item): Add inherited tags to the agenda line
@@ -4611,8 +11101,8 @@
accidentially overwritten by last commit to Emacs.
* org.el (org-outline-path-complete-in-steps): New option.
- (org-refile-get-location): Honor
- `org-outline-path-complete-in-steps'.
+ (org-refile-get-location):
+ Honor `org-outline-path-complete-in-steps'.
(org-agenda-change-all-lines, org-tags-sparse-tree)
(org-time-string-to-absolute, org-small-year-to-year)
(org-link-escape): Re-apply changes accidentially overwritten
@@ -4635,8 +11125,8 @@
line before the first headline to always be included. This is
to not miss a commented target.
- * org-mouse.el (org-mouse-insert-item): Call
- `org-indent-to-column' instead of `indent-to', for XEmacs
+ * org-mouse.el (org-mouse-insert-item):
+ Call `org-indent-to-column' instead of `indent-to', for XEmacs
compatibility.
* org.el (org-refile-targets): Fix customize definition so
@@ -4659,18 +11149,18 @@
2008-11-23 Carsten Dominik <carsten.dominik@gmail.com>
- * org-remember.el (org-remember-apply-template): Use
- `org-substring-no-properties'.
+ * org-remember.el (org-remember-apply-template):
+ Use `org-substring-no-properties'.
* org-compat.el (org-substring-no-properties): New function.
- * org-remember.el (org-remember-apply-template): Use
- `org-substring-no-properties' for compatibility.
+ * org-remember.el (org-remember-apply-template):
+ Use `org-substring-no-properties' for compatibility.
- * org-list.el (org-list-two-spaces-after-bullet-regexp): New
- option.
- (org-fix-bullet-type): respect
- `org-list-two-spaces-after-bullet-regexp'.
+ * org-list.el (org-list-two-spaces-after-bullet-regexp):
+ New option.
+ (org-fix-bullet-type):
+ Respect `org-list-two-spaces-after-bullet-regexp'.
* org-clock.el (org-clock-load): Clean up the code.
@@ -4735,8 +11225,8 @@
(org-set-property, org-delete-property)
(org-delete-property-globally): Use `org-ido-completing-read'.
- * org-remember.el (org-remember-apply-template): Use
- `org-ido-completing-read'.
+ * org-remember.el (org-remember-apply-template):
+ Use `org-ido-completing-read'.
* org-publish.el (org-publish): Use `org-ido-completing-read'.
@@ -4744,14 +11234,14 @@
(org-insert-columns-dblock): Use `org-ido-completing-read'.
* org-colview-xemacs.el (org-columns-edit-value)
- (org-columns-new, org-insert-columns-dblock): Use
- `org-ido-completing-read'.
+ (org-columns-new, org-insert-columns-dblock):
+ Use `org-ido-completing-read'.
- * org-attach.el (org-attach-delete-one, org-attach-open): Use
- `org-ido-completing-read'.
+ * org-attach.el (org-attach-delete-one, org-attach-open):
+ Use `org-ido-completing-read'.
- * org-agenda.el (org-todo-list, org-agenda-filter-by-tag): Use
- `org-ido-completing-read'.
+ * org-agenda.el (org-todo-list, org-agenda-filter-by-tag):
+ Use `org-ido-completing-read'.
* org.el (org-time-today): New function.
(org-matcher-time): Use `org-time-today'. Add special treatment
@@ -4766,8 +11256,8 @@
2008-11-23 Carsten Dominik <carsten.dominik@gmail.com>
- * org-export-latex.el (org-export-latex-subcontent): Interprete
- target aliases as additonal labels.
+ * org-export-latex.el (org-export-latex-subcontent):
+ Interprete target aliases as additonal labels.
* org-exp.el (org-export-target-aliases): New variable.
(org-export-preprocess-string)
@@ -4814,8 +11304,8 @@
* org-vm.el (org-vm-follow-link): Require `vm-search'.
- * org.el (org-up-heading-safe, org-forward-same-level): Always
- call `org-back-to-heading' instead of `outline-back-to-heading'.
+ * org.el (org-up-heading-safe, org-forward-same-level):
+ Always call `org-back-to-heading' instead of `outline-back-to-heading'.
(org-back-to-heading): New wrapper around outline-back-to-heading,
with a useful error message telling where the error happened.
@@ -4921,8 +11411,8 @@
* org.el (org-link-abbrev-alist): Improve customization type.
- * org-attach.el (org-attach-expand-link, org-attach-expand): New
- functions.
+ * org-attach.el (org-attach-expand-link, org-attach-expand):
+ New functions.
* org-agenda.el (org-agenda-get-progress): Rename from
`org-get-closed'. Implement searching for state changes as well.
@@ -4961,8 +11451,8 @@
* org-exp.el (org-export-as-html): Make sure that <hr/> is between
paragraphs, not inside.
- * org.el (org-todo): Quote
- `org-agenda-headline-snapshot-before-repeat'.
+ * org.el (org-todo):
+ Quote `org-agenda-headline-snapshot-before-repeat'.
* org-exp.el (org-export-as-html): Fully process link descriptions.
(org-export-html-format-desc): New function.
@@ -4977,14 +11467,14 @@
really, a preliminary and incomplete version was present earlier,
but not used).
- * org.el (org-fast-todo-selection, org-fast-tag-selection): Use
- `org-fit-window-to-buffer'.
+ * org.el (org-fast-todo-selection, org-fast-tag-selection):
+ Use `org-fit-window-to-buffer'.
* org-exp.el (org-export): Use `org-fit-window-to-buffer'.
* org-agenda.el (org-agenda-get-restriction-and-command)
- (org-fit-agenda-window, org-agenda-convert-date): Use
- `org-fit-window-to-buffer'.
+ (org-fit-agenda-window, org-agenda-convert-date):
+ Use `org-fit-window-to-buffer'.
* org-exp.el (org-export-as-html): Process href links through
`org-export-html-format-href'.
@@ -5007,8 +11497,8 @@
(org-export-html-style-default): Mark style definitions as
unparsed CDATA.
- * org-publish.el (org-publish-validate-link): Function
- re-introduced.
+ * org-publish.el (org-publish-validate-link):
+ Function re-introduced.
2008-11-12 Charles Sebold <csebold@gmail.com>
@@ -5046,7 +11536,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.
@@ -5143,7 +11633,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>
@@ -5153,8 +11643,8 @@
2008-10-26 Bastien Guerry <bzg@altern.org>
- * org-export-latex.el (org-export-latex-classes): Add
- \usepackage{graphicx} to the default list of packages.
+ * org-export-latex.el (org-export-latex-classes):
+ Add \usepackage{graphicx} to the default list of packages.
2008-10-26 Carsten Dominik <dominik@science.uva.nl>
@@ -5168,8 +11658,8 @@
(org-add-log-note): Mask prefix argument when immediately storing
the note.
- * org-agenda.el (org-agenda-filter-effort-default-operator): New
- option.
+ * org-agenda.el (org-agenda-filter-effort-default-operator):
+ New option.
2008-10-26 James TD Smith <ahktenzero@mohorovi.cc>
@@ -5179,7 +11669,7 @@
2008-10-26 Carsten Dominik <dominik@science.uva.nl>
- * org-agenda.el (org-agenda-filter-tags,org-agenda-filter-form):
+ * org-agenda.el (org-agenda-filter-tags, org-agenda-filter-form):
New variables.
(org-prepare-agenda): Reset the filter tags.
(org-agenda-filter-by-tag, org-agenda-filter-by-tag-show-all):
@@ -5202,8 +11692,8 @@
2008-10-26 Carsten Dominik <dominik@science.uva.nl>
- * org.el (org-add-log-setup): Respect
- `org-log-state-notes-insert-after-drawers'.
+ * org.el (org-add-log-setup):
+ Respect `org-log-state-notes-insert-after-drawers'.
(org-log-state-notes-insert-after-drawers): New option.
(org-todo-trigger-tag-changes): New function.
(org-todo): Call `org-todo-trigger-tag-changes'.
@@ -5214,7 +11704,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.
@@ -5238,8 +11728,8 @@
2008-10-26 Carsten Dominik <dominik@science.uva.nl>
- * org-export-latex.el (org-export-latex-preprocess): Improve
- quoting of LaTeX environments.
+ * org-export-latex.el (org-export-latex-preprocess):
+ Improve quoting of LaTeX environments.
2008-10-19 Eli Zaretskii <eliz@gnu.org>
@@ -5294,8 +11784,8 @@
* org-attach.el (org-attach-auto-tag): New option.
(org-attach-tag, org-attach-untag): New functions.
- (org-attach-attach, org-attach-new, org-attach-sync): Call
- `org-attach-tag'.
+ (org-attach-attach, org-attach-new, org-attach-sync):
+ Call `org-attach-tag'.
(org-attach-delete): Call `org-attach-untag'.
* org-table.el (orgtbl-self-insert-command): Make this work for
@@ -5322,8 +11812,8 @@
* org-exp.el (org-infile-export-plist): Put the content of
#+LATEX_HEADER: into the property :latex-header-extra.
- * org-colview.el (org-columns-get-format-and-top-level): Remove
- resetting the marker.
+ * org-colview.el (org-columns-get-format-and-top-level):
+ Remove resetting the marker.
* org-colview-xemacs.el (org-columns-get-format-and-top-level):
Remove resetting the marker.
@@ -5335,8 +11825,8 @@
* org-exp.el (org-infile-export-plist): Allow multiple STYLE lines.
* org.el (org-entry-get-multivalued-property)
- (org-entry-protect-space, org-entry-restore-space): New
- functions.
+ (org-entry-protect-space, org-entry-restore-space):
+ New functions.
(org-file-apps-defaults-macosx): Let postscript files be opened by
preview.
(org-time-stamp-inactive): Call `org-time-stamp'.
@@ -5371,8 +11861,8 @@
* org-bbdb.el (org-bbdb-anniversaries): Require bbdb in
`org-bbdb-anniversaries'.
- * org.el (org-get-next-sibling, org-forward-same-level): New
- functions, similar to the outline versions, but invisible headings
+ * org.el (org-get-next-sibling, org-forward-same-level):
+ New functions, similar to the outline versions, but invisible headings
are OK.
2008-10-12 Bastien Guerry <bzg@altern.org>
@@ -5417,7 +11907,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
@@ -5426,7 +11916,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
@@ -5438,7 +11928,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.
@@ -5452,7 +11942,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.
@@ -5461,7 +11951,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>
@@ -5497,15 +11987,15 @@
(org-entries-lessp): Implement sorting by TODO state.
(org-cmp-todo-state): New defsubst.
- * org-colview.el (org-colview-construct-allowed-dates): New
- function.
- (org-columns-next-allowed-value): Use
- `org-colview-construct-allowed-dates'.
+ * org-colview.el (org-colview-construct-allowed-dates):
+ New function.
+ (org-columns-next-allowed-value):
+ Use `org-colview-construct-allowed-dates'.
- * org-colview-xemacs.el (org-colview-construct-allowed-dates): New
- function.
- (org-columns-next-allowed-value): Use
- `org-colview-construct-allowed-dates'.
+ * org-colview-xemacs.el (org-colview-construct-allowed-dates):
+ New function.
+ (org-columns-next-allowed-value):
+ Use `org-colview-construct-allowed-dates'.
* org.el (org-protect-slash): New function.
(org-get-refile-targets): Use `org-protect-slash'.
@@ -5513,8 +12003,8 @@
* org-agenda.el (org-global-tags-completion-table): New variable.
* org-exp.el (org-export-handle-export-tags): New function.
- (org-export-preprocess-string): Call
- `org-export-handle-export-tags'.
+ (org-export-preprocess-string):
+ Call `org-export-handle-export-tags'.
* org-publish.el (org-publish-expand-components): Function removed.
(org-publish-expand-projects): Allow components to have components.
@@ -5524,8 +12014,8 @@
(org-yank-and-fold-if-subtree): New function.
* org-agenda.el (org-agenda-todayp): New function.
- (org-agenda-get-deadlines, org-agenda-get-scheduled): Use
- `org-agenda-todayp'.
+ (org-agenda-get-deadlines, org-agenda-get-scheduled):
+ Use `org-agenda-todayp'.
* org.el (org-insert-heading-respect-content)
(org-insert-todo-heading-respect-content): New commands.
@@ -5633,11 +12123,11 @@
* org-agenda.el (org-agenda-align-tags): Fix bug with malformed
face property.
- * org-colview.el (org-columns-display-here): Use
- `org-columns-modify-value-for-display-function'.
+ * org-colview.el (org-columns-display-here):
+ Use `org-columns-modify-value-for-display-function'.
- * org-colview-xemacs.el (org-columns-display-here): Use
- `org-columns-modify-value-for-display-function'.
+ * org-colview-xemacs.el (org-columns-display-here):
+ Use `org-columns-modify-value-for-display-function'.
* org.el (org-columns-modify-value-for-display-function): New option.
@@ -5694,14 +12184,14 @@
2008-07-24 Carsten Dominik <dominik@science.uva.nl>
- * org-exp.el (org-export-region-as-html, org-export-as-html): Make
- sure that calls from `org-export-region-as-html' do not do the
+ * org-exp.el (org-export-region-as-html, org-export-as-html):
+ Make sure that calls from `org-export-region-as-html' do not do the
special check for a subtree.
* org-agenda.el (org-batch-store-agenda-views): Fix parsing bug.
- * org.el (org-open-file): Use
- `org-open-directory-means-index-dot-org'.
+ * org.el (org-open-file):
+ Use `org-open-directory-means-index-dot-org'.
(org-open-directory-means-index-dot-org): New option.
* org.el (org-make-link-string): Remove link attributes from
@@ -5717,8 +12207,8 @@
* org.el (org-narrow-to-subtree): Do not include the final newline
into the narrowed region.
- * org-agenda.el (org-agenda-custom-commands-local-options): Fix
- bug with user-define skipping condition.
+ * org-agenda.el (org-agenda-custom-commands-local-options):
+ Fix bug with user-define skipping condition.
* org-agenda.el (org-agenda-get-restriction-and-command): Fix typo.
@@ -5737,8 +12227,8 @@
* org-publish.el (org-publish-find-title): Bug fix.
(org-publish-org-index): Implement new :index-style option.
- * org-publish.el (org-publish-timestamp-filename): Use
- SHA1-encoded file names in the timestamp directory.
+ * org-publish.el (org-publish-timestamp-filename):
+ Use SHA1-encoded file names in the timestamp directory.
* org-publish.el (org-publish-needed-p): Be verbose about files
published and files skipped.
@@ -5796,7 +12286,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
@@ -5880,8 +12370,8 @@
`org-diary-to-ical-string' out of the loop, and kill the buffer
afterwords.
- * org-remember.el (org-remember-visit-immediately): Position
- cursor after moving to the note.
+ * org-remember.el (org-remember-visit-immediately):
+ Position cursor after moving to the note.
(org-remember-apply-template): Use a text property to record the
cursor position.
(org-remember-handler): Align tags after pasting the note.
@@ -5924,8 +12414,8 @@
2008-06-17 Carsten Dominik <dominik@science.uva.nl>
* org-remember.el (org-jump-to-target-location): New variable.
- (org-remember-apply-template): Set
- `org-remember-apply-template' if requested by template.
+ (org-remember-apply-template):
+ Set `org-remember-apply-template' if requested by template.
(org-remember-handler): Start an idle timer to jump to
remember location.
@@ -5975,8 +12465,8 @@
2008-06-17 Carsten Dominik <dominik@science.uva.nl>
- * org-agenda.el (org-agenda-columns-remove-prefix-from-item): New
- option.
+ * org-agenda.el (org-agenda-columns-remove-prefix-from-item):
+ New option.
* org-colview.el (org-agenda-columns-cleanup-item): New function.
@@ -6097,11 +12587,11 @@
* org-clock.el (org-clock-display, org-clock-out)
(org-update-mode-line): Use `org-time-clocksum-format'.
- * org-colview-xemacs.el (org-columns-number-to-string): Use
- `org-time-clocksum-format'.
+ * org-colview-xemacs.el (org-columns-number-to-string):
+ Use `org-time-clocksum-format'.
- * org-colview.el (org-columns-number-to-string): Use
- `org-time-clocksum-format'.
+ * org-colview.el (org-columns-number-to-string):
+ Use `org-time-clocksum-format'.
2008-06-17 Carsten Dominik <dominik@science.uva.nl>
@@ -6129,8 +12619,8 @@
(org-export-preprocess-string): Implement the COMMENT
environment.
- * org-export-latex.el (org-export-latex-preprocess): Implement
- VERSE environment.
+ * org-export-latex.el (org-export-latex-preprocess):
+ Implement VERSE environment.
2008-06-17 Carsten Dominik <dominik@science.uva.nl>
@@ -6185,8 +12675,8 @@
2008-06-17 Carsten Dominik <dominik@science.uva.nl>
- * org.el (org-remove-double-quotes, org-file-contents): New
- functions.
+ * org.el (org-remove-double-quotes, org-file-contents):
+ New functions.
* org-exp.el (org-infile-export-plist): Also parse the
contents of #+SETUPFILE files, recursively.
@@ -6195,8 +12685,8 @@
contents of #+SETUPFILE files, recursively.
* org-exp.el (org-export-handle-include-files): New function.
- (org-export-preprocess-string): Call
- `org-export-handle-include-files'.
+ (org-export-preprocess-string):
+ Call `org-export-handle-include-files'.
* org.el (org-delete-property-globally)
(org-delete-property, org-set-property): Ignore case during
@@ -6224,8 +12714,8 @@
* org.el (org-set-font-lock-defaults): Make the description
tag bold.
- * org-exp.el (org-export-as-html, org-close-li): Implement
- description lists.
+ * org-exp.el (org-export-as-html, org-close-li):
+ Implement description lists.
2008-06-17 Jason Riedy <jason@acm.org>
@@ -6286,7 +12776,7 @@
* org.el (org-base-buffer): New function.
- * org-exp.el (org-icalendar-cleanup-string): Make sure ',"
+ * org-exp.el (org-icalendar-cleanup-string): Make sure ","
and ";" are escaped.
(org-print-icalendar-entries): Also apply
`org-icalendar-cleanup-string' to the headline, not only to the
@@ -6306,7 +12796,7 @@
;; add-log-time-zone-rule: t
;; End:
- Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 2008-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -6323,4 +12813,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: a9bdcf06-7c2d-4b5a-bf7a-c5e7b706f67c
diff --git a/lisp/org/ob-C.el b/lisp/org/ob-C.el
new file mode 100644
index 00000000000..6d81e1978fa
--- /dev/null
+++ b/lisp/org/ob-C.el
@@ -0,0 +1,193 @@
+;;; ob-C.el --- org-babel functions for C and similar languages
+
+;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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)
+
+
+;;; 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..5f94240f22f
--- /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-2011 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte, Dan Davison
+;; Keywords: literate programming, reproducible research, R, statistics
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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) (when (> (length line) 0) line))
+ (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)))))) "\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)
+
+
+;;; 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..06407542468
--- /dev/null
+++ b/lisp/org/ob-asymptote.el
@@ -0,0 +1,163 @@
+;;; ob-asymptote.el --- org-babel functions for asymptote evaluation
+
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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)
+
+
+;;; 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..8682a06e243
--- /dev/null
+++ b/lisp/org/ob-calc.el
@@ -0,0 +1,96 @@
+;;; ob-calc.el --- org-babel functions for calc code evaluation
+
+;; Copyright (C) 2010-2011 Free Software Foundation, Inc
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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."
+ (unless (get-buffer "*Calculator*")
+ (save-window-excursion (calc) (calc-quit)))
+ (let* ((vars (mapcar #'cdr (org-babel-get-header params :var)))
+ (var-syms (mapcar #'car vars))
+ (var-names (mapcar #'symbol-name var-syms)))
+ (mapc
+ (lambda (pair)
+ (calc-push-list (list (cdr pair)))
+ (calc-store-into (car pair)))
+ vars)
+ (mapc
+ (lambda (line)
+ (when (> (length line) 0)
+ (cond
+ ;; simple variable name
+ ((member line var-names) (calc-recall (intern line)))
+ ;; stack operation
+ ((string= "'" (substring line 0 1))
+ (funcall (lookup-key calc-mode-map (substring line 1)) nil))
+ ;; complex expression
+ (t
+ (calc-push-list
+ (list ((lambda (res)
+ (cond
+ ((numberp res) res)
+ ((math-read-number res) (math-read-number res))
+ ((listp res) (error "calc error \"%s\" on input \"%s\""
+ (cadr res) line))
+ (t (calc-eval
+ (math-evaluate-expr
+ ;; resolve user variables, calc built in
+ ;; variables are handled automatically
+ ;; upstream by calc
+ (mapcar (lambda (el)
+ (if (and (consp el) (equal 'var (car el))
+ (member (cadr el) var-syms))
+ (progn
+ (calc-recall (cadr el))
+ (prog1 (calc-top 1)
+ (calc-pop 1)))
+ el))
+ ;; parse line into calc objects
+ (car (math-read-exprs line))))))))
+ (calc-eval line))))))))
+ (mapcar #'org-babel-trim
+ (split-string (org-babel-expand-body:calc body params) "[\n\r]"))))
+ (save-excursion
+ (with-current-buffer (get-buffer "*Calculator*")
+ (calc-eval (calc-top 1)))))
+
+(provide 'ob-calc)
+
+
+;;; 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..f9087e8358e
--- /dev/null
+++ b/lisp/org/ob-clojure.el
@@ -0,0 +1,87 @@
+;;; ob-clojure.el --- org-babel functions for clojure evaluation
+
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
+
+;; Author: Joel Boehland, Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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:
+
+;;; support for evaluating clojure code, relies on slime for all eval
+
+;;; Requirements:
+
+;;; - clojure (at least 1.2.0)
+;;; - 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)
+
+(declare-function slime-eval "ext:slime" (sexp &optional package))
+
+(add-to-list 'org-babel-tangle-lang-exts '("clojure" . "clj"))
+
+(defvar org-babel-default-header-args:clojure '())
+(defvar org-babel-header-arg-names:clojure '(package))
+
+(defun org-babel-expand-body:clojure (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 (org-babel-trim
+ (if (> (length vars) 0)
+ (concat "(let ["
+ (mapconcat
+ (lambda (var)
+ (format "%S (quote %S)" (car var) (cdr var)))
+ vars "\n ")
+ "]\n" body ")")
+ body))))
+ (if (or (member "code" result-params)
+ (member "pp" result-params))
+ (format (concat "(let [org-mode-print-catcher (java.io.StringWriter.)]"
+ "(clojure.pprint/with-pprint-dispatch %s-dispatch"
+ "(clojure.pprint/pprint %s org-mode-print-catcher)"
+ "(str org-mode-print-catcher)))")
+ (if (member "code" result-params) "code" "simple") body)
+ body)))
+
+(defun org-babel-execute:clojure (body params)
+ "Execute a block of Clojure code with Babel."
+ (require 'slime) (require 'swank-clojure)
+ (with-temp-buffer
+ (insert (org-babel-expand-body:clojure body params))
+ (read
+ (slime-eval
+ `(swank:interactive-eval-region
+ ,(buffer-substring-no-properties (point-min) (point-max)))
+ (cdr (assoc :package params))))))
+
+(provide 'ob-clojure)
+
+
+;;; 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..7607f802914
--- /dev/null
+++ b/lisp/org/ob-comint.el
@@ -0,0 +1,162 @@
+;;; ob-comint.el --- org-babel functions for interaction with comint buffers
+
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research, comint
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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)
+
+
+;;; 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..6c96d53a993
--- /dev/null
+++ b/lisp/org/ob-css.el
@@ -0,0 +1,48 @@
+;;; ob-css.el --- org-babel functions for css evaluation
+
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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)
+
+
+;;; 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..336ca8cde7f
--- /dev/null
+++ b/lisp/org/ob-ditaa.el
@@ -0,0 +1,73 @@
+;;; ob-ditaa.el --- org-babel functions for ditaa evaluation
+
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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)
+
+
+;;; 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..09476cd2592
--- /dev/null
+++ b/lisp/org/ob-dot.el
@@ -0,0 +1,89 @@
+;;; ob-dot.el --- org-babel functions for dot evaluation
+
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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)
+
+
+;;; 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..9b9fe68a25a
--- /dev/null
+++ b/lisp/org/ob-emacs-lisp.el
@@ -0,0 +1,70 @@
+;;; ob-emacs-lisp.el --- org-babel functions for emacs-lisp code evaluation
+
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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)
+
+
+;;; 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..84d0354fc77
--- /dev/null
+++ b/lisp/org/ob-eval.el
@@ -0,0 +1,261 @@
+;;; ob-eval.el --- org-babel functions for external code evaluation
+
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research, comint
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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:
+(eval-when-compile (require 'cl))
+
+(defvar org-babel-error-buffer-name "*Org-Babel Error Output*")
+
+(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-buffer-name)))
+ (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"
+ (if (featurep 'xemacs)
+ (temp-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))
+
+(defun org-babel-eval-wipe-error-buffer ()
+ "Delete the contents of the Org code block error buffer.
+This buffer is named by `org-babel-error-buffer-name'."
+ (when (get-buffer org-babel-error-buffer-name)
+ (with-current-buffer org-babel-error-buffer-name
+ (delete-region (point-min) (point-max)))))
+
+(provide 'ob-eval)
+
+
+;;; 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..3215bcf4d8a
--- /dev/null
+++ b/lisp/org/ob-exp.el
@@ -0,0 +1,327 @@
+;;; ob-exp.el --- Exportation of org-babel source blocks
+
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte, Dan Davison
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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-eval-wipe-error-buffer "ob-eval" ())
+(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)))
+ (org-babel-eval-wipe-error-buffer)
+ (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)
+
+
+;;; 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..41b47102d65
--- /dev/null
+++ b/lisp/org/ob-gnuplot.el
@@ -0,0 +1,234 @@
+;;; ob-gnuplot.el --- org-babel functions for gnuplot evaluation
+
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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)
+
+
+;;; 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..43c14deb407
--- /dev/null
+++ b/lisp/org/ob-haskell.el
@@ -0,0 +1,216 @@
+;;; ob-haskell.el --- org-babel functions for haskell evaluation
+
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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-script-escape 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)
+
+
+;;; 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..06acfb391bc
--- /dev/null
+++ b/lisp/org/ob-js.el
@@ -0,0 +1,164 @@
+;;; ob-js.el --- org-babel functions for Javascript
+
+;; Copyright (C) 2010-2011 Free Software Foundation
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research, js
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;;; License:
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; 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)
+
+
+;;; 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..d1422c6876f
--- /dev/null
+++ b/lisp/org/ob-keys.el
@@ -0,0 +1,97 @@
+;;; ob-keys.el --- key bindings for org-babel
+
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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)
+
+
+;;; 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..9bb0f318be6
--- /dev/null
+++ b/lisp/org/ob-latex.el
@@ -0,0 +1,179 @@
+;;; ob-latex.el --- org-babel functions for latex "evaluation"
+
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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)
+
+
+;;; 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..51f0282c5c0
--- /dev/null
+++ b/lisp/org/ob-ledger.el
@@ -0,0 +1,71 @@
+;;; ob-ledger.el --- org-babel functions for ledger evaluation
+
+;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
+
+;; Author: Eric S Fraga
+;; Keywords: literate programming, reproducible research, accounting
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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)
+
+
+;;; 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..1a8ad38a199
--- /dev/null
+++ b/lisp/org/ob-lisp.el
@@ -0,0 +1,112 @@
+;;; ob-lisp.el --- org-babel functions for Common Lisp
+
+;; Copyright (C) 2010-2011 Free Software Foundation
+
+;; Author: David T. O'Toole <dto@gnu.org>, Eric Schulte
+;; Keywords: literate programming, reproducible research, lisp
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;;; License:
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; 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" (sexp &optional package))
+(declare-function slime-process "ext:slime" (&optional connection))
+(declare-function slime-connected-p "ext:slime" ())
+
+(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."
+ :group 'org-babel
+ :type 'string)
+
+(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'"
+ (require 'slime)
+ (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."
+ (require 'slime)
+ (unless (string= session "none")
+ (save-window-excursion
+ (or (slime-connected-p)
+ (slime-process)))))
+
+(provide 'ob-lisp)
+
+
+;;; 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..96081c16236
--- /dev/null
+++ b/lisp/org/ob-lob.el
@@ -0,0 +1,123 @@
+;;; ob-lob.el --- functions supporting the Library of Babel
+
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte, Dan Davison
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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)%s"
+ (match-string 2)
+ (if (match-string 4)
+ (concat "[" (match-string 4) "]") "")
+ (or (match-string 6) "") (match-string 7))
+ (match-string 8)))
+ (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)
+
+
+;;; 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..441f9d7a73a
--- /dev/null
+++ b/lisp/org/ob-matlab.el
@@ -0,0 +1,47 @@
+;;; ob-matlab.el --- org-babel support for matlab evaluation
+
+;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
+
+;; Author: Dan Davison
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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)
+
+
+;;; 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..3b55f2e27b3
--- /dev/null
+++ b/lisp/org/ob-mscgen.el
@@ -0,0 +1,85 @@
+;;; ob-msc.el --- org-babel functions for mscgen evaluation
+
+;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
+
+;; Author: Juan Pechiar
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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)
+
+
+;;; 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..bf34b984c00
--- /dev/null
+++ b/lisp/org/ob-ocaml.el
@@ -0,0 +1,156 @@
+;;; ob-ocaml.el --- org-babel functions for ocaml evaluation
+
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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)
+
+
+;;; 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..ae6c1513dee
--- /dev/null
+++ b/lisp/org/ob-octave.el
@@ -0,0 +1,263 @@
+;;; ob-octave.el --- org-babel functions for octave and matlab evaluation
+
+;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
+
+;; Author: Dan Davison
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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)
+
+
+;;; 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..99c04d8e313
--- /dev/null
+++ b/lisp/org/ob-org.el
@@ -0,0 +1,61 @@
+;;; ob-org.el --- org-babel functions for org code block evaluation
+
+;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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)
+
+
+;;; 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..6309b900111
--- /dev/null
+++ b/lisp/org/ob-perl.el
@@ -0,0 +1,116 @@
+;;; ob-perl.el --- org-babel functions for perl evaluation
+
+;; Copyright (C) 2009-2011 Free Software Foundation
+
+;; Author: Dan Davison, Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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)
+
+
+;;; 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..f455bc9bb4c
--- /dev/null
+++ b/lisp/org/ob-plantuml.el
@@ -0,0 +1,82 @@
+;;; ob-plantuml.el --- org-babel functions for plantuml evaluation
+
+;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
+
+;; Author: Zhang Weize
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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)
+
+
+;;; 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..b53513a212c
--- /dev/null
+++ b/lisp/org/ob-python.el
@@ -0,0 +1,281 @@
+;;; ob-python.el --- org-babel functions for python evaluation
+
+;; Copyright (C) 2009-2011 Free Software Foundation
+
+;; Author: Eric Schulte, Dan Davison
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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)))
+ (return-val (when (and (eq result-type 'value) (not session))
+ (cdr (assoc :return params))))
+ (preamble (cdr (assoc :preamble params)))
+ (full-body
+ (org-babel-expand-body:generic
+ (concat body (if return-val (format "return %s" return-val) ""))
+ params (org-babel-variable-assignments:python params)))
+ (result (org-babel-python-evaluate
+ session full-body result-type result-params preamble)))
+ (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."
+ (org-babel-script-escape 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 preamble)
+ "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 preamble)))
+
+(defun org-babel-python-evaluate-external-process
+ (body &optional result-type result-params preamble)
+ "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
+ (concat (if preamble (concat preamble "\n") "") body)))
+ (value (let ((tmp-file (org-babel-temp-file "python-")))
+ (org-babel-eval org-babel-python-command
+ (concat
+ (if preamble (concat preamble "\n") "")
+ (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 pprint"
+ (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)
+
+
+;;; 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..96819df8ea1
--- /dev/null
+++ b/lisp/org/ob-ref.el
@@ -0,0 +1,228 @@
+;;; ob-ref.el --- org-babel functions for referencing external data
+
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte, Dan Davison
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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 'org-list)
+ (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))
+(declare-function org-in-item-p "org-list" ())
+
+(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)
+ (let ((out (org-babel-read ref)))
+ (if (equal out ref)
+ (if (string-match "^\".+\"$" ref)
+ (read ref)
+ (org-babel-ref-resolve ref))
+ 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-header-args 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-header-args (match-string 3 ref))
+ (setq new-referent (match-string 5 ref))
+ (when (> (length new-refere) 0)
+ (when (> (length new-referent) 0)
+ (setq args (mapcar (lambda (ref) (cons :var ref))
+ (org-babel-ref-split-args new-referent))))
+ (when (> (length new-header-args) 0)
+ (setq args (append (org-babel-parse-header-arguments new-header-args)
+ args)))
+ (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))
+ (list (org-babel-read-list))
+ (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)
+ ((org-in-item-p) 'list)
+ ((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)
+
+
+;;; 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..ae98137735c
--- /dev/null
+++ b/lisp/org/ob-ruby.el
@@ -0,0 +1,238 @@
+;;; ob-ruby.el --- org-babel functions for ruby evaluation
+
+;; Copyright (C) 2009-2011 Free Software Foundation
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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-script-escape 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)
+
+
+;;; 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..3348dd4d1d6
--- /dev/null
+++ b/lisp/org/ob-sass.el
@@ -0,0 +1,68 @@
+;;; ob-sass.el --- org-babel functions for the sass css generation language
+
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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)
+
+
+;;; 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..5dda693b9a7
--- /dev/null
+++ b/lisp/org/ob-scheme.el
@@ -0,0 +1,138 @@
+;;; ob-scheme.el --- org-babel functions for Scheme
+
+;; Copyright (C) 2010-2011 Free Software Foundation
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research, scheme
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;;; License:
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; 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)
+
+
+;;; 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..59e23c4caad
--- /dev/null
+++ b/lisp/org/ob-screen.el
@@ -0,0 +1,146 @@
+;;; ob-screen.el --- org-babel support for interactive terminal
+
+;; Copyright (C) 2009-2011 Free Software Foundation
+
+;; Author: Benjamin Andresen
+;; Keywords: literate programming, interactive shell
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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)
+
+
+;;; 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..6ca52b1f361
--- /dev/null
+++ b/lisp/org/ob-sh.el
@@ -0,0 +1,170 @@
+;;; ob-sh.el --- org-babel functions for shell evaluation
+
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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-script-escape 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)
+
+
+;;; 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..49859d24a17
--- /dev/null
+++ b/lisp/org/ob-sql.el
@@ -0,0 +1,125 @@
+;;; ob-sql.el --- org-babel functions for sql evaluation
+
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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))
+(declare-function orgtbl-to-csv "org-table" (TABLE PARAMS))
+
+(defvar org-babel-default-header-args:sql '())
+
+(defun org-babel-expand-body:sql (body params)
+ "Expand BODY according to the values of PARAMS."
+ (org-babel-sql-expand-vars
+ body (mapcar #'cdr (org-babel-get-header params :var))))
+
+(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)
+ (msosql (format "osql %s -s \"\t\" -i %s -o %s"
+ (or cmdline "")
+ (org-babel-process-file-name in-file)
+ (org-babel-process-file-name out-file)))
+ (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:sql body params)))
+ (message command)
+ (shell-command command)
+ (with-temp-buffer
+ (org-table-import out-file '(16))
+ (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-sql-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 "sql-data-"))
+ (if (stringp val) val (format "%S" val))))
+ (cdr pair))
+ body)))
+ vars)
+ body)
+
+(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)
+
+
+;;; 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..408ca4e64c4
--- /dev/null
+++ b/lisp/org/ob-sqlite.el
@@ -0,0 +1,148 @@
+;;; ob-sqlite.el --- org-babel functions for sqlite database interaction
+
+;; Copyright (C) 2010-2011 Free Software Foundation
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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-eval)
+(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)) "")))
+ (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
+ (org-babel-eval
+ (org-fill-template
+ "%cmd %header %separator %nullvalue %others %csv %db "
+ (list
+ (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)))
+ ;; body of the code block
+ (org-babel-expand-body:sqlite body params)))
+ (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)
+
+
+;;; 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..e44bb86ca04
--- /dev/null
+++ b/lisp/org/ob-table.el
@@ -0,0 +1,124 @@
+;;; ob-table.el --- support for calling org-babel functions from tables
+
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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))
+ (if (match-string 1 string) "...")) 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)
+
+
+;;; 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..67f12eabc01
--- /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-2011 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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'."
+ (interactive "fFile to load: ")
+ (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)
+
+
+;;; ob-tangle.el ends here
diff --git a/lisp/org/ob.el b/lisp/org/ob.el
new file mode 100644
index 00000000000..33f960f145e
--- /dev/null
+++ b/lisp/org/ob.el
@@ -0,0 +1,1967 @@
+;;; ob.el --- working with code blocks in org-mode
+
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte, Dan Davison
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+
+;; 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 'org-list)
+ (require 'cl))
+(require 'ob-eval)
+(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))
+(declare-function org-in-item-p "org-list" ())
+(declare-function org-list-parse-list "org-list" (&optional delete))
+(declare-function org-list-to-generic "org-list" (LIST PARAMS))
+(declare-function org-list-bottom-point "org-list" ())
+
+(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 block%son your system? "
+ (if info (format " %s " (nth 0 info)) " ")
+ (if (nth 4 info)
+ (format " (%s) " (nth 4 info)) " "))))))
+ (prog1 nil (message "Evaluation %s"
+ (if (or (equal eval "never") (equal eval "no"))
+ "Disabled" "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-eval-wipe-error-buffer)
+ (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)
+ (let ((noweb (cdr (assoc :noweb params))))
+ (if (and noweb
+ (or (string= "yes" noweb)
+ (string= "tangle" noweb)))
+ (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
+(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 ((tempvar (make-symbol "file")))
+ `(let* ((,tempvar ,file)
+ (visited-p (or (null ,tempvar)
+ (get-file-buffer (expand-file-name ,tempvar))))
+ (point (point)) to-be-removed)
+ (save-window-excursion
+ (when ,tempvar (find-file ,tempvar))
+ (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))))
+
+;;;###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)))
+
+(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."
+ (when (> (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 (match-string 1 arg))
+ (org-babel-read (org-babel-chomp (match-string 2 arg))))
+ (cons (intern (org-babel-chomp arg)) nil)))
+ (let ((balance 0) (partial nil) (lst nil) (last 0))
+ (mapc (lambda (ch) ; split on [] balanced instances of [ \t]:
+ (setq balance (+ balance
+ (cond ((equal 91 ch) 1)
+ ((equal 93 ch) -1)
+ (t 0))))
+ (setq partial (cons ch partial))
+ (when (and (= ch 58) (= balance 0)
+ (or (= last 32) (= last 9)))
+ (setq lst (cons (apply #'string (nreverse (cddr partial)))
+ lst))
+ (setq partial (list ch)))
+ (setq last ch))
+ (string-to-list arg-string))
+ (nreverse (cons (apply #'string (nreverse partial)) lst)))))))
+
+(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))
+ ((org-in-item-p) (org-babel-read-list))
+ ((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)))
+
+(defun org-babel-read-list ()
+ "Read the list at `point' into emacs-lisp."
+ (mapcar #'org-babel-read (cdr (org-list-parse-list))))
+
+(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
+
+list ---- the results are interpreted as an Org-mode list.
+
+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-marker)))
+ ((member "prepend" result-params)))) ; already there
+ (setq results-switches
+ (if results-switches (concat " " results-switches) ""))
+ ;; insert results based on type
+ (cond
+ ;; do nothing for an empty result
+ ((= (length result) 0))
+ ;; insert a list if preferred
+ ((member "list" result-params)
+ (insert
+ (org-babel-trim
+ (org-list-to-generic (cons 'unordered
+ (if (listp result) result (list result)))
+ '(:splicep nil :istart "- " :iend "\n")))))
+ ;; assume the result is a table if it's not a string
+ ((not (stringp result))
+ (goto-char beg)
+ (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))
+ (t (goto-char beg) (insert result)))
+ (when (listp result) (goto-char (org-table-end)))
+ (setq end (point-marker))
+ ;; possibly wrap result
+ (flet ((wrap (start finish)
+ (goto-char beg) (insert start)
+ (goto-char end) (insert finish)
+ (setq end (point-marker))))
+ (cond
+ ((member "html" result-params)
+ (wrap "#+BEGIN_HTML\n" "#+END_HTML"))
+ ((member "latex" result-params)
+ (wrap "#+BEGIN_LaTeX\n" "#+END_LaTeX"))
+ ((member "code" result-params)
+ (wrap (format "#+BEGIN_SRC %s%s\n" (or lang "none") results-switches)
+ "#+END_SRC"))
+ ((member "org" result-params)
+ (wrap "#+BEGIN_ORG\n" "#+END_ORG"))
+ ((member "raw" result-params)
+ (goto-char beg) (if (org-at-table-p) (org-cycle)))
+ ((member "wrap" result-params)
+ (when (and (stringp result) (not (member "file" result-params)))
+ (org-babel-examplize-region beg end results-switches))
+ (wrap "#+BEGIN_RESULT\n" "#+END_RESULT"))
+ ((and (stringp result) (not (member "file" result-params)))
+ (org-babel-examplize-region beg end results-switches)
+ (setq end (point)))))
+ ;; possibly indent the results to match the #+results line
+ (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 "Code block returned no value.")
+ (message "Code block produced no output."))
+ (message "Code block evaluation complete."))))
+
+(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
+ (cond
+ ((org-at-table-p) (progn (goto-char (org-table-end)) (point)))
+ ((org-in-item-p) (- (org-list-bottom-point) 1))
+ (t
+ (let ((case-fold-search t)
+ (blocks-re (regexp-opt
+ (list "latex" "html" "example" "src" "result"))))
+ (if (looking-at (concat "[ \t]*#\\+begin_" blocks-re))
+ (re-search-forward (concat "[ \t]*#\\+end_" blocks-re) nil t)
+ (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)) ; do nothing for an empty result
+ ((< 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"))
+ (if (markerp end) (goto-char end) (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" "list" "vector" "table" "scalar" "raw" "org"
+ "html" "latex" "code" "pp" "wrap")
+ ("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" "tangle")) 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-script-escape (str)
+ "Safely convert tables into elisp lists."
+ (let (in-single in-double out)
+ (org-babel-read
+ (if (and (stringp str) (string-match "^\\[.+\\]$" str))
+ (org-babel-read
+ (concat
+ "'"
+ (progn
+ (mapc
+ (lambda (ch)
+ (setq
+ out
+ (case ch
+ (91 (if (or in-double in-single) ; [
+ (cons 91 out)
+ (cons 40 out)))
+ (93 (if (or in-double in-single) ; ]
+ (cons 93 out)
+ (cons 41 out)))
+ (44 (if (or in-double in-single) (cons 44 out) out)) ; ,
+ (39 (if in-double ; '
+ (cons 39 out)
+ (setq in-single (not in-single)) (cons 34 out)))
+ (34 (if in-single ; "
+ (append (list 34 32) out)
+ (setq in-double (not in-double)) (cons 34 out)))
+ (t (cons ch out)))))
+ (string-to-list str))
+ (apply #'string (reverse out)))))
+ str))))
+
+(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
+ (condition-case nil
+ (progn
+ (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))
+ (error
+ (message "Failed to remove temporary Org-babel directory %s"
+ org-babel-temporary-directory)))))
+
+(add-hook 'kill-emacs-hook 'org-babel-remove-temporary-directory)
+
+(provide 'ob)
+
+
+;;; ob.el ends here
diff --git a/lisp/org/org-agenda.el b/lisp/org/org-agenda.el
index 4ad19b37339..8aeb4c4e5b2 100644
--- a/lisp/org/org-agenda.el
+++ b/lisp/org/org-agenda.el
@@ -1,12 +1,11 @@
;;; org-agenda.el --- Dynamic task and appointment lists for Org
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; This file is part of GNU Emacs.
;;
@@ -32,8 +31,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 +61,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 +87,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 +107,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 +142,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 +197,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 +216,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.")
@@ -236,8 +241,12 @@ you can \"misuse\" it to also add other text to the header. However,
(const org-agenda-prefix-format :value " %-12:c%?-12t% s")
(string))
(list :tag "Number of days in agenda"
- (const org-agenda-ndays)
- (integer :value 1))
+ (const org-agenda-span)
+ (choice (const :tag "Day" 'day)
+ (const :tag "Week" 'week)
+ (const :tag "Month" 'month)
+ (const :tag "Year" 'year)
+ (integer :tag "Custom")))
(list :tag "Fixed starting date"
(const org-agenda-start-day)
(string :value "2007-11-01"))
@@ -258,6 +267,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 +289,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 +533,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 +554,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
@@ -531,31 +565,105 @@ See also the variable `org-agenda-tags-todo-honor-ignore-options'."
:group 'org-agenda-todo-list
:type 'boolean)
+(defcustom org-agenda-todo-ignore-timestamp nil
+ "Non-nil means don't show entries with a timestamp.
+This applies when creating the global todo list.
+Valid values are:
+
+past Don't show entries for today or in the past.
+
+future Don't show entries with a timestamp in the future.
+ The idea behind this is that if it has a future
+ timestamp, you don't want to think about it until the
+ date.
+
+all Don't show any entries with a timestamp in the global todo list.
+ The idea behind this is that by setting a timestamp, you
+ have already \"taken care\" of this item.
+
+See also `org-agenda-todo-ignore-with-date'.
+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 '(choice
+ (const :tag "Ignore future timestamp todos" future)
+ (const :tag "Ignore past or present timestamp todos" past)
+ (const :tag "Ignore all timestamp todos" all)
+ (const :tag "Show timestamp todos" nil)))
+
(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'
+ `org-agenda-todo-ignore-timestamp',
+ `org-agenda-todo-ignore-scheduled',
`org-agenda-todo-ignore-deadlines'
make the global TODO list skip entries that have time stamps of certain
kinds. If this option is set, the same options will also apply for the
@@ -603,6 +711,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 +743,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 +765,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 +781,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 +849,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 +882,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
@@ -749,15 +891,28 @@ option will be ignored."
:group 'org-agenda-windows
:type 'boolean)
-(defcustom org-agenda-ndays 7
- "Number of days to include in overview display.
+(defcustom org-agenda-ndays nil
+ "Number of days to include in overview display.
Should be 1 or 7.
+Obsolete, see `org-agenda-span'."
+ :group 'org-agenda-daily/weekly
+ :type 'integer)
+
+(make-obsolete-variable 'org-agenda-ndays 'org-agenda-span "24.1")
+
+(defcustom org-agenda-span 'week
+ "Number of days to include in overview display.
+Can be day, week, month, year, or any number of days.
Custom commands can set this variable in the options section."
:group 'org-agenda-daily/weekly
- :type 'integer)
+ :type '(choice (const :tag "Day" day)
+ (const :tag "Week" week)
+ (const :tag "Month" month)
+ (const :tag "Year" year)
+ (integer :tag "Custom")))
(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 +921,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 +960,41 @@ 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-timegrid-use-ampm nil
+ "When set, show AM/PM style timestamps on the timegrid."
+ :group 'org-agenda
+ :type 'boolean)
+
+(defun org-agenda-time-of-day-to-ampm (time)
+ "Convert TIME of a string like '13:45' to an AM/PM style time string."
+ (let* ((hour-number (string-to-number (substring time 0 -3)))
+ (minute (substring time -2))
+ (ampm "am"))
+ (cond
+ ((equal hour-number 12)
+ (setq ampm "pm"))
+ ((> hour-number 12)
+ (setq ampm "pm")
+ (setq hour-number (- hour-number 12))))
+ (concat
+ (if org-agenda-time-leading-zero
+ (format "%02d" hour-number)
+ (format "%02s" (number-to-string hour-number)))
+ ":" minute ampm)))
+
+(defun org-agenda-time-of-day-to-ampm-maybe (time)
+ "Conditionally convert TIME to AM/PM format
+based on `org-agenda-timegrid-use-ampm'"
+ (if org-agenda-timegrid-use-ampm
+ (org-agenda-time-of-day-to-ampm time)
+ time))
+
(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 +1015,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 +1030,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 +1057,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 +1087,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 +1130,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 +1141,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 +1215,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 +1260,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 +1270,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.
@@ -1060,11 +1284,11 @@ When nil, such items are sorted as 0 minutes effort."
:group 'org-agenda)
(defcustom org-agenda-prefix-format
- '((agenda . " %-12:c%?-12t% s")
+ '((agenda . " %i %-12:c%?-12t% s")
(timeline . " % s")
- (todo . " %-12:c")
- (tags . " %-12:c")
- (search . " %-12:c"))
+ (todo . " %i %-12:c")
+ (tags . " %i %-12:c")
+ (search . " %i %-12:c"))
"Format specifications for the prefix of items in the agenda views.
An alist with four entries, for the different agenda types. The keys to the
sublists are `agenda', `timeline', `todo', and `tags'. The values
@@ -1073,6 +1297,8 @@ This format works similar to a printf format, with the following meaning:
%c the category of the item, \"Diary\" for entries from the diary, or
as given by the CATEGORY keyword or derived from the file name.
+ %i the icon category of the item, as give in
+ `org-agenda-category-icon-alist'.
%T the *last* tag of the item. Last because inherited tags come
first in the list.
%t the time-of-day specification if one applies to the entry, in the
@@ -1163,6 +1389,14 @@ 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 preceding deadline items in the agenda view.
This is a list with two strings. The first applies when the item has its
@@ -1177,7 +1411,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 +1419,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 +1427,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 +1443,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 +1458,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 +1483,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 +1502,55 @@ 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"))))))
+
+(defcustom org-agenda-day-face-function nil
+ "Function called to determine what face should be used to display a day.
+The only argument passed to that function is the day. It should
+returns a face, or nil if does not want to specify a face and let
+the normal rules apply."
+ :group 'org-agenda-line-format
+ :type 'function)
+
+(defcustom org-agenda-category-icon-alist nil
+ "Alist of category icon to be displayed in agenda views.
+
+Each entry should have the following format:
+
+ (CATEGORY-REGEXP FILE-OR-DATA TYPE DATA-P PROPS)
+
+Where CATEGORY-REGEXP is a regexp matching the categories where
+the icon should be displayed.
+FILE-OR-DATA either a file path or a string containing image data.
+
+The other fields can be ommited safely if not needed:
+TYPE indicates the image type.
+DATA-P is a boolean indicating whether the FILE-OR-DATA string is
+image data.
+PROPS are additional image attributes to assign to the image,
+like, e.g. `:ascent center'.
+
+ (\"Org\" \"/path/to/icon.png\" nil nil :ascent center)
+
+If you want to set the display properties yourself, just put a
+list as second element:
+
+ (CATEGORY-REGEXP (MY PROPERTY LIST))
+
+For example, to display a 16px horizontal space for Emacs
+category, you can use:
+
+ (\"Emacs\" '(space . (:width (16))))"
+ :group 'org-agenda-line-format
+ :type '(alist :key-type (string :tag "Regexp matching category")
+ :value-type (choice (list :tag "Icon"
+ (string :tag "File or data")
+ (symbol :tag "Type")
+ (boolean :tag "Data?")
+ (repeat :tag "Extra image properties" :inline t symbol))
+ (list :tag "Display properties" sexp))))
(defgroup org-agenda-column-view nil
"Options concerning column view in the agenda."
@@ -1269,12 +1558,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 +1573,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 +1584,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 +1598,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 +1609,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 +1646,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 +1760,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 +1801,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 +1824,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"
@@ -1538,24 +1841,27 @@ The following commands are available:
("View"
["Day View" org-agenda-day-view
:active (org-agenda-check-type nil 'agenda)
- :style radio :selected (equal org-agenda-ndays 1)
+ :style radio :selected (eq org-agenda-current-span 'day)
:keys "v d (or just d)"]
["Week View" org-agenda-week-view
:active (org-agenda-check-type nil 'agenda)
- :style radio :selected (equal org-agenda-ndays 7)
+ :style radio :selected (eq org-agenda-current-span 'week)
:keys "v w (or just w)"]
["Month View" org-agenda-month-view
:active (org-agenda-check-type nil 'agenda)
- :style radio :selected (member org-agenda-ndays '(28 29 30 31))
+ :style radio :selected (eq org-agenda-current-span 'month)
:keys "v m"]
["Year View" org-agenda-year-view
:active (org-agenda-check-type nil 'agenda)
- :style radio :selected (member org-agenda-ndays '(365 366))
+ :style radio :selected (eq org-agenda-current-span 'year)
:keys "v y"]
"--"
["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 +1980,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 +2126,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 +2223,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 +2262,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 +2450,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 +2478,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 +2527,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 +2636,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 +2643,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 +2657,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 +2672,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 +2711,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 +2748,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)
@@ -2557,18 +2899,23 @@ removed from the entry content. Currently only `planning' is allowed here."
(defvar org-agenda-columns-active nil)
(defvar org-agenda-name nil)
(defvar org-agenda-filter nil)
+(defvar org-agenda-filter-while-redo 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 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 +2951,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 +2994,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 +3012,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 +3038,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 +3085,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 +3100,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 +3162,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 +3182,20 @@ 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)))))
+
+(defun org-agenda-get-day-face (date)
+ "Return the face DATE should be displayed with."
+ (or (and (functionp org-agenda-day-face-function)
+ (funcall org-agenda-day-face-function date))
+ (cond ((org-agenda-todayp date)
+ 'org-agenda-date-today)
+ ((member (calendar-day-of-week date) org-agenda-weekend-days)
+ 'org-agenda-date-weekend)
+ (t 'org-agenda-date))))
;;; Agenda timeline
@@ -2844,13 +3209,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)))
@@ -2859,10 +3224,10 @@ dates."
org-timeline-show-empty-dates))
(org-deadline-warning-days 0)
(org-agenda-only-exact-dates t)
- (today (time-to-days (current-time)))
+ (today (org-today))
(past t)
args
- s e rtn d emptyp wd)
+ s e rtn d emptyp)
(setq org-agenda-redo-command
(list 'progn
(list 'org-switch-to-buffer-other-window (current-buffer))
@@ -2872,8 +3237,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)
@@ -2897,8 +3261,7 @@ dates."
(progn
(setq past nil)
(insert (make-string 79 ?-) "\n")))
- (setq date (calendar-gregorian-from-absolute d)
- wd (calendar-day-of-week date))
+ (setq date (calendar-gregorian-from-absolute d))
(setq s (point))
(setq rtn (and (not emptyp)
(apply 'org-agenda-get-day-entries entry
@@ -2912,9 +3275,7 @@ dates."
(funcall org-agenda-format-date date))
"\n")
(put-text-property s (1- (point)) 'face
- (if (member wd org-agenda-weekend-days)
- 'org-agenda-date-weekend
- 'org-agenda-date))
+ (org-agenda-get-day-face date))
(put-text-property s (1- (point)) 'org-date-line t)
(put-text-property s (1- (point)) 'org-agenda-date-header t)
(if (equal d today)
@@ -2940,7 +3301,7 @@ When EMPTY is non-nil, also include days without any entries."
(if inactive org-ts-regexp-both org-ts-regexp)))
dates dates1 date day day1 day2 ts1 ts2)
(if force-today
- (setq dates (list (time-to-days (current-time)))))
+ (setq dates (list (org-today))))
(save-excursion
(goto-char beg)
(while (re-search-forward re end t)
@@ -2976,13 +3337,47 @@ 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-agenda-current-span nil
+ "The current span used in the agenda view.") ; 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 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)
+(defun org-agenda-list (&optional include-all start-day span)
"Produce a daily/weekly view from all files in variable `org-agenda-files'.
The view will be for the current day or week, but from the overview buffer
you will be able to go to other days/weeks.
@@ -2993,38 +3388,36 @@ This feature is considered obsolete, please use the TODO list or a block
agenda instead.
With a numeric prefix argument in an interactive call, the agenda will
-span INCLUDE-ALL days. Lisp programs should instead specify NDAYS to change
-the number of days. NDAYS defaults to `org-agenda-ndays'.
+span INCLUDE-ALL days. Lisp programs should instead specify SPAN to change
+the number of days. SPAN defaults to `org-agenda-span'.
START-DAY defaults to TODAY, or to the most recent match for the weekday
given in `org-agenda-start-on-weekday'."
(interactive "P")
(if (and (integerp include-all) (> include-all 0))
- (setq ndays include-all include-all nil))
- (setq ndays (or ndays org-agenda-ndays)
- start-day (or start-day org-agenda-start-day))
+ (setq span include-all include-all nil))
+ (setq start-day (or start-day org-agenda-start-day))
(if org-agenda-overriding-arguments
(setq include-all (car org-agenda-overriding-arguments)
start-day (nth 1 org-agenda-overriding-arguments)
- ndays (nth 2 org-agenda-overriding-arguments)))
+ span (nth 2 org-agenda-overriding-arguments)))
(if (stringp start-day)
;; Convert to an absolute day number
(setq start-day (time-to-days (org-read-date nil t start-day))))
- (setq org-agenda-last-arguments (list include-all start-day ndays))
+ (setq org-agenda-last-arguments (list include-all start-day span))
(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))
+ (let* ((span (org-agenda-ndays-to-span (or span org-agenda-ndays org-agenda-span)))
+ (today (org-today))
+ (sd (or start-day today))
+ (ndays (org-agenda-span-to-ndays span sd))
+ (org-agenda-start-on-weekday
+ (if (eq ndays 7)
+ org-agenda-start-on-weekday))
(thefiles (org-agenda-files nil 'ifmode))
(files thefiles)
- (today (time-to-days
- (time-subtract (current-time)
- (list 0 (* 3600 org-extend-today-until) 0))))
- (sd (or start-day today))
(start (if (or (null org-agenda-start-on-weekday)
- (< org-agenda-ndays 7))
+ (< ndays 7))
sd
(let* ((nt (calendar-day-of-week
(calendar-gregorian-from-absolute sd)))
@@ -3034,24 +3427,19 @@ given in `org-agenda-start-on-weekday'."
(day-numbers (list start))
(day-cnt 0)
(inhibit-redisplay (not debug-on-error))
- s e rtn rtnall file date d start-pos end-pos todayp nd wd
- clocktable-start clocktable-end)
+ s e rtn rtnall file date d start-pos end-pos todayp
+ clocktable-start clocktable-end filter)
(setq org-agenda-redo-command
- (list 'org-agenda-list (list 'quote include-all) start-day ndays))
- ;; Make the list of days
- (setq ndays (or ndays org-agenda-ndays)
- nd ndays)
- (while (> ndays 1)
- (push (1+ (car day-numbers)) day-numbers)
- (setq ndays (1- ndays)))
+ (list 'org-agenda-list (list 'quote include-all) start-day (list 'quote span)))
+ (dotimes (n (1- ndays))
+ (push (1+ (car day-numbers)) day-numbers))
(setq day-numbers (nreverse day-numbers))
(setq clocktable-start (car day-numbers)
clocktable-end (1+ (or (org-last day-numbers) 0)))
(org-prepare-agenda "Day/Week")
(org-set-local 'org-starting-day (car day-numbers))
(org-set-local 'org-include-all-loc include-all)
- (org-set-local 'org-agenda-span
- (org-agenda-ndays-to-span nd))
+ (org-set-local 'org-agenda-current-span (org-agenda-ndays-to-span span))
(when (and (or include-all org-agenda-include-all-todo)
(member today day-numbers))
(setq files thefiles
@@ -3079,7 +3467,7 @@ given in `org-agenda-start-on-weekday'."
(if org-agenda-overriding-header
(insert (org-add-props (copy-sequence org-agenda-overriding-header)
nil 'face 'org-agenda-structure) "\n")
- (insert (capitalize (symbol-name (org-agenda-ndays-to-span nd)))
+ (insert (org-agenda-span-name span)
"-agenda"
(if (< (- d2 d1) 350)
(if (= w1 w2)
@@ -3092,7 +3480,6 @@ given in `org-agenda-start-on-weekday'."
(org-agenda-mark-header-line s))
(while (setq d (pop day-numbers))
(setq date (calendar-gregorian-from-absolute d)
- wd (calendar-day-of-week date)
s (point))
(if (or (setq todayp (= d today))
(and (not start-pos) (= d sd)))
@@ -3104,18 +3491,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))
@@ -3132,19 +3523,16 @@ given in `org-agenda-start-on-weekday'."
(funcall org-agenda-format-date date))
"\n")
(put-text-property s (1- (point)) 'face
- (if (member wd org-agenda-weekend-days)
- 'org-agenda-date-weekend
- 'org-agenda-date))
+ (org-agenda-get-day-face date))
(put-text-property s (1- (point)) 'org-date-line t)
(put-text-property s (1- (point)) 'org-agenda-date-header t)
(put-text-property s (1- (point)) 'org-day-cnt day-cnt)
(when todayp
- (put-text-property s (1- (point)) 'org-today t)
- (put-text-property s (1- (point)) 'face 'org-agenda-date-today))
+ (put-text-property s (1- (point)) 'org-today t))
(if rtnall (insert
(org-finalize-agenda-entries
(org-agenda-add-time-grid-maybe
- rtnall nd todayp))
+ rtnall ndays todayp))
"\n"))
(put-text-property s (1- (point)) 'day d)
(put-text-property s (1- (point)) 'org-day-cnt day-cnt))))
@@ -3157,6 +3545,15 @@ given in `org-agenda-start-on-weekday'."
(setq p (plist-put p :tstart clocktable-start))
(setq p (plist-put p :tend clocktable-end))
(setq p (plist-put p :scope 'agenda))
+ (when (and (eq org-agenda-clockreport-mode 'with-filter)
+ (setq filter (or org-agenda-filter-while-redo
+ (get 'org-agenda-filter :preset-filter))))
+ (setq p (plist-put p :tags (mapconcat (lambda (x)
+ (if (string-match "[<>=]" x)
+ ""
+ x))
+ filter ""))))
+ (message "%s" (plist-get p :tags)) (sit-for 2)
(setq tbl (apply 'org-get-clocktable p))
(insert tbl)))
(goto-char (point-min))
@@ -3176,7 +3573,31 @@ given in `org-agenda-start-on-weekday'."
(message "")))
(defun org-agenda-ndays-to-span (n)
- (cond ((< n 7) 'day) ((= n 7) 'week) ((< n 32) 'month) (t 'year)))
+ "Return a span symbol for a span of N days, or N if none matches."
+ (cond ((symbolp n) n)
+ ((= n 1) 'day)
+ ((= n 7) 'week)
+ (t n)))
+
+(defun org-agenda-span-to-ndays (span start-day)
+ "Return ndays from SPAN starting at START-DAY."
+ (cond ((numberp span) span)
+ ((eq span 'day) 1)
+ ((eq span 'week) 7)
+ ((eq span 'month)
+ (let ((date (calendar-gregorian-from-absolute start-day)))
+ (calendar-last-day-of-month (car date) (caddr date))))
+ ((eq span 'year)
+ (let ((date (calendar-gregorian-from-absolute start-day)))
+ (if (calendar-leap-year-p (caddr date)) 366 365)))))
+
+(defun org-agenda-span-name (span)
+ "Return a SPAN name."
+ (if (null span)
+ ""
+ (if (symbolp span)
+ (capitalize (symbol-name span))
+ (format "%d days" span))))
;;; Agenda word search
@@ -3195,11 +3616,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 +3628,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 +3673,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 +3702,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,17 +3866,17 @@ 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")
- (let* ((today (time-to-days (current-time)))
+ (if (and (stringp arg) (not (string-match "\\S-" arg))) (setq arg nil))
+ (let* ((today (org-today))
(date (calendar-gregorian-from-absolute today))
(kwds org-todo-keywords-for-agenda)
(completion-ignore-case t)
@@ -3475,11 +3944,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 +4018,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 +4030,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 +4041,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 +4080,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 +4129,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 +4195,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 +4227,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 +4264,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 +4331,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 +4370,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,20 +4495,58 @@ 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)
+ org-agenda-todo-ignore-deadlines
+ org-agenda-todo-ignore-timestamp)
(setq end (or end (save-excursion (outline-next-heading) (point))))
(save-excursion
(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)))))
+ (and org-agenda-todo-ignore-timestamp
+ (let ((buffer (current-buffer))
+ (regexp
+ (concat
+ org-scheduled-time-regexp "\\|" org-deadline-time-regexp))
+ (start (point)))
+ ;; Copy current buffer into a temporary one
+ (with-temp-buffer
+ (insert-buffer-substring buffer start end)
+ (goto-char (point-min))
+ ;; Delete SCHEDULED and DEADLINE items
+ (while (re-search-forward regexp end t)
+ (delete-region (match-beginning 0) (match-end 0)))
+ (goto-char (point-min))
+ ;; No search for timestamp left
+ (when (re-search-forward org-ts-regexp nil t)
+ (cond
+ ((eq org-agenda-todo-ignore-timestamp 'future)
+ (> (org-days-to-time (match-string 1)) 0))
+ ((eq org-agenda-todo-ignore-timestamp 'past)
+ (<= (org-days-to-time (match-string 1)) 0))
+ (t))))))))))
(defconst org-agenda-no-heading-message
"No heading for this item in buffer or region.")
@@ -4064,7 +4611,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 +4630,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 +4675,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 +4772,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 +4822,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 +4845,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 +5060,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
@@ -4505,6 +5100,14 @@ The flag is set if the currently compiled format contains a `%e'.")
(defvar org-prefix-category-max-length nil
"Used by `org-compile-prefix-format' to remember the category field width.")
+(defun org-agenda-get-category-icon (category)
+ "Return an image for CATEGORY according to `org-agenda-category-icon-alist'."
+ (dolist (entry org-agenda-category-icon-alist)
+ (when (org-string-match-p (car entry) category)
+ (if (listp (cadr entry))
+ (return (cadr entry))
+ (return (apply 'create-image (cdr entry)))))))
+
(defun org-format-agenda-item (extra txt &optional category tags dotime
noprefix remove-re habitp)
"Format TXT to be inserted into the agenda buffer.
@@ -4529,11 +5132,17 @@ Any match of REMOVE-RE will be removed from TXT."
org-agenda-show-inherited-tags
org-agenda-hide-tags-regexp))
(let* ((category (or category
- org-category
+ (if (stringp org-category)
+ org-category
+ (and org-category (symbol-name org-category)))
(if buffer-file-name
(file-name-sans-extension
(file-name-nondirectory buffer-file-name))
"")))
+ (category-icon (org-agenda-get-category-icon category))
+ (category-icon (if category-icon
+ (propertize " " 'display category-icon)
+ ""))
;; time, tag, effort are needed for the eval of the prefix format
(tag (if tags (nth (1- (length tags)) tags) ""))
time effort neffort
@@ -4589,7 +5198,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)
@@ -4619,8 +5228,15 @@ Any match of REMOVE-RE will be removed from TXT."
(if noprefix
(setq rtn txt)
;; Prepare the variables needed in the eval of the compiled format
- (setq time (cond (s2 (concat s1 "-" s2))
- (s1 (concat s1 "......"))
+ (setq time (cond (s2 (concat
+ (org-agenda-time-of-day-to-ampm-maybe s1)
+ "-" (org-agenda-time-of-day-to-ampm-maybe s2)
+ (if org-agenda-timegrid-use-ampm " ")))
+ (s1 (concat
+ (org-agenda-time-of-day-to-ampm-maybe s1)
+ (if org-agenda-timegrid-use-ampm
+ "........ "
+ "......")))
(t ""))
extra (or (and (not habitp) extra) "")
category (if (symbolp category) (symbol-name category) category)
@@ -4663,18 +5279,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 +5335,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)))))
@@ -4744,11 +5360,11 @@ The resulting form is returned and stored in the variable
(t " %-12:c%?-12t% s")))
(start 0)
varform vars var e c f opt)
- (while (string-match "%\\(\\?\\)?\\([-+]?[0-9.]*\\)\\([ .;,:!?=|/<>]?\\)\\([ctse]\\)"
+ (while (string-match "%\\(\\?\\)?\\([-+]?[0-9.]*\\)\\([ .;,:!?=|/<>]?\\)\\([ctsei]\\)"
s start)
(setq var (cdr (assoc (match-string 4 s)
'(("c" . category) ("t" . time) ("s" . extra)
- ("T" . tag) ("e" . effort))))
+ ("i" . category-icon) ("T" . tag) ("e" . effort))))
c (or (match-string 3 s) "")
opt (match-beginning 1)
start (1+ (match-beginning 0)))
@@ -4805,20 +5421,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 +5482,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 +5538,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 +5587,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 +5633,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 +5661,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 +5750,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)))
@@ -5084,6 +5764,7 @@ When this is the global TODO list, a prefix argument will be interpreted."
(let* ((org-agenda-keep-modes t)
(filter org-agenda-filter)
(preset (get 'org-agenda-filter :preset-filter))
+ (org-agenda-filter-while-redo (or filter preset))
(cols org-agenda-columns-active)
(line (org-current-line))
(window-line (- line (org-current-line (window-start))))
@@ -5127,7 +5808,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 +5849,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 +5877,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 +5910,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 +5945,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 +5977,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 +6004,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 +6024,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 ()
@@ -5340,13 +6037,10 @@ Negative selection means, regexp must not match for selection of an entry."
(cond
(tdpos (goto-char tdpos))
((eq org-agenda-type 'agenda)
- (let* ((sd (time-to-days
- (time-subtract (current-time)
- (list 0 (* 3600 org-extend-today-until) 0))))
- (comp (org-agenda-compute-time-span sd org-agenda-span))
+ (let* ((sd (org-agenda-compute-starting-span
+ (org-today) (or org-agenda-ndays org-agenda-span)))
(org-agenda-overriding-arguments org-agenda-last-arguments))
- (setf (nth 1 org-agenda-overriding-arguments) (car comp))
- (setf (nth 2 org-agenda-overriding-arguments) (cdr comp))
+ (setf (nth 1 org-agenda-overriding-arguments) sd)
(org-agenda-redo)
(org-agenda-find-same-or-today-or-agenda)))
(t (error "Cannot find today")))))
@@ -5363,28 +6057,28 @@ Negative selection means, regexp must not match for selection of an entry."
With prefix ARG, go forward that many times the current span."
(interactive "p")
(org-agenda-check-type t 'agenda)
- (let* ((span org-agenda-span)
+ (let* ((span org-agenda-current-span)
(sd org-starting-day)
(greg (calendar-gregorian-from-absolute sd))
(cnt (org-get-at-bol 'org-day-cnt))
- greg2 nd)
+ greg2)
(cond
((eq span 'day)
- (setq sd (+ arg sd) nd 1))
+ (setq sd (+ arg sd)))
((eq span 'week)
- (setq sd (+ (* 7 arg) sd) nd 7))
+ (setq sd (+ (* 7 arg) sd)))
((eq span 'month)
(setq greg2 (list (+ (car greg) arg) (nth 1 greg) (nth 2 greg))
sd (calendar-absolute-from-gregorian greg2))
- (setcar greg2 (1+ (car greg2)))
- (setq nd (- (calendar-absolute-from-gregorian greg2) sd)))
+ (setcar greg2 (1+ (car greg2))))
((eq span 'year)
(setq greg2 (list (car greg) (nth 1 greg) (+ arg (nth 2 greg)))
sd (calendar-absolute-from-gregorian greg2))
- (setcar (nthcdr 2 greg2) (1+ (nth 2 greg2)))
- (setq nd (- (calendar-absolute-from-gregorian greg2) sd))))
+ (setcar (nthcdr 2 greg2) (1+ (nth 2 greg2))))
+ (t
+ (setq sd (+ (* span arg) sd))))
(let ((org-agenda-overriding-arguments
- (list (car org-agenda-last-arguments) sd nd t)))
+ (list (car org-agenda-last-arguments) sd span t)))
(org-agenda-redo)
(org-agenda-find-same-or-today-or-agenda cnt))))
@@ -5397,8 +6091,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 +6101,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 +6109,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))
@@ -5424,7 +6121,6 @@ With prefix ARG, go backward that many times the current span."
"Switch to daily view for agenda.
With argument DAY-OF-YEAR, switch to that day of the year."
(interactive "P")
- (setq org-agenda-ndays 1)
(org-agenda-change-time-span 'day day-of-year))
(defun org-agenda-week-view (&optional iso-week)
"Switch to daily view for agenda.
@@ -5434,7 +6130,6 @@ week. Any digits before this encode a year. So 200712 means
week 12 of year 2007. Years in the range 1938-2037 can also be
written as 2-digit years."
(interactive "P")
- (setq org-agenda-ndays 7)
(org-agenda-change-time-span 'week iso-week))
(defun org-agenda-month-view (&optional month)
"Switch to monthly view for agenda.
@@ -5459,70 +6154,61 @@ written as 2-digit years."
"Change the agenda view to SPAN.
SPAN may be `day', `week', `month', `year'."
(org-agenda-check-type t 'agenda)
- (if (and (not n) (equal org-agenda-span span))
+ (if (and (not n) (equal org-agenda-current-span span))
(error "Viewing span is already \"%s\"" span))
(let* ((sd (or (org-get-at-bol 'day)
org-starting-day))
- (computed (org-agenda-compute-time-span sd span n))
+ (sd (org-agenda-compute-starting-span sd span n))
(org-agenda-overriding-arguments
- (list (car org-agenda-last-arguments)
- (car computed) (cdr computed) t)))
+ (list (car org-agenda-last-arguments) sd span t)))
(org-agenda-redo)
(org-agenda-find-same-or-today-or-agenda))
(org-agenda-set-mode-name)
(message "Switched to %s view" span))
-(defun org-agenda-compute-time-span (sd span &optional n)
- "Compute starting date and number of days for agenda.
+(defun org-agenda-compute-starting-span (sd span &optional n)
+ "Compute starting date for agenda.
SPAN may be `day', `week', `month', `year'. The return value
is a cons cell with the starting date and the number of days,
so that the date SD will be in that range."
(let* ((greg (calendar-gregorian-from-absolute sd))
(dg (nth 1 greg))
(mg (car greg))
- (yg (nth 2 greg))
- nd w1 y1 m1 thisweek)
+ (yg (nth 2 greg)))
(cond
((eq span 'day)
(when n
(setq sd (+ (calendar-absolute-from-gregorian
(list mg 1 yg))
- n -1)))
- (setq nd 1))
+ n -1))))
((eq span 'week)
(let* ((nt (calendar-day-of-week
(calendar-gregorian-from-absolute sd)))
(d (if org-agenda-start-on-weekday
(- nt org-agenda-start-on-weekday)
- 0)))
+ 0))
+ y1)
(setq sd (- sd (+ (if (< d 0) 7 0) d)))
(when n
(require 'cal-iso)
- (setq thisweek (car (calendar-iso-from-absolute sd)))
(when (> n 99)
(setq y1 (org-small-year-to-year (/ n 100))
n (mod n 100)))
(setq sd
(calendar-absolute-from-iso
(list n 1
- (or y1 (nth 2 (calendar-iso-from-absolute sd)))))))
- (setq nd 7)))
+ (or y1 (nth 2 (calendar-iso-from-absolute sd)))))))))
((eq span 'month)
- (when (and n (> n 99))
- (setq y1 (org-small-year-to-year (/ n 100))
- n (mod n 100)))
- (setq sd (calendar-absolute-from-gregorian
- (list (or n mg) 1 (or y1 yg)))
- nd (- (calendar-absolute-from-gregorian
- (list (1+ (or n mg)) 1 (or y1 yg)))
- sd)))
+ (let (y1)
+ (when (and n (> n 99))
+ (setq y1 (org-small-year-to-year (/ n 100))
+ n (mod n 100)))
+ (setq sd (calendar-absolute-from-gregorian
+ (list (or n mg) 1 (or y1 yg))))))
((eq span 'year)
(setq sd (calendar-absolute-from-gregorian
- (list 1 1 (or n yg)))
- nd (- (calendar-absolute-from-gregorian
- (list 1 1 (1+ (or n yg))))
- sd))))
- (cons sd nd)))
+ (list 1 1 (or n yg))))))
+ sd))
(defun org-agenda-next-date-line (&optional arg)
"Jump to the next line indicating a date in agenda buffer."
@@ -5546,17 +6232,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 +6266,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
@@ -5594,11 +6278,15 @@ so that the date SD will be in that range."
(if org-agenda-entry-text-mode "on" "off")
(if (integerp arg) arg org-agenda-entry-text-maxlines)))
-(defun org-agenda-clockreport-mode ()
- "Toggle clocktable mode in an agenda buffer."
- (interactive)
+(defun org-agenda-clockreport-mode (&optional with-filter)
+ "Toggle clocktable mode in an agenda buffer.
+With prefix arg WITH-FILTER, make the clocktable respect the current
+agenda filter."
+ (interactive "P")
(org-agenda-check-type t 'agenda)
- (setq org-agenda-clockreport-mode (not org-agenda-clockreport-mode))
+ (if with-filter
+ (setq org-agenda-clockreport-mode 'with-filter)
+ (setq org-agenda-clockreport-mode (not org-agenda-clockreport-mode)))
(org-agenda-set-mode-name)
(org-agenda-redo)
(message "Clocktable mode is %s"
@@ -5650,6 +6338,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 inclusion of entries with a deadline 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)
@@ -5663,31 +6361,36 @@ When called with a prefix argument, include all archive files as well."
(defun org-agenda-set-mode-name ()
"Set the mode name to indicate all the small mode settings."
(setq mode-name
- (concat "Org-Agenda"
- (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-use-time-grid " Grid" "")
- (if (and (boundp 'org-habit-show-habits)
- org-habit-show-habits) " Habit" "")
- (if (consp org-agenda-show-log) " LogAll"
- (if org-agenda-show-log " Log" ""))
- (if (or org-agenda-filter (get 'org-agenda-filter
- :preset-filter))
- (concat " {" (mapconcat
- 'identity
- (append (get 'org-agenda-filter
- :preset-filter)
- org-agenda-filter) "") "}")
- "")
- (if org-agenda-archives-mode
- (if (eq org-agenda-archives-mode t)
- " Archives"
- (format " :%s:" org-archive-tag))
- "")
- (if org-agenda-clockreport-mode " Clock" "")))
+ (list "Org-Agenda"
+ (if (get 'org-agenda-files 'org-restrict) " []" "")
+ " "
+ '(:eval (org-agenda-span-name org-agenda-current-span))
+ (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" "")
+ (if (consp org-agenda-show-log) " LogAll"
+ (if org-agenda-show-log " Log" ""))
+ (if (or org-agenda-filter (get 'org-agenda-filter
+ :preset-filter))
+ (concat " {" (mapconcat
+ 'identity
+ (append (get 'org-agenda-filter
+ :preset-filter)
+ org-agenda-filter) "") "}")
+ "")
+ (if org-agenda-archives-mode
+ (if (eq org-agenda-archives-mode t)
+ " Archives"
+ (format " :%s:" org-archive-tag))
+ "")
+ (if org-agenda-clockreport-mode
+ (if (eq org-agenda-clockreport-mode 'with-filter)
+ " Clock{}" " Clock")
+ "")))
(force-mode-line-update))
(defun org-agenda-post-command-hook ()
@@ -5697,20 +6400,19 @@ 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))
(defun org-agenda-previous-line ()
"Move cursor to the previous line, and show if follow-mode is active."
-
(interactive)
(call-interactively 'previous-line)
(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 +6446,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 +6563,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 +6582,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 +6793,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)
@@ -6128,8 +6832,7 @@ the same tree node, and the headline of the tree node in the Org-mode file."
(buffer (marker-buffer marker))
(pos (marker-position marker))
(hdmarker (org-get-at-bol 'org-hd-marker))
- (todayp (equal (org-get-at-bol 'day)
- (time-to-days (current-time))))
+ (todayp (org-agenda-todayp (org-get-at-bol 'day)))
(inhibit-read-only t)
org-agenda-headline-snapshot-before-repeat newhead just-one)
(org-with-remote-undo buffer
@@ -6238,7 +6941,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 +6959,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 +7227,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 +7256,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 +7283,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 +7311,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 +7364,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 +7391,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 +7445,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 +7461,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 +7493,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 +7573,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 +7690,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)))
@@ -6992,23 +7740,26 @@ This is a command that has to be installed in `calendar-mode-map'."
(eq (get-char-property (point-at-bol) 'type)
'org-marked-entry-overlay))
-(defun org-agenda-bulk-mark ()
+(defun org-agenda-bulk-mark (&optional arg)
"Mark the entry at point for future bulk action."
- (interactive)
- (org-agenda-check-no-diary)
- (let* ((m (org-get-at-bol 'org-hd-marker))
- ov)
- (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))))
- (org-overlay-display ov "> "
- (org-get-todo-face "TODO")
- 'evaporate)
- (org-overlay-put ov 'type 'org-marked-entry-overlay))
- (beginning-of-line 2)
- (message "%d entries marked for bulk action"
- (length org-agenda-bulk-marked-entries))))
+ (interactive "p")
+ (dotimes (i (max arg 1))
+ (unless (org-get-at-bol 'org-agenda-diary-link)
+ (let* ((m (org-get-at-bol 'org-hd-marker))
+ ov)
+ (unless (org-agenda-bulk-marked-p)
+ (unless m (error "Nothing to mark at point"))
+ (push m org-agenda-bulk-marked-entries)
+ (setq ov (make-overlay (point-at-bol) (+ 2 (point-at-bol))))
+ (org-overlay-display ov "> "
+ (org-get-todo-face "TODO")
+ 'evaporate)
+ (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))))))
(defun org-agenda-bulk-unmark ()
"Unmark the entry at point for future bulk action."
@@ -7020,6 +7771,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 +7791,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 +7803,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")
+ (message "Bulk: [r]efile [$]arch [A]rch->sib [t]odo [+/-]tag [s]chd [S]catter [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 +7827,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,20 +7856,44 @@ 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)))))))
+
+ ((eq action '?S)
+ (let ((days (read-number
+ (format "Scatter tasks across how many %sdays: "
+ (if arg "week" "")) 7)))
+ (setq cmd
+ `(let ((distance (random ,(1+ days))))
+ (if arg
+ (let ((dist distance)
+ (day-of-week
+ (calendar-day-of-week
+ (calendar-gregorian-from-absolute (org-today)))))
+ (dotimes (i (1+ dist))
+ (while (member day-of-week org-agenda-weekend-days)
+ (incf distance)
+ (incf day-of-week)
+ (if (= day-of-week 7)
+ (setq day-of-week 0)))
+ (incf day-of-week)
+ (if (= day-of-week 7)
+ (setq day-of-week 0)))))
+ (org-agenda-date-later distance)))))
+
(t (error "Invalid bulk action")))
;; Sort the markers, to make sure that parents are handled before children
@@ -7137,6 +7919,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,13 +7999,15 @@ 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: ")))
(let* ((cnt 0) ; count added events
(org-agenda-new-buffers nil)
(org-deadline-warning-days 0)
+ ;; Do not use `org-today' here because appt only takes
+ ;; time and without date as argument, so it may pass wrong
+ ;; information otherwise
(today (org-date-to-gregorian
(time-to-days (current-time))))
(org-agenda-restrict nil)
@@ -7265,17 +8050,12 @@ belonging to the \"Work\" category."
(defun org-agenda-todayp (date)
"Does DATE mean today, when considering `org-extend-today-until'?"
- (let (today h)
- (if (listp date) (setq date (calendar-absolute-from-gregorian date)))
- (setq today (calendar-absolute-from-gregorian (calendar-current-date)))
- (setq h (nth 2 (decode-time (current-time))))
- (or (and (>= h org-extend-today-until)
- (= date today))
- (and (< h org-extend-today-until)
- (= date (1- today))))))
+ (let ((today (org-today))
+ (date (if (and date (listp date)) (calendar-absolute-from-gregorian date)
+ date)))
+ (eq date today)))
(provide 'org-agenda)
-;; arch-tag: 77f7565d-7c4b-44af-a2df-9f6f7070cff1
;;; org-agenda.el ends here
diff --git a/lisp/org/org-archive.el b/lisp/org/org-archive.el
index 81226b2809a..4a934517cfe 100644
--- a/lisp/org/org-archive.el
+++ b/lisp/org/org-archive.el
@@ -1,12 +1,11 @@
;;; org-archive.el --- Archiving for Org-mode
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; This file is part of GNU Emacs.
;;
@@ -40,7 +39,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 +54,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 +64,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 +114,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 +267,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 +277,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 +363,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 +399,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))
@@ -454,6 +465,5 @@ This command is set with the variable `org-archive-default-command'."
(provide 'org-archive)
-;; arch-tag: 0837f601-9699-43c3-8b90-631572ae6c85
;;; org-archive.el ends here
diff --git a/lisp/org/org-ascii.el b/lisp/org/org-ascii.el
index edf2eb37982..d5964538a9c 100644
--- a/lisp/org/org-ascii.el
+++ b/lisp/org/org-ascii.el
@@ -1,12 +1,11 @@
;;; org-ascii.el --- ASCII export for Org-mode
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; This file is part of GNU Emacs.
;;
@@ -26,7 +25,10 @@
;;
;;; Commentary:
+;;; Code:
+
(require 'org-exp)
+
(eval-when-compile
(require 'cl))
@@ -52,19 +54,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 +92,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 +208,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 +234,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 +277,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 +310,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 +346,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 +399,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 +430,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 +444,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 +486,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 +549,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 +591,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 +653,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)))
@@ -621,5 +718,4 @@ publishing directory."
(provide 'org-ascii)
-;; arch-tag: aa96f882-f477-4e13-86f5-70d43e7adf3c
;;; org-ascii.el ends here
diff --git a/lisp/org/org-attach.el b/lisp/org/org-attach.el
index 4eaa8bf46c0..c9679edc65a 100644
--- a/lisp/org/org-attach.el
+++ b/lisp/org/org-attach.el
@@ -1,10 +1,10 @@
;;; org-attach.el --- Manage file attachments to org-mode tasks
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@newartisans.com>
;; Keywords: org data task
-;; Version: 6.33x
+;; Version: 7.4
;; 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.
@@ -412,5 +418,4 @@ prefix."
(provide 'org-attach)
-;; arch-tag: fce93c2e-fe07-4fa3-a905-e10dcc7a6248
;;; org-attach.el ends here
diff --git a/lisp/org/org-bbdb.el b/lisp/org/org-bbdb.el
index ac5b245c6e3..49393db4304 100644
--- a/lisp/org/org-bbdb.el
+++ b/lisp/org/org-bbdb.el
@@ -1,13 +1,12 @@
;;; org-bbdb.el --- Support for links to BBDB entries from within Org-mode
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>,
;; 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.4
;;
;; This file is part of GNU Emacs.
;;
@@ -207,7 +206,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 +321,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 +337,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."
@@ -382,6 +380,5 @@ END:VEVENT\n"
(provide 'org-bbdb)
-;; arch-tag: 9e4f275d-d080-48c1-b040-62247f66b5c2
;;; org-bbdb.el ends here
diff --git a/lisp/org/org-beamer.el b/lisp/org/org-beamer.el
new file mode 100644
index 00000000000..7b698da9681
--- /dev/null
+++ b/lisp/org/org-beamer.el
@@ -0,0 +1,635 @@
+;;; org-beamer.el --- Beamer-specific LaTeX export for org-mode
+;;
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
+;;
+;; Version: 7.4
+;; 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 close columns, go back to full width
+ (org-beamer-close-columns-maybe)
+ (when (setq ass (assoc "BEAMER_envargs" props))
+ (let (case-fold-search)
+ (while (string-match "C\\(\\[[^][]*\\]\\|<[^<>]*>\\)" (cdr ass))
+ (setq columns-option (match-string 1 (cdr ass)))
+ (setcdr ass (replace-match "" t t (cdr ass))))
+ (while (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)
+
+
+;;; org-beamer.el ends here
diff --git a/lisp/org/org-bibtex.el b/lisp/org/org-bibtex.el
index 3eb18013c1c..0c7edc6cbdb 100644
--- a/lisp/org/org-bibtex.el
+++ b/lisp/org/org-bibtex.el
@@ -1,11 +1,11 @@
;;; org-bibtex.el --- Org links to BibTeX entries
;;
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;;
;; 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.4
;;
;; This file is part of GNU Emacs.
;;
@@ -200,6 +200,5 @@
(provide 'org-bibtex)
-;; arch-tag: 83987d5a-01b8-41c7-85bc-77700f1285f5
;;; org-bibtex.el ends here
diff --git a/lisp/org/org-capture.el b/lisp/org/org-capture.el
new file mode 100644
index 00000000000..fb9365bda75
--- /dev/null
+++ b/lisp/org/org-capture.el
@@ -0,0 +1,1389 @@
+;;; org-capture.el --- Fast note taking in Org-mode
+
+;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
+
+;; Author: Carsten Dominik <carsten at orgmode dot org>
+;; Keywords: outlines, hypermedia, calendar, wp
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+;;
+;; 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 for today's date
+
+ (file+datetree+prompt \"path/to/file\")
+ Will create a heading in a date tree, promts for date
+
+ (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 & Date tree, prompt for date"
+ (const :format "" file+datetree+prompt)
+ (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)
+
+(defcustom org-capture-after-finalize-hook nil
+ "Hook that is run right after a capture process is finalized.
+ Suitable for window cleanup"
+ :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'."))
+(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 (&optional stay-with-capture)
+ "Finalize the capture process.
+With prefix argument STAY-WITH-CAPTURE, jump to the location of the
+captured item after finalizing."
+ (interactive "P")
+ (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))
+
+ (run-hooks 'org-capture-after-finalize-hook)
+ ;; Special cases
+ (cond
+ (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"))))
+ (stay-with-capture
+ (org-capture-goto-last-stored)))
+ ;; Return if we did store something
+ (not abort-note)))
+
+(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. Any prefix argument will be passed to the refile comand."
+ (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))))
+
+ ((memq (car target) '(file+datetree file+datetree+prompt))
+ (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
+ (cond
+
+ (org-overriding-default-time
+ ;; use the overriding default time
+ (time-to-days org-overriding-default-time))
+
+ ((eq (car target) 'file+datetree+prompt)
+ ;; prompt for date
+ (time-to-days (org-read-date
+ nil t nil "Date for tree entry:"
+ (days-to-time (org-today)))))
+ (t
+ ;; current date, possible corrected for late night workers
+ (org-today))))))
+
+ ((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)
+
+
+;;; org-capture.el ends here
diff --git a/lisp/org/org-clock.el b/lisp/org/org-clock.el
index c6f5f03ff8d..4e30dd90d80 100644
--- a/lisp/org/org-clock.el
+++ b/lisp/org/org-clock.el
@@ -1,12 +1,11 @@
;;; org-clock.el --- The time clocking code for Org-mode
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; This file is part of GNU Emacs.
;;
@@ -29,11 +28,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 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 +64,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 +97,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 +113,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 +125,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 +137,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 +201,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
@@ -202,11 +221,48 @@ string as argument."
(string :tag "Program")
(function :tag "Function")))
-(defcustom org-clock-clocktable-default-properties '(:maxlevel 2 :scope file)
- "Default properties for new clocktables."
+(defgroup org-clocktable nil
+ "Options concerning the clock table in Org-mode."
+ :tag "Org Clock Table"
+ :group 'org-clock)
+
+(defcustom org-clocktable-defaults
+ (list
+ :maxlevel 2
+ :scope 'file
+ :block nil
+ :tstart nil
+ :tend nil
+ :step nil
+ :stepskip0 nil
+ :fileskip0 nil
+ :tags nil
+ :emphasize nil
+ :link nil
+ :narrow '40!
+ :indent t
+ :formula nil
+ :timestamp nil
+ :level nil
+ :tcolumns nil
+ :formatter nil)
+ "Default properties for clock tables."
:group 'org-clock
:type 'plist)
+(defcustom org-clock-clocktable-formatter 'org-clocktable-write-default
+ "Function to turn clocking data into a table.
+For more information, see `org-clocktable-write-default'."
+ :group 'org-clocktable
+ :type 'function)
+
+(defcustom org-clock-clocktable-default-properties '(:maxlevel 2 :scope file)
+ "Default properties for new clocktables.
+These will be inserted into the BEGIN line, to make it easy for users to
+play with them."
+ :group 'org-clocktable
+ :type 'plist)
+
(defcustom org-clock-idle-time nil
"When non-nil, resolve open clocks if the user is idle more than X minutes."
:group 'org-clock
@@ -222,6 +278,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 +316,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 +353,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 +379,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 +403,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 +416,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 +438,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 +547,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 +566,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 +594,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 +642,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 +679,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 +710,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 +735,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 +795,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 +863,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 +894,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 +916,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 +943,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 +961,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 +994,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 +1038,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 +1059,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 +1102,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 +1127,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 +1138,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 +1280,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 +1330,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 +1346,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 +1380,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 +1394,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 +1403,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 +1425,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 +1449,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 +1548,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 +1562,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 +1573,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 +1585,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
@@ -1398,7 +1622,7 @@ fontified, and then returned."
(font-lock-fontify-buffer)
(forward-line 2)
(buffer-substring (point) (progn
- (re-search-forward "^#\\+END" nil t)
+ (re-search-forward "^[ \t]*#\\+END" nil t)
(point-at-bol)))))
(defun org-clock-report (&optional arg)
@@ -1423,12 +1647,68 @@ buffer and update it."
(let ((pos (point)) start)
(save-excursion
(end-of-line 1)
- (and (re-search-backward "^#\\+BEGIN:[ \t]+clocktable" nil t)
+ (and (re-search-backward "^[ \t]*#\\+BEGIN:[ \t]+clocktable" nil t)
(setq start (match-beginning 0))
- (re-search-forward "^#\\+END:.*" nil t)
+ (re-search-forward "^[ \t]*#\\+END:.*" nil t)
(>= (match-end 0) pos)
start))))
+(defun org-day-of-week (day month year)
+ "Returns the day of the week as an integer."
+ (nth 6
+ (decode-time
+ (date-to-time
+ (format "%d-%02d-%02dT00:00:00" year month day)))))
+
+(defun org-quarter-to-date (quarter year)
+ "Get the date (week day year) of the first day of a given quarter."
+ (let (startday)
+ (cond
+ ((= quarter 1)
+ (setq startday (org-day-of-week 1 1 year))
+ (cond
+ ((= startday 0)
+ (list 52 7 (- year 1)))
+ ((= startday 6)
+ (list 52 6 (- year 1)))
+ ((<= startday 4)
+ (list 1 startday year))
+ ((> startday 4)
+ (list 53 startday (- year 1)))
+ )
+ )
+ ((= quarter 2)
+ (setq startday (org-day-of-week 1 4 year))
+ (cond
+ ((= startday 0)
+ (list 13 startday year))
+ ((< startday 4)
+ (list 14 startday year))
+ ((>= startday 4)
+ (list 13 startday year))
+ )
+ )
+ ((= quarter 3)
+ (setq startday (org-day-of-week 1 7 year))
+ (cond
+ ((= startday 0)
+ (list 26 startday year))
+ ((< startday 4)
+ (list 27 startday year))
+ ((>= startday 4)
+ (list 26 startday year))
+ )
+ )
+ ((= quarter 4)
+ (setq startday (org-day-of-week 1 10 year))
+ (cond
+ ((= startday 0)
+ (list 39 startday year))
+ ((<= startday 4)
+ (list 40 startday year))
+ ((> startday 4)
+ (list 39 startday year)))))))
+
(defun org-clock-special-range (key &optional time as-strings)
"Return two times bordering a special time range.
Key is a symbol specifying the range and can be one of `today', `yesterday',
@@ -1445,7 +1725,12 @@ the returned times will be formatted strings."
(dow (nth 6 tm))
(skey (symbol-name key))
(shift 0)
- s1 m1 h1 d1 month1 y1 diff ts te fm txt w date)
+ (q (cond ((>= (nth 4 tm) 10) 4)
+ ((>= (nth 4 tm) 7) 3)
+ ((>= (nth 4 tm) 4) 2)
+ ((>= (nth 4 tm) 1) 1)))
+ s1 m1 h1 d1 month1 y1 diff ts te fm txt w date
+ interval tmp shiftedy shiftedm shiftedq)
(cond
((string-match "^[0-9]+$" skey)
(setq y (string-to-number skey) m 1 d 1 key 'year))
@@ -1462,6 +1747,15 @@ the returned times will be formatted strings."
(setq d (nth 1 date) month (car date) y (nth 2 date)
dow 1
key 'week))
+ ((string-match "^\\([0-9]+\\)-[qQ]\\([1-4]\\)$" skey)
+ (require 'cal-iso)
+ (setq y (string-to-number (match-string 1 skey)))
+ (setq q (string-to-number (match-string 2 skey)))
+ (setq date (calendar-gregorian-from-absolute
+ (calendar-absolute-from-iso (org-quarter-to-date q y))))
+ (setq d (nth 1 date) month (car date) y (nth 2 date)
+ dow 1
+ key 'quarter))
((string-match "^\\([0-9]+\\)-\\([0-9]\\{1,2\\}\\)-\\([0-9]\\{1,2\\}\\)$" skey)
(setq y (string-to-number (match-string 1 skey))
month (string-to-number (match-string 2 skey))
@@ -1469,12 +1763,17 @@ the returned times will be formatted strings."
key 'day))
((string-match "\\([-+][0-9]+\\)$" skey)
(setq shift (string-to-number (match-string 1 skey))
- key (intern (substring skey 0 (match-beginning 1))))))
+ key (intern (substring skey 0 (match-beginning 1))))
+ (if(and (memq key '(quarter thisq)) (> shift 0))
+ (error "Looking forward with quarters isn't implemented.")
+ ())))
+
(when (= shift 0)
- (cond ((eq key 'yesterday) (setq key 'today shift -1))
- ((eq key 'lastweek) (setq key 'week shift -1))
- ((eq key 'lastmonth) (setq key 'month shift -1))
- ((eq key 'lastyear) (setq key 'year shift -1))))
+ (cond ((eq key 'yesterday) (setq key 'today shift -1))
+ ((eq key 'lastweek) (setq key 'week shift -1))
+ ((eq key 'lastmonth) (setq key 'month shift -1))
+ ((eq key 'lastyear) (setq key 'year shift -1))
+ ((eq key 'lastq) (setq key 'quarter shift -1))))
(cond
((memq key '(day today))
(setq d (+ d shift) h 0 m 0 h1 24 m1 0))
@@ -1483,6 +1782,28 @@ the returned times will be formatted strings."
m 0 h 0 d (- d diff) d1 (+ 7 d)))
((memq key '(month thismonth))
(setq d 1 h 0 m 0 d1 1 month (+ month shift) month1 (1+ month) h1 0 m1 0))
+ ((memq key '(quarter thisq))
+ ; compute if this shift remains in this year
+ ; if not, compute how many years and quarters we have to shift (via floor*)
+ ; and compute the shifted years, months and quarters
+ (cond
+ ((< (+ (- q 1) shift) 0) ; shift not in this year
+ (setq interval (* -1 (+ (- q 1) shift)))
+ ; set tmp to ((years to shift) (quarters to shift))
+ (setq tmp (org-floor* interval 4))
+ ; due to the use of floor, 0 quarters actually means 4
+ (if (= 0 (nth 1 tmp))
+ (setq shiftedy (- y (nth 0 tmp))
+ shiftedm 1
+ shiftedq 1)
+ (setq shiftedy (- y (+ 1 (nth 0 tmp)))
+ shiftedm (- 13 (* 3 (nth 1 tmp)))
+ shiftedq (- 5 (nth 1 tmp))))
+ (setq d 1 h 0 m 0 d1 1 month shiftedm month1 (+ 3 shiftedm) h1 0 m1 0 y shiftedy))
+ ((> (+ q shift) 0) ; shift is whitin this year
+ (setq shiftedq (+ q shift))
+ (setq shiftedy y)
+ (setq d 1 h 0 m 0 d1 1 month (+ 1 (* 3 (- (+ q shift) 1))) month1 (+ 4 (* 3 (- (+ q shift) 1))) h1 0 m1 0))))
((memq key '(year thisyear))
(setq m 0 h 0 d 1 month 1 y (+ y shift) y1 (1+ y)))
(t (error "No such time block %s" key)))
@@ -1498,11 +1819,21 @@ the returned times will be formatted strings."
((memq key '(month thismonth))
(setq txt (format-time-string "%B %Y" ts)))
((memq key '(year thisyear))
- (setq txt (format-time-string "the year %Y" ts))))
+ (setq txt (format-time-string "the year %Y" ts)))
+ ((memq key '(quarter thisq))
+ (setq txt (concatenate 'string (org-count-quarter shiftedq) " quarter of " (number-to-string shiftedy))))
+ )
(if as-strings
(list (format-time-string fm ts) (format-time-string fm te) txt)
(list ts te txt))))
+(defun org-count-quarter (n)
+ (cond
+ ((= n 1) "1st")
+ ((= n 2) "2nd")
+ ((= n 3) "3rd")
+ ((= n 4) "4th")))
+
(defun org-clocktable-shift (dir n)
"Try to shift the :block date of the clocktable at point.
Point must be in the #+BEGIN: line of a clocktable, or this function
@@ -1516,7 +1847,7 @@ the currently selected interval size."
(and (memq dir '(left down)) (setq n (- n)))
(save-excursion
(goto-char (point-at-bol))
- (if (not (looking-at "#\\+BEGIN: clocktable\\>.*?:block[ \t]+\\(\\S-+\\)"))
+ (if (not (looking-at "^[ \t]*#\\+BEGIN:[ \t]+clocktable\\>.*?:block[ \t]+\\(\\S-+\\)"))
(error "Line needs a :block definition before this command works")
(let* ((b (match-beginning 1)) (e (match-end 1))
(s (match-string 1))
@@ -1525,88 +1856,95 @@ the currently selected interval size."
((equal s "yesterday") (setq s "today-1"))
((equal s "lastweek") (setq s "thisweek-1"))
((equal s "lastmonth") (setq s "thismonth-1"))
- ((equal s "lastyear") (setq s "thisyear-1")))
- (cond
- ((string-match "^\\(today\\|thisweek\\|thismonth\\|thisyear\\)\\([-+][0-9]+\\)?$" s)
- (setq block (match-string 1 s)
- shift (if (match-end 2)
- (string-to-number (match-string 2 s))
- 0))
- (setq shift (+ shift n))
- (setq ins (if (= shift 0) block (format "%s%+d" block shift))))
- ((string-match "\\([0-9]+\\)\\(-\\([wW]?\\)\\([0-9]\\{1,2\\}\\)\\(-\\([0-9]\\{1,2\\}\\)\\)?\\)?" s)
- ;; 1 1 2 3 3 4 4 5 6 6 5 2
- (setq y (string-to-number (match-string 1 s))
- wp (and (match-end 3) (match-string 3 s))
- mw (and (match-end 4) (string-to-number (match-string 4 s)))
- d (and (match-end 6) (string-to-number (match-string 6 s))))
- (cond
- (d (setq ins (format-time-string
- "%Y-%m-%d"
- (encode-time 0 0 0 (+ d n) m y))))
- ((and wp mw (> (length wp) 0))
- (require 'cal-iso)
- (setq date (calendar-gregorian-from-absolute (calendar-absolute-from-iso (list (+ mw n) 1 y))))
- (setq ins (format-time-string
- "%G-W%V"
- (encode-time 0 0 0 (nth 1 date) (car date) (nth 2 date)))))
- (mw
- (setq ins (format-time-string
- "%Y-%m"
- (encode-time 0 0 0 1 (+ mw n) y))))
- (y
- (setq ins (number-to-string (+ y n))))))
- (t (error "Cannot shift clocktable block")))
- (when ins
- (goto-char b)
- (insert ins)
- (delete-region (point) (+ (point) (- e b)))
- (beginning-of-line 1)
- (org-update-dblock)
- t)))))
+ ((equal s "lastyear") (setq s "thisyear-1"))
+ ((equal s "lastq") (setq s "thisq-1")))
+
+ (cond
+ ((string-match "^\\(today\\|thisweek\\|thismonth\\|thisyear\\|thisq\\)\\([-+][0-9]+\\)?$" s)
+ (setq block (match-string 1 s)
+ shift (if (match-end 2)
+ (string-to-number (match-string 2 s))
+ 0))
+ (setq shift (+ shift n))
+ (setq ins (if (= shift 0) block (format "%s%+d" block shift))))
+ ((string-match "\\([0-9]+\\)\\(-\\([wWqQ]?\\)\\([0-9]\\{1,2\\}\\)\\(-\\([0-9]\\{1,2\\}\\)\\)?\\)?" s)
+ ;; 1 1 2 3 3 4 4 5 6 6 5 2
+ (setq y (string-to-number (match-string 1 s))
+ wp (and (match-end 3) (match-string 3 s))
+ mw (and (match-end 4) (string-to-number (match-string 4 s)))
+ d (and (match-end 6) (string-to-number (match-string 6 s))))
+ (cond
+ (d (setq ins (format-time-string
+ "%Y-%m-%d"
+ (encode-time 0 0 0 (+ d n) m y))))
+ ((and wp (string-match "w\\|W" wp) mw (> (length wp) 0))
+ (require 'cal-iso)
+ (setq date (calendar-gregorian-from-absolute (calendar-absolute-from-iso (list (+ mw n) 1 y))))
+ (setq ins (format-time-string
+ "%G-W%V"
+ (encode-time 0 0 0 (nth 1 date) (car date) (nth 2 date)))))
+ ((and wp (string-match "q\\|Q" wp) mw (> (length wp) 0))
+ (require 'cal-iso)
+ ; if the 4th + 1 quarter is requested we flip to the 1st quarter of the next year
+ (if (> (+ mw n) 4)
+ (setq mw 0
+ y (+ 1 y))
+ ())
+ ; if the 1st - 1 quarter is requested we flip to the 4th quarter of the previous year
+ (if (= (+ mw n) 0)
+ (setq mw 5
+ y (- y 1))
+ ())
+ (setq date (calendar-gregorian-from-absolute (calendar-absolute-from-iso (org-quarter-to-date (+ mw n) y))))
+ (setq ins (format-time-string
+ (concatenate 'string (number-to-string y) "-Q" (number-to-string (+ mw n)))
+ (encode-time 0 0 0 (nth 1 date) (car date) (nth 2 date)))))
+ (mw
+ (setq ins (format-time-string
+ "%Y-%m"
+ (encode-time 0 0 0 1 (+ mw n) y))))
+ (y
+ (setq ins (number-to-string (+ y n))))))
+ (t (error "Cannot shift clocktable block")))
+ (when ins
+ (goto-char b)
+ (insert ins)
+ (delete-region (point) (+ (point) (- e b)))
+ (beginning-of-line 1)
+ (org-update-dblock)
+ t)))))
(defun org-dblock-write:clocktable (params)
"Write the standard clocktable."
+ (setq params (org-combine-plists org-clocktable-defaults params))
(catch 'exit
- (let* ((hlchars '((1 . "*") (2 . "/")))
- (ins (make-marker))
- (total-time nil)
- (scope (plist-get params :scope))
- (tostring (plist-get params :tostring))
- (multifile (plist-get params :multifile))
- (header (plist-get params :header))
- (maxlevel (or (plist-get params :maxlevel) 3))
- (step (plist-get params :step))
- (emph (plist-get params :emphasize))
- (timestamp (plist-get params :timestamp))
+ (let* ((scope (plist-get params :scope))
+ (block (plist-get params :block))
(ts (plist-get params :tstart))
(te (plist-get params :tend))
- (block (plist-get params :block))
(link (plist-get params :link))
- 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)
+ (maxlevel (or (plist-get params :maxlevel) 3))
+ (step (plist-get params :step))
+ (timestamp (plist-get params :timestamp))
+ (formatter (or (plist-get params :formatter)
+ org-clock-clocktable-formatter
+ 'org-clocktable-write-default))
+ cc range-text ipos pos one-file-with-archives
+ scope-is-list tbls level)
+
+ ;; Check if we need to do steps
+ (when block
+ ;; Get the range text for the header
+ (setq cc (org-clock-special-range block nil t)
+ ts (car cc) te (nth 1 cc) range-text (nth 2 cc)))
(when step
+ ;; Write many tables, in steps
(unless (or block (and ts te))
(error "Clocktable `:step' can only be used with `:block' or `:tstart,:end'"))
(org-clocktable-steps params)
(throw 'exit nil))
- (when block
- (setq cc (org-clock-special-range block nil t)
- ts (car cc) te (nth 1 cc) range-text (nth 2 cc)))
- (when (integerp ts) (setq ts (calendar-gregorian-from-absolute ts)))
- (when (integerp te) (setq te (calendar-gregorian-from-absolute te)))
- (when (and ts (listp ts))
- (setq ts (format "%4d-%02d-%02d" (nth 2 ts) (car ts) (nth 1 ts))))
- (when (and te (listp te))
- (setq te (format "%4d-%02d-%02d" (nth 2 te) (car te) (nth 1 te))))
- ;; Now the times are strings we can parse.
- (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)))))
- (move-marker ins (point))
- (setq ipos (point))
+
+ (setq ipos (point)) ; remember the insertion position
;; Get the right scope
(setq pos (point))
@@ -1620,171 +1958,298 @@ the currently selected interval size."
(setq scope (org-add-archive-files scope)))
((eq scope 'file-with-archives)
(setq scope (org-add-archive-files (list (buffer-file-name)))
- rm-file-column t)))
+ one-file-with-archives t)))
(setq scope-is-list (and scope (listp scope)))
- (save-restriction
- (cond
- ((not scope))
- ((eq scope 'file) (widen))
- ((eq scope 'subtree) (org-narrow-to-subtree))
- ((eq scope 'tree)
- (while (org-up-heading-safe))
- (org-narrow-to-subtree))
- ((and (symbolp scope) (string-match "^tree\\([0-9]+\\)$"
- (symbol-name scope)))
- (setq level (string-to-number (match-string 1 (symbol-name scope))))
- (catch 'exit
- (while (org-up-heading-safe)
- (looking-at outline-regexp)
- (if (<= (org-reduced-level (funcall outline-level)) level)
- (throw 'exit nil))))
- (org-narrow-to-subtree))
- (scope-is-list
+ (if scope-is-list
+ ;; we collect from several files
(let* ((files scope)
- (scope 'agenda)
- (p1 (copy-sequence params))
file)
- (setq p1 (plist-put p1 :tostring t))
- (setq p1 (plist-put p1 :multifile t))
- (setq p1 (plist-put p1 :scope 'file))
(org-prepare-agenda-buffers files)
(while (setq file (pop files))
(with-current-buffer (find-buffer-visiting file)
- (setq tbl1 (org-dblock-write:clocktable p1))
- (when tbl1
- (push (org-clocktable-add-file
- file
- (concat "| |*File time*|*"
- (org-minutes-to-hh:mm-string
- org-clock-file-total-minutes)
- "*|\n"
- tbl1)) tbl)
- (setq total-time (+ (or total-time 0)
- org-clock-file-total-minutes))))))))
- (goto-char pos)
-
- (unless scope-is-list
- (org-clock-sum ts te)
- (goto-char (point-min))
- (setq st t)
- (while (or (and (bobp) (prog1 st (setq st nil))
- (get-text-property (point) :org-clock-minutes)
- (setq p (point-min)))
- (setq p (next-single-property-change (point) :org-clock-minutes)))
- (goto-char p)
- (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]*$"))
- (setq level (org-reduced-level
- (- (match-end 1) (match-beginning 1))))
- (<= level maxlevel))
- (setq hlc (if emph (or (cdr (assoc level hlchars)) "") "")
- hdl (if (not link)
- (match-string 2)
- (org-make-link-string
- (format "file:%s::%s"
- (buffer-file-name)
- (save-match-data
- (org-make-org-heading-search-string
- (match-string 2))))
- (match-string 2)))
- tsp (when timestamp
- (setq props (org-entry-properties (point)))
- (or (cdr (assoc "SCHEDULED" props))
- (cdr (assoc "TIMESTAMP" props))
- (cdr (assoc "DEADLINE" props))
- (cdr (assoc "TIMESTAMP_IA" props)))))
- (if (and (not multifile) (= level 1)) (push "|-" tbl))
- (push (concat
- "| " (int-to-string level) "|"
- (if timestamp (concat tsp "|") "")
- hlc hdl hlc " |"
- (make-string (1- level) ?|)
- hlc (org-minutes-to-hh:mm-string time) hlc
- " |") tbl))))))
- (setq tbl (nreverse tbl))
- (if tostring
- (if tbl (mapconcat 'identity tbl "\n") nil)
- (goto-char ins)
- (insert-before-markers
- (or header
- (concat
- "Clock summary at ["
- (substring
- (format-time-string (cdr org-time-stamp-formats))
- 1 -1)
- "]"
- (if block (concat ", for " range-text ".") "")
- "\n\n"))
- (if scope-is-list "|File" "")
- "|L|" (if timestamp "Timestamp|" "") "Headline|Time|\n")
- (setq total-time (or total-time org-clock-file-total-minutes))
- (insert-before-markers
- "|-\n|"
- (if scope-is-list "|" "")
- (if timestamp "|Timestamp|" "|")
- "*Total time*| *"
- (org-minutes-to-hh:mm-string (or total-time 0))
- "*|\n|-\n")
- (setq tbl (delq nil tbl))
- (if (and (stringp (car tbl)) (> (length (car tbl)) 1)
- (equal (substring (car tbl) 0 2) "|-"))
- (pop tbl))
- (insert-before-markers (mapconcat
- 'identity (delq nil tbl)
- (if scope-is-list "\n|-\n" "\n")))
- (backward-delete-char 1)
- (if (setq formula (plist-get params :formula))
- (cond
- ((eq formula '%)
- (setq pcol (+ (if scope-is-list 1 0) maxlevel 3))
- (insert
- (format
- "\n#+TBLFM: $%d='(org-clock-time%% @%d$%d $%d..$%d);%%.1f"
- pcol
- 2
- (+ 3 (if scope-is-list 1 0))
- (+ (if scope-is-list 1 0) 3)
- (1- pcol)))
- (setq recalc t))
- ((stringp formula)
- (insert "\n#+TBLFM: " formula)
- (setq recalc t))
- (t (error "invalid formula in clocktable")))
- ;; Should we rescue an old formula?
- (when (stringp (setq content (plist-get params :content)))
- (when (string-match "^\\([ \t]*#\\+TBLFM:.*\\)" content)
- (setq recalc t)
- (insert "\n" (match-string 1 (plist-get params :content)))
- (beginning-of-line 0))))
- (goto-char ipos)
- (skip-chars-forward "^|")
- (org-table-align)
- (when recalc
- (if (eq formula '%)
- (save-excursion (org-table-goto-column pcol nil 'force)
- (insert "%")))
- (org-table-recalculate 'all))
- (when rm-file-column
- (forward-char 1)
- (org-table-delete-column)))))))
+ (save-excursion
+ (save-restriction
+ (push (org-clock-get-table-data file params) tbls))))))
+ ;; Just from the current file
+ (save-restriction
+ ;; get the right range into the restriction
+ (org-prepare-agenda-buffers (list (buffer-file-name)))
+ (cond
+ ((not scope)) ; use the restriction as it is now
+ ((eq scope 'file) (widen))
+ ((eq scope 'subtree) (org-narrow-to-subtree))
+ ((eq scope 'tree)
+ (while (org-up-heading-safe))
+ (org-narrow-to-subtree))
+ ((and (symbolp scope) (string-match "^tree\\([0-9]+\\)$"
+ (symbol-name scope)))
+ (setq level (string-to-number (match-string 1 (symbol-name scope))))
+ (catch 'exit
+ (while (org-up-heading-safe)
+ (looking-at outline-regexp)
+ (if (<= (org-reduced-level (funcall outline-level)) level)
+ (throw 'exit nil))))
+ (org-narrow-to-subtree)))
+ ;; do the table, with no file name.
+ (push (org-clock-get-table-data nil params) tbls)))
+
+ ;; OK, at this point we tbls as a list of tables, one per file
+ (setq tbls (nreverse tbls))
+
+ (setq params (plist-put params :multifile scope-is-list))
+ (setq params (plist-put params :one-file-with-archives
+ one-file-with-archives))
+
+ (funcall formatter ipos tbls params))))
+
+(defun org-clocktable-write-default (ipos tables params)
+ "Write out a clock table at position IPOS in the current buffer.
+TABLES is a list of tables with clocking data as produced by
+`org-clock-get-table-data'. PARAMS is the parameter property list obtained
+from the dynamic block defintion."
+ ;; This function looks quite complicated, mainly because there are a lot
+ ;; of options which can add or remove columns. I have massively commented
+ ;; function, to I hope it is understandable. If someone want to write
+ ;; there own special formatter, this maybe much easier because there can
+ ;; be a fixed format with a well-defined number of columns...
+ (let* ((hlchars '((1 . "*") (2 . "/")))
+ (multifile (plist-get params :multifile))
+ (block (plist-get params :block))
+ (ts (plist-get params :tstart))
+ (te (plist-get params :tend))
+ (header (plist-get params :header))
+ (narrow (plist-get params :narrow))
+ (link (plist-get params :link))
+ (maxlevel (or (plist-get params :maxlevel) 3))
+ (emph (plist-get params :emphasize))
+ (level-p (plist-get params :level))
+ (timestamp (plist-get params :timestamp))
+ (ntcol (max 1 (or (plist-get params :tcolumns) 100)))
+ (rm-file-column (plist-get params :one-file-with-archives))
+ (indent (plist-get params :indent))
+ range-text total-time tbl level hlc formula pcol
+ file-time entries entry headline
+ recalc content narrow-cut-p tcol)
+
+ ;; Implement abbreviations
+ (when (plist-get params :compact)
+ (setq level nil indent t narrow (or narrow '40!) ntcol 1))
+
+ ;; Some consistency test for parameters
+ (unless (integerp ntcol)
+ (setq params (plist-put params :tcolumns (setq ntcol 100))))
+
+ (when (and narrow (integerp narrow) link)
+ ;; We cannot have both integer narrow and link
+ (message
+ "Using hard narrowing in clocktable to allow for links")
+ (setq narrow (intern (format "%d!" narrow))))
+
+ (when narrow
+ (cond
+ ((integerp narrow))
+ ((and (symbolp narrow)
+ (string-match "\\`[0-9]+!\\'" (symbol-name narrow)))
+ (setq narrow-cut-p t
+ narrow (string-to-number (substring (symbol-name narrow)
+ 0 -1))))
+ (t
+ (error "Invalid value %s of :narrow property in clock table"
+ narrow))))
+
+ (when block
+ ;; Get the range text for the header
+ (setq range-text (nth 2 (org-clock-special-range block nil t))))
+
+ ;; Compute the total time
+ (setq total-time (apply '+ (mapcar 'cadr tables)))
+
+ ;; Now we need to output this tsuff
+ (goto-char ipos)
+
+ ;; Insert the text *before* the actual table
+ (insert-before-markers
+ (or header
+ ;; Format the standard header
+ (concat
+ "Clock summary at ["
+ (substring
+ (format-time-string (cdr org-time-stamp-formats))
+ 1 -1)
+ "]"
+ (if block (concat ", for " range-text ".") "")
+ "\n\n")))
+
+ ;; Insert the narrowing line
+ (when (and narrow (integerp narrow) (not narrow-cut-p))
+ (insert-before-markers
+ "|" ; table line starter
+ (if multifile "|" "") ; file column, maybe
+ (if level-p "|" "") ; level column, maybe
+ (if timestamp "|" "") ; timestamp column, maybe
+ (format "<%d>| |\n" narrow))) ; headline and time columns
+
+ ;; Insert the table header line
+ (insert-before-markers
+ "|" ; table line starter
+ (if multifile "File|" "") ; file column, maybe
+ (if level-p "L|" "") ; level column, maybe
+ (if timestamp "Timestamp|" "") ; timestamp column, maybe
+ "Headline|Time|\n") ; headline and time columns
+
+ ;; Insert the total time in the table
+ (insert-before-markers
+ "|-\n" ; a hline
+ "|" ; table line starter
+ (if multifile "| ALL " "") ; file column, maybe
+ (if level-p "|" "") ; level column, maybe
+ (if timestamp "|" "") ; timestamp column, maybe
+ "*Total time*| " ; instead of a headline
+ "*"
+ (org-minutes-to-hh:mm-string (or total-time 0)) ; the time
+ "*|\n") ; close line
+
+ ;; Now iterate over the tables and insert the data
+ ;; but only if any time has been collected
+ (when (and total-time (> total-time 0))
+
+ (while (setq tbl (pop tables))
+ ;; now tbl is the table resulting from one file.
+ (setq file-time (nth 1 tbl))
+ (when (or (and file-time (> file-time 0))
+ (not (plist-get params :fileskip0)))
+ (insert-before-markers "|-\n") ; a hline because a new file starts
+ ;; First the file time, if we have multiple files
+ (when multifile
+ ;; Summarize the time colleted from this file
+ (insert-before-markers
+ (format "| %s %s | %s*File time* | *%s*|\n"
+ (file-name-nondirectory (car tbl))
+ (if level-p "| " "") ; level column, maybe
+ (if timestamp "| " "") ; timestamp column, maybe
+ (org-minutes-to-hh:mm-string (nth 1 tbl))))) ; the time
+
+ ;; Get the list of node entries and iterate over it
+ (setq entries (nth 2 tbl))
+ (while (setq entry (pop entries))
+ (setq level (car entry)
+ headline (nth 1 entry)
+ hlc (if emph (or (cdr (assoc level hlchars)) "") ""))
+ (when narrow-cut-p
+ (if (and (string-match (concat "\\`" org-bracket-link-regexp
+ "\\'")
+ headline)
+ (match-end 3))
+ (setq headline
+ (format "[[%s][%s]]"
+ (match-string 1 headline)
+ (org-shorten-string (match-string 3 headline)
+ narrow)))
+ (setq headline (org-shorten-string headline narrow))))
+ (insert-before-markers
+ "|" ; start the table line
+ (if multifile "|" "") ; free space for file name column?
+ (if level-p (format "%d|" (car entry)) "") ; level, maybe
+ (if timestamp (concat (nth 2 entry) "|") "") ; timestamp, maybe
+ (if indent (org-clocktable-indent-string level) "") ; indentation
+ hlc headline hlc "|" ; headline
+ (make-string (min (1- ntcol) (or (- level 1))) ?|)
+ ; empty fields for higher levels
+ hlc (org-minutes-to-hh:mm-string (nth 3 entry)) hlc ; time
+ "|\n" ; close line
+ )))))
+ (backward-delete-char 1)
+ (if (setq formula (plist-get params :formula))
+ (cond
+ ((eq formula '%)
+ ;; compute the column where the % numbers need to go
+ (setq pcol (+ 2
+ (if multifile 1 0)
+ (if level-p 1 0)
+ (if timestamp 1 0)
+ (min maxlevel (or ntcol 100))))
+ ;; compute the column where the total time is
+ (setq tcol (+ 2
+ (if multifile 1 0)
+ (if level-p 1 0)
+ (if timestamp 1 0)))
+ (insert
+ (format
+ "\n#+TBLFM: $%d='(org-clock-time%% @%d$%d $%d..$%d);%%.1f"
+ pcol ; the column where the % numbers should go
+ (if (and narrow (not narrow-cut-p)) 3 2) ; row of the total time
+ tcol ; column of the total time
+ tcol (1- pcol) ; range of columns where times can be found
+ ))
+ (setq recalc t))
+ ((stringp formula)
+ (insert "\n#+TBLFM: " formula)
+ (setq recalc t))
+ (t (error "invalid formula in clocktable")))
+ ;; Should we rescue an old formula?
+ (when (stringp (setq content (plist-get params :content)))
+ (when (string-match "^\\([ \t]*#\\+TBLFM:.*\\)" content)
+ (setq recalc t)
+ (insert "\n" (match-string 1 (plist-get params :content)))
+ (beginning-of-line 0))))
+ ;; Back to beginning, align the table, recalculate if necessary
+ (goto-char ipos)
+ (skip-chars-forward "^|")
+ (org-table-align)
+ (when org-hide-emphasis-markers
+ ;; we need to align a second time
+ (org-table-align))
+ (when recalc
+ (if (eq formula '%)
+ (save-excursion
+ (if (and narrow (not narrow-cut-p)) (beginning-of-line 2))
+ (org-table-goto-column pcol nil 'force)
+ (insert "%")))
+ (org-table-recalculate 'all))
+ (when rm-file-column
+ ;; The file column is actually not wanted
+ (forward-char 1)
+ (org-table-delete-column))
+ total-time))
+
+(defun org-clocktable-indent-string (level)
+ (if (= level 1)
+ ""
+ (let ((str "\\__"))
+ (while (> level 2)
+ (setq level (1- level)
+ str (concat str "___")))
+ (concat str " "))))
(defun org-clocktable-steps (params)
+ "Step through the range to make a number of clock tables."
(let* ((p1 (copy-sequence params))
(ts (plist-get p1 :tstart))
(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))
@@ -1796,23 +2261,107 @@ the currently selected interval size."
(setq p1 (plist-put p1 :tend (format-time-string
(org-time-stamp-format nil t)
(seconds-to-time (setq ts (+ ts step))))))
- (insert "\n" (if (eq step0 'day) "Daily report: " "Weekly report starting on: ")
+ (insert "\n" (if (eq step0 'day) "Daily report: "
+ "Weekly report starting on: ")
(plist-get p1 :tstart) "\n")
- (org-dblock-write:clocktable p1)
- (re-search-forward "#\\+END:")
+ (setq step-time (org-dblock-write:clocktable p1))
+ (re-search-forward "^[ \t]*#\\+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)
- (if table
- (let ((lines (org-split-string table "\n"))
- (ff (file-name-nondirectory file)))
- (mapconcat 'identity
- (mapcar (lambda (x)
- (if (string-match org-table-dataline-regexp x)
- (concat "|" ff x)
- x))
- lines)
- "\n"))))
+(defun org-clock-get-table-data (file params)
+ "Get the clocktable data for file FILE, with parameters PARAMS.
+FILE is only for identification - this function assumes that
+the correct buffer is current, and that the wanted restriction is
+in place.
+The return value will be a list with the file name and the total
+file time (in minutes) as 1st and 2nd elements. The third element
+of this list will be a list of headline entries. Each entry has the
+following structure:
+
+ (LEVEL HEADLINE TIMESTAMP TIME)
+
+LEVEL: The level of the headline, as an integer. This will be
+ the reduced leve, so 1,2,3,... even if only odd levels
+ are being used.
+HEADLINE: The text of the headline. Depending on PARAMS, this may
+ already be formatted like a link.
+TIMESTAMP: If PARAMS require it, this will be a time stamp found in the
+ entry, any of SCHEDULED, DEADLINE, NORMAL, or first inactive,
+ in this sequence.
+TIME: The sum of all time spend in this tree, in minutes. This time
+ will of cause be restricted to the time block and tags match
+ specified in PARAMS."
+ (let* ((maxlevel (or (plist-get params :maxlevel) 3))
+ (timestamp (plist-get params :timestamp))
+ (ts (plist-get params :tstart))
+ (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))))
+ cc range-text st p time level hdl props tsp tbl)
+
+ (setq org-clock-file-total-minutes nil)
+ (when block
+ (setq cc (org-clock-special-range block nil t)
+ ts (car cc) te (nth 1 cc) range-text (nth 2 cc)))
+ (when (integerp ts) (setq ts (calendar-gregorian-from-absolute ts)))
+ (when (integerp te) (setq te (calendar-gregorian-from-absolute te)))
+ (when (and ts (listp ts))
+ (setq ts (format "%4d-%02d-%02d" (nth 2 ts) (car ts) (nth 1 ts))))
+ (when (and te (listp te))
+ (setq te (format "%4d-%02d-%02d" (nth 2 te) (car te) (nth 1 te))))
+ ;; Now the times are strings we can parse.
+ (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)))))
+ (save-excursion
+ (org-clock-sum ts te
+ (unless (null matcher)
+ (lambda ()
+ (let ((tags-list (org-get-tags-at)))
+ (eval matcher)))))
+ (goto-char (point-min))
+ (setq st t)
+ (while (or (and (bobp) (prog1 st (setq st nil))
+ (get-text-property (point) :org-clock-minutes)
+ (setq p (point-min)))
+ (setq p (next-single-property-change
+ (point) :org-clock-minutes)))
+ (goto-char p)
+ (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]*$"))
+ (setq level (org-reduced-level
+ (- (match-end 1) (match-beginning 1))))
+ (<= level maxlevel))
+ (setq hdl (if (not link)
+ (match-string 2)
+ (org-make-link-string
+ (format "file:%s::%s"
+ (buffer-file-name)
+ (save-match-data
+ (org-make-org-heading-search-string
+ (match-string 2))))
+ (match-string 2)))
+ tsp (when timestamp
+ (setq props (org-entry-properties (point)))
+ (or (cdr (assoc "SCHEDULED" props))
+ (cdr (assoc "DEADLINE" props))
+ (cdr (assoc "TIMESTAMP" props))
+ (cdr (assoc "TIMESTAMP_IA" props)))))
+ (when (> time 0) (push (list level hdl tsp time) tbl))))))
+ (setq tbl (nreverse tbl))
+ (list file org-clock-file-total-minutes tbl))))
(defun org-clock-time% (total &rest strings)
"Compute a time fraction in percent.
@@ -1833,7 +2382,8 @@ This function is made for clock tables."
(if (string-match "\\([0-9]+\\):\\([0-9]+\\)" s)
(throw 'exit
(/ (* 100.0 (+ (string-to-number (match-string 2 s))
- (* 60 (string-to-number (match-string 1 s)))))
+ (* 60 (string-to-number
+ (match-string 1 s)))))
tot))))
0))))
@@ -1857,16 +2407,17 @@ 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)
(or (not org-clock-persist-query-save)
(y-or-n-p (concat "Save current clock ("
- (substring-no-properties org-clock-heading)
+ (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 +2483,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))
@@ -1941,6 +2492,6 @@ The details of what will be saved are regulated by the variable
(provide 'org-clock)
-;; arch-tag: 7b42c5d4-9b36-48be-97c0-66a869daed4c
;;; org-clock.el ends here
+
diff --git a/lisp/org/org-colview.el b/lisp/org/org-colview.el
index 683b845c3ef..35a23052e8a 100644
--- a/lisp/org/org-colview.el
+++ b/lisp/org/org-colview.el
@@ -1,12 +1,11 @@
;;; org-colview.el --- Column View in Org-mode
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; This file is part of GNU Emacs.
;;
@@ -36,6 +35,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 +148,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 +222,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 +239,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 +304,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 +329,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 +465,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 +501,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 +518,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 +630,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 +749,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 +925,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 +1035,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 +1059,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 +1119,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 +1392,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 +1420,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 +1488,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,9 +1498,43 @@ 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)
-;; arch-tag: 61f5128d-747c-4983-9479-e3871fa3d73c
;;; org-colview.el ends here
diff --git a/lisp/org/org-compat.el b/lisp/org/org-compat.el
index f0d0904b735..efe54c568b3 100644
--- a/lisp/org/org-compat.el
+++ b/lisp/org/org-compat.el
@@ -1,12 +1,11 @@
;;; org-compat.el --- Compatibility code for Org-mode
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; This file is part of GNU Emacs.
;;
@@ -39,7 +38,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 +88,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 +145,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 +192,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 +205,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 +248,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 +262,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,8 +371,59 @@ TIME defaults to the current time."
(time-to-seconds (or time (current-time)))
(float-time time)))
+(if (fboundp 'string-match-p)
+ (defalias 'org-string-match-p 'string-match-p)
+ (defun org-string-match-p (regexp string &optional start)
+ (save-match-data
+ (funcall 'string-match regexp string start))))
+
+(if (fboundp 'looking-at-p)
+ (defalias 'org-looking-at-p 'looking-at-p)
+ (defun org-looking-at-p (&rest 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)))))
+
+(defun org-floor* (x &optional y)
+ "Return a list of the floor of X and the fractional part of X.
+With two arguments, return floor and remainder of their quotient."
+ (let ((q (floor x y)))
+ (list q (- x (if y (* y q) q)))))
+
(provide 'org-compat)
-;; arch-tag: a0a0579f-e68c-4bdf-9e55-93768b846bbe
;;; org-compat.el ends here
diff --git a/lisp/org/org-complete.el b/lisp/org/org-complete.el
new file mode 100644
index 00000000000..07c1ba2e4f2
--- /dev/null
+++ b/lisp/org/org-complete.el
@@ -0,0 +1,277 @@
+;;; org-complete.el --- In-buffer completion code
+
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
+;;
+;; Author: Carsten Dominik <carsten at orgmode dot org>
+;; John Wiegley <johnw at gnu dot org>
+;; Keywords: outlines, hypermedia, calendar, wp
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+;;
+;; 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:
+
+;;;; Require other packages
+
+(eval-when-compile
+ (require 'cl))
+
+(require 'org-macs)
+(require 'pcomplete)
+
+(declare-function org-split-string "org" (string &optional separators))
+(declare-function org-get-current-options "org-exp" ())
+(declare-function org-make-org-heading-search-string "org"
+ (&optional string heading))
+(declare-function org-get-buffer-tags "org" ())
+(declare-function org-get-tags "org" ())
+(declare-function org-buffer-property-keys "org"
+ (&optional include-specials include-defaults include-columns))
+(declare-function org-entry-properties "org" (&optional pom which specific))
+
+;;;; Customization variables
+
+(defgroup org-complete nil
+ "Outline-based notes management and organizer."
+ :tag "Org"
+ :group 'org)
+
+(defun org-thing-at-point ()
+ "Examine the thing at point and let the caller know what it is.
+The return value is a string naming the thing at point."
+ (let ((beg1 (save-excursion
+ (skip-chars-backward (org-re "[:alnum:]_@"))
+ (point)))
+ (beg (save-excursion
+ (skip-chars-backward "a-zA-Z0-9_:$")
+ (point)))
+ (line-to-here (buffer-substring (point-at-bol) (point))))
+ (cond
+ ((string-match "\\`[ \t]*#\\+begin: clocktable[ \t]+" line-to-here)
+ (cons "block-option" "clocktable"))
+ ((string-match "\\`[ \t]*#\\+begin_src[ \t]+" line-to-here)
+ (cons "block-option" "src"))
+ ((save-excursion
+ (re-search-backward "^[ \t]*#\\+\\([A-Z_]+\\):.*"
+ (line-beginning-position) t))
+ (cons "file-option" (match-string-no-properties 1)))
+ ((string-match "\\`[ \t]*#\\+[a-zA-Z]*\\'" line-to-here)
+ (cons "file-option" nil))
+ ((equal (char-before beg) ?\[)
+ (cons "link" nil))
+ ((equal (char-before beg) ?\\)
+ (cons "tex" nil))
+ ((string-match "\\`\\*+[ \t]+\\'"
+ (buffer-substring (point-at-bol) beg))
+ (cons "todo" nil))
+ ((equal (char-before beg) ?*)
+ (cons "searchhead" nil))
+ ((and (equal (char-before beg1) ?:)
+ (equal (char-after (point-at-bol)) ?*))
+ (cons "tag" nil))
+ ((and (equal (char-before beg1) ?:)
+ (not (equal (char-after (point-at-bol)) ?*)))
+ (cons "prop" nil))
+ (t nil))))
+
+(defun org-command-at-point ()
+ "Return the qualified name of the Org completion entity at point.
+When completing for #+STARTUP, for example, this function returns
+\"file-option/startup\"."
+ (let ((thing (org-thing-at-point)))
+ (cond
+ ((string= "file-option" (car thing))
+ (concat (car thing) "/" (downcase (cdr thing))))
+ ((string= "block-option" (car thing))
+ (concat (car thing) "/" (downcase (cdr thing))))
+ (t
+ (car thing)))))
+
+(defun org-parse-arguments ()
+ "Parse whitespace separated arguments in the current region."
+ (let ((begin (line-beginning-position))
+ (end (line-end-position))
+ begins args)
+ (save-restriction
+ (narrow-to-region begin end)
+ (save-excursion
+ (goto-char (point-min))
+ (while (not (eobp))
+ (skip-chars-forward " \t\n[")
+ (setq begins (cons (point) begins))
+ (skip-chars-forward "^ \t\n[")
+ (setq args (cons (buffer-substring-no-properties
+ (car begins) (point))
+ args)))
+ (cons (reverse args) (reverse begins))))))
+
+
+(defun org-complete-initial ()
+ "Calls the right completion function for first argument completions."
+ (ignore
+ (funcall (or (pcomplete-find-completion-function
+ (car (org-thing-at-point)))
+ pcomplete-default-completion-function))))
+
+(defvar org-additional-option-like-keywords)
+(defun pcomplete/org-mode/file-option ()
+ "Complete against all valid file options."
+ (require 'org-exp)
+ (pcomplete-here
+ (org-complete-case-double
+ (mapcar (lambda (x)
+ (if (= ?: (aref x (1- (length x))))
+ (concat x " ")
+ x))
+ (delq nil
+ (pcomplete-uniqify-list
+ (append
+ (mapcar (lambda (x)
+ (if (string-match "^#\\+\\([A-Z_]+:?\\)" x)
+ (match-string 1 x)))
+ (org-split-string (org-get-current-options) "\n"))
+ org-additional-option-like-keywords)))))
+ (substring pcomplete-stub 2)))
+
+(defvar org-startup-options)
+(defun pcomplete/org-mode/file-option/startup ()
+ "Complete arguments for the #+STARTUP file option."
+ (while (pcomplete-here
+ (let ((opts (pcomplete-uniqify-list
+ (mapcar 'car org-startup-options))))
+ ;; Some options are mutually exclusive, and shouldn't be completed
+ ;; against if certain other options have already been seen.
+ (dolist (arg pcomplete-args)
+ (cond
+ ((string= arg "hidestars")
+ (setq opts (delete "showstars" opts)))))
+ opts))))
+
+(defun pcomplete/org-mode/file-option/bind ()
+ "Complete arguments for the #+BIND file option, which are variable names"
+ (let (vars)
+ (mapatoms
+ (lambda (a) (if (boundp a) (setq vars (cons (symbol-name a) vars)))))
+ (pcomplete-here vars)))
+
+(defvar org-link-abbrev-alist-local)
+(defvar org-link-abbrev-alist)
+(defun pcomplete/org-mode/link ()
+ "Complete against defined #+LINK patterns."
+ (pcomplete-here
+ (pcomplete-uniqify-list (append (mapcar 'car org-link-abbrev-alist-local)
+ (mapcar 'car org-link-abbrev-alist)))))
+
+(defvar org-entities)
+(defun pcomplete/org-mode/tex ()
+ "Complete against TeX-style HTML entity names."
+ (require 'org-entities)
+ (while (pcomplete-here
+ (pcomplete-uniqify-list (remove nil (mapcar 'car-safe org-entities)))
+ (substring pcomplete-stub 1))))
+
+(defvar org-todo-keywords-1)
+(defun pcomplete/org-mode/todo ()
+ "Complete against known TODO keywords."
+ (pcomplete-here (pcomplete-uniqify-list org-todo-keywords-1)))
+
+(defvar org-todo-line-regexp)
+(defun pcomplete/org-mode/searchhead ()
+ "Complete against all headings.
+This needs more work, to handle headings with lots of spaces in them."
+ (while
+ (pcomplete-here
+ (save-excursion
+ (goto-char (point-min))
+ (let (tbl)
+ (while (re-search-forward org-todo-line-regexp nil t)
+ (push (org-make-org-heading-search-string
+ (match-string-no-properties 3) t)
+ tbl))
+ (pcomplete-uniqify-list tbl)))
+ (substring pcomplete-stub 1))))
+
+(defvar org-tag-alist)
+(defun pcomplete/org-mode/tag ()
+ "Complete a tag name. Omit tags already set."
+ (while (pcomplete-here
+ (mapcar (lambda (x)
+ (concat x ":"))
+ (let ((lst (pcomplete-uniqify-list
+ (or (remove
+ nil
+ (mapcar (lambda (x)
+ (and (stringp (car x)) (car x)))
+ org-tag-alist))
+ (mapcar 'car (org-get-buffer-tags))))))
+ (dolist (tag (org-get-tags))
+ (setq lst (delete tag lst)))
+ lst))
+ (and (string-match ".*:" pcomplete-stub)
+ (substring pcomplete-stub (match-end 0))))))
+
+(defun pcomplete/org-mode/prop ()
+ "Complete a property name. Omit properties already set."
+ (pcomplete-here
+ (mapcar (lambda (x)
+ (concat x ": "))
+ (let ((lst (pcomplete-uniqify-list
+ (org-buffer-property-keys nil t t))))
+ (dolist (prop (org-entry-properties))
+ (setq lst (delete (car prop) lst)))
+ lst))
+ (substring pcomplete-stub 1)))
+
+(defun pcomplete/org-mode/block-option/src ()
+ "Complete the arguments of a begin_src block.
+Complete a language in the first field, the header arguments and switches."
+ (pcomplete-here
+ (mapcar
+ (lambda(x) (symbol-name (nth 3 x)))
+ (cdr (car (cdr (memq :key-type (plist-get
+ (symbol-plist
+ 'org-babel-load-languages)
+ 'custom-type)))))))
+ (while (pcomplete-here
+ '("-n" "-r" "-l"
+ ":cache" ":colnames" ":comments" ":dir" ":eval" ":exports"
+ ":file" ":hlines" ":no-expand" ":noweb" ":results" ":rownames"
+ ":session" ":shebang" ":tangle" ":var"))))
+
+(defun pcomplete/org-mode/block-option/clocktable ()
+ "Complete keywords in a clocktable line"
+ (while (pcomplete-here '(":maxlevel" ":scope"
+ ":tstart" ":tend" ":block" ":step"
+ ":stepskip0" ":fileskip0"
+ ":emphasize" ":link" ":narrow" ":indent"
+ ":tcolumns" ":level" ":compact" ":timestamp"
+ ":formula" ":formatter"))))
+
+(defun org-complete-case-double (list)
+ "Return list with both upcase and downcase version of all strings in LIST."
+ (let (e res)
+ (while (setq e (pop list))
+ (setq res (cons (downcase e) (cons (upcase e) res))))
+ (nreverse res)))
+
+;;;; Finish up
+
+(provide 'org-complete)
+
+
+;;; org-complete.el ends here
diff --git a/lisp/org/org-crypt.el b/lisp/org/org-crypt.el
index aee5f43007d..0a6001bf62a 100644
--- a/lisp/org/org-crypt.el
+++ b/lisp/org/org-crypt.el
@@ -1,10 +1,10 @@
;;; org-crypt.el --- Public key encryption for org-mode entries
-;; Copyright (C) 2007, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007, 2009-2011 Free Software Foundation, Inc.
;; Emacs Lisp Archive Entry
;; Filename: org-crypt.el
-;; Version: 6.33x
+;; Version: 7.4
;; 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,73 +109,78 @@ 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
;;; org-crypt.el ends here
diff --git a/lisp/org/org-ctags.el b/lisp/org/org-ctags.el
new file mode 100644
index 00000000000..3bbfe18e1b4
--- /dev/null
+++ b/lisp/org/org-ctags.el
@@ -0,0 +1,540 @@
+;;; org-ctags.el - Integrate Emacs "tags" facility with org mode.
+;;
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
+
+;; Author: Paul Sexton <eeeickythump@gmail.com>
+;; Version: 7.4
+
+;; Keywords: org, wp
+;; Version: 7.4
+;;
+;; 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)
+
+;;; org-ctags.el ends here
diff --git a/lisp/org/org-datetree.el b/lisp/org/org-datetree.el
index 1a80519e4d5..47ca287d8fc 100644
--- a/lisp/org/org-datetree.el
+++ b/lisp/org/org-datetree.el
@@ -1,11 +1,11 @@
;;; org-datetree.el --- Create date entries in a tree
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; 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))
@@ -194,6 +195,5 @@ before running this command, even though the command tries to be smart."
(provide 'org-datetree)
-;; arch-tag: 1daea962-fd08-448b-9f98-6e8b511b3601
;;; org-datetree.el ends here
diff --git a/lisp/org/org-docbook.el b/lisp/org/org-docbook.el
index 22081ab4f32..e883d71b6f4 100644
--- a/lisp/org/org-docbook.el
+++ b/lisp/org/org-docbook.el
@@ -1,10 +1,10 @@
;;; org-docbook.el --- DocBook exporter for org-mode
;;
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;;
;; Emacs Lisp Archive Entry
;; Filename: org-docbook.el
-;; Version: 6.33x
+;; Version: 7.4
;; 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.
@@ -1410,5 +1440,4 @@ that need to be preserved in later phase of DocBook exporting."
(provide 'org-docbook)
-;; arch-tag: a24a127c-d365-4c2a-9e9b-f7dcb0ebfdc3
;;; org-docbook.el ends here
diff --git a/lisp/org/org-docview.el b/lisp/org/org-docview.el
new file mode 100644
index 00000000000..ee39d8afc63
--- /dev/null
+++ b/lisp/org/org-docview.el
@@ -0,0 +1,92 @@
+;;; org-docview.el --- support for links to doc-view-mode buffers
+
+;; Copyright (C) 2009-2011 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.4
+;;
+;; 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)
+
+
+;;; 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..7115972b73e
--- /dev/null
+++ b/lisp/org/org-entities.el
@@ -0,0 +1,572 @@
+;;; org-entities.el --- Support for special entities in Org-mode
+
+;; Copyright (C) 2010-2011 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.4
+;;
+;; 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:
+
+
+;;; org-entities.el ends here
diff --git a/lisp/org/org-exp-blocks.el b/lisp/org/org-exp-blocks.el
index 30400754f27..f5b635838fe 100644
--- a/lisp/org/org-exp-blocks.el
+++ b/lisp/org/org-exp-blocks.el
@@ -1,9 +1,9 @@
;;; org-exp-blocks.el --- pre-process blocks when exporting org files
-;; Copyright (C) 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
;; Author: Eric Schulte
+;; Version: 7.4
;; This file is part of GNU Emacs.
;;
@@ -67,6 +67,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 +94,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 +107,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 +123,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 +153,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 +163,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 +187,18 @@ 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))))))
-
-(add-hook 'org-export-preprocess-hook 'org-export-blocks-preprocess)
+ (interblock start (point-max))
+ (run-hooks 'org-export-blocks-postblock-hook)))))
;;================================================================================
;; type specific functions
@@ -209,7 +214,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 +224,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 +286,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)
@@ -342,5 +351,4 @@ other backends, it converts the comment into an EXAMPLE segment."
(provide 'org-exp-blocks)
-;; arch-tag: 1c365fe9-8808-4f72-bb15-0b00f36d8024
;;; org-exp-blocks.el ends here
diff --git a/lisp/org/org-exp.el b/lisp/org/org-exp.el
index 11452045384..002ad025fbe 100644
--- a/lisp/org/org-exp.el
+++ b/lisp/org/org-exp.el
@@ -1,12 +1,11 @@
;;; org-exp.el --- ASCII, HTML, XOXO and iCalendar export for Org-mode
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; This file is part of GNU Emacs.
;;
@@ -26,11 +25,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 +45,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 +59,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 +72,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 +81,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 +98,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 +127,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 +137,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 +180,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 +211,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 +227,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 +237,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 +254,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 +276,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 +315,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-info:nil\"."
+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. \"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 +368,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 +378,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 +402,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 +438,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 +456,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 +470,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:mathjax\".
+
+Allowed values are:
-This option can also be set with the +OPTIONS line, e.g. \"LaTeX:t\".
+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 +513,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 +533,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 +551,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 +610,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 +688,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 +727,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 +765,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 +811,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 +871,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 +908,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 +920,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 +934,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 +944,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 +983,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 (org-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 +1029,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 +1062,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,12 +1076,21 @@ 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)
+
+ ;; Export code blocks
+ (org-export-blocks-preprocess)
+
;; Handle source code snippets
(org-export-replace-src-segments-and-examples backend)
;; Protect short examples marked by a leading colon
(org-export-protect-colon-examples)
+ ;; Protected spaces
+ (org-export-convert-protected-spaces backend)
+
;; Normalize footnotes
(when (plist-get parameters :footnotes)
(org-footnote-normalize nil t))
@@ -1309,6 +1098,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 +1127,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 +1153,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 +1172,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 +1201,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 +1220,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 +1304,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 +1329,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 +1352,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 +1487,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))
@@ -1713,6 +1541,26 @@ from the buffer."
(add-text-properties (point) (org-end-of-subtree t)
'(org-protected t)))))
+(defun org-export-convert-protected-spaces (backend)
+ "Convert strings like \\____ to protected spaces in all backends."
+ (goto-char (point-min))
+ (while (re-search-forward "\\\\__+" nil t)
+ (org-if-unprotected-1
+ (replace-match
+ (org-add-props
+ (cond
+ ((eq backend 'latex)
+ (format "\\hspace{%dex}" (- (match-end 0) (match-beginning 0))))
+ ((eq backend 'html)
+ (org-add-props (match-string 0) nil
+ 'org-whitespace (- (match-end 0) (match-beginning 0))))
+ ;; ((eq backend 'docbook))
+ ((eq backend 'ascii)
+ (org-add-props (match-string 0) '(org-whitespace t)))
+ (t (make-string (- (match-end 0) (match-beginning 0)) ?\ )))
+ '(org-protected t))
+ t t))))
+
(defun org-export-protect-verbatim ()
"Mark verbatim snippets with the protection property."
(goto-char (point-min))
@@ -1739,6 +1587,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 +1595,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 +1647,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 +1656,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 +1695,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 +1752,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 (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 (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 (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 +1793,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 +1855,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 +1905,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 +1918,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 +2089,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,12 +2125,13 @@ 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 minlevel)
(goto-char (point-min))
(while (re-search-forward "^#\\+INCLUDE:?[ \t]+\\(.*\\)" nil t)
(setq params (read (concat "(" (match-string 1) ")"))
prefix (org-get-and-remove-property 'params :prefix)
prefix1 (org-get-and-remove-property 'params :prefix1)
+ minlevel (org-get-and-remove-property 'params :minlevel)
file (org-symname-or-string (pop params))
markup (org-symname-or-string (pop params))
lang (and (member markup '("src" "SRC"))
@@ -2198,6 +2143,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"
@@ -2208,11 +2154,24 @@ TYPE must be a string, any of:
end (format "#+end_%s" markup))))
(insert (or start ""))
(insert (org-get-file-contents (expand-file-name file)
- prefix prefix1 markup))
+ prefix prefix1 markup minlevel))
(or (bolp) (newline))
- (insert (or end ""))))))
-
-(defun org-get-file-contents (file &optional prefix prefix1 markup)
+ (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 minlevel)
"Get the contents of FILE and return them as a string.
If PREFIX is a string, prepend it to each line. If PREFIX1
is a string, prepend it to the first line instead of PREFIX.
@@ -2225,7 +2184,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"))
@@ -2234,6 +2193,9 @@ take care of the block they are in."
(goto-char (match-beginning 0))
(insert ",")
(end-of-line 1)))
+ (when minlevel
+ (dotimes (lvl minlevel)
+ (org-map-region 'org-demote (point-min) (point-max))))
(buffer-string)))
(defun org-get-and-remove-property (listvar prop)
@@ -2263,24 +2225,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 +2262,10 @@ 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
(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 +2316,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 +2355,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 +2387,60 @@ 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}{%s}\n" 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 +2448,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 +2551,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 +2579,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)
@@ -2587,9 +2611,10 @@ use it. The prefix arg ARG is passed through to the exporting command."
;; does do the trick.
(if (looking-at "#[^\r\n]*")
(append-to-buffer buffer (match-beginning 0) (1+ (match-end 0))))
- (while (re-search-forward "[\n\r]#[^\n\r]*" nil t)
- (append-to-buffer buffer (1+ (match-beginning 0))
- (min (point-max) (1+ (match-end 0))))))
+ (when (re-search-forward "^\\*+[ \t]+" nil t)
+ (while (re-search-backward "[\n\r]#[^\n\r]*" nil t)
+ (append-to-buffer buffer (1+ (match-beginning 0))
+ (min (point-max) (1+ (match-end 0)))))))
(set-buffer buffer)
(let ((buffer-file-name file)
(org-inhibit-startup t))
@@ -2614,6 +2639,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 +2702,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 +2749,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 +2775,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 +2868,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 +2886,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 +2908,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 +2923,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 +2935,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)
@@ -2930,7 +2961,6 @@ The depends on the variable `org-export-copy-to-kill'."
(provide 'org-exp)
-;; arch-tag: 65985fe9-095c-49c7-a7b6-cb4ee15c0a95
;;; org-exp.el ends here
diff --git a/lisp/org/org-faces.el b/lisp/org/org-faces.el
index 70bd7eb0cb1..e5877768fe7 100644
--- a/lisp/org/org-faces.el
+++ b/lisp/org/org-faces.el
@@ -1,12 +1,11 @@
;;; org-faces.el --- Face definitions for Org-mode.
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; This file is part of GNU Emacs.
;;
@@ -49,7 +48,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"))
@@ -247,9 +246,7 @@ column view defines special faces for each outline level. See the file
:group 'org-faces)
(defface org-link
- '((((class color) (background light)) (:foreground "Purple" :underline t))
- (((class color) (background dark)) (:foreground "Cyan" :underline t))
- (t (:underline t)))
+ '((t :inherit link))
"Face for links."
:group 'org-faces)
@@ -338,29 +335,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 +399,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 +419,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 +455,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 +465,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 +526,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 +561,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 +597,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 +664,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
@@ -617,6 +682,15 @@ If it is less than 8, the level-1 face gets re-used for level N+1 etc."
:type 'integer
:group 'org-faces)
+(defcustom org-cycle-level-faces t
+ "Non-nil means level styles cycle after level `org-n-level-faces'.
+Then so level org-n-level-faces+1 is styled like level 1.
+If nil, then all levels >=org-n-level-faces are styled like
+level org-n-level-faces"
+ :group 'org-appearance
+ :group 'org-faces
+ :type 'boolean)
+
(defface org-latex-and-export-specials
(let ((font (cond ((assq :inherit custom-face-attributes)
'(:inherit underline))
@@ -634,10 +708,12 @@ 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)
-;; arch-tag: 9dab5f91-c4b9-4d6f-bac3-1f6211ad0a04
;;; org-faces.el ends here
diff --git a/lisp/org/org-feed.el b/lisp/org/org-feed.el
index 8f973b96908..07558af462f 100644
--- a/lisp/org/org-feed.el
+++ b/lisp/org/org-feed.el
@@ -1,11 +1,11 @@
;;; org-feed.el --- Add RSS feed items to Org files
;;
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; 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,31 +640,38 @@ 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)
-;; arch-tag: 0929b557-9bc4-47f4-9633-30a12dbb5ae2
;;; org-feed.el ends here
diff --git a/lisp/org/org-footnote.el b/lisp/org/org-footnote.el
index d606049336c..c0ca570b7b7 100644
--- a/lisp/org/org-footnote.el
+++ b/lisp/org/org-footnote.el
@@ -1,11 +1,11 @@
;;; org-footnote.el --- Footnote support in Org and elsewhere
;;
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; 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 (derived-mode-p '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.
@@ -572,6 +585,5 @@ and all references of a footnote label."
(provide 'org-footnote)
-;; arch-tag: 1b5954df-fb5d-4da5-8709-78d944dbfc37
;;; org-footnote.el ends here
diff --git a/lisp/org/org-freemind.el b/lisp/org/org-freemind.el
index dc3b8c2dd4b..dccdf449296 100644
--- a/lisp/org/org-freemind.el
+++ b/lisp/org/org-freemind.el
@@ -1,11 +1,11 @@
;;; org-freemind.el --- Export Org files to freemind
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
;; Author: Lennart Borgman (lennart O borgman A gmail O com)
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; 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))
@@ -1068,8 +1172,8 @@ PATH should be a list of steps, where each step has the form
(when (< 0 (- level skip-levels))
(dolist (attrib attributes)
(case (car attrib)
- ('TEXT (setq text (cdr attrib)))
- ('text (setq text (cdr attrib)))))
+ (TEXT (setq text (cdr attrib)))
+ (text (setq text (cdr attrib)))))
(unless text
;; There should be a richcontent node holding the text:
(setq text (org-freemind-get-richcontent-node-text node)))
@@ -1089,8 +1193,10 @@ PATH should be a list of steps, where each step has the form
(setq text (replace-regexp-in-string "\n $" "" text))
(insert text))
(case qname
- ('node
+ (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
@@ -1131,7 +1237,6 @@ PATH should be a list of steps, where each step has the form
(provide 'org-freemind)
-;; arch-tag: e7b0d776-94fd-404a-b35e-0f855fae3627
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; org-freemind.el ends here
diff --git a/lisp/org/org-gnus.el b/lisp/org/org-gnus.el
index da640cfa05a..e8424a1e5cd 100644
--- a/lisp/org/org-gnus.el
+++ b/lisp/org/org-gnus.el
@@ -1,13 +1,12 @@
;;; org-gnus.el --- Support for links to Gnus groups and messages from within Org-mode
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Tassilo Horn <tassilo at member dot fsf dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; This file is part of GNU Emacs.
;;
@@ -39,22 +38,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 +72,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 +146,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 +217,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))))
@@ -192,6 +257,5 @@ If `org-store-link' was called with a prefix arg the meaning of
(provide 'org-gnus)
-;; arch-tag: 512e0840-58fa-45b3-b456-71e10fa2376d
;;; org-gnus.el ends here
diff --git a/lisp/org/org-habit.el b/lisp/org/org-habit.el
index dd1bacdea71..33c55cf46d1 100644
--- a/lisp/org/org-habit.el
+++ b/lisp/org/org-habit.el
@@ -1,11 +1,11 @@
;;; org-habit.el --- The habit tracking code for Org-mode
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw at gnu dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; 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)))
@@ -191,10 +197,7 @@ This list represents a \"habit\" for the rest of this module."
"Determine the relative priority of a habit.
This must take into account not just urgency, but consistency as well."
(let ((pri 1000)
- (now (time-to-days
- (or moment
- (time-subtract (current-time)
- (list 0 (* 3600 org-extend-today-until) 0)))))
+ (now (if moment (time-to-days moment) (org-today)))
(scheduled (org-habit-scheduled habit))
(deadline (org-habit-deadline habit)))
;; add 10 for every day past the scheduled date, and subtract for every
@@ -281,9 +284,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 +315,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
@@ -339,6 +350,5 @@ current time."
(provide 'org-habit)
-;; arch-tag: 64e070d9-bd09-4917-bd44-44465f5ed348
;;; org-habit.el ends here
diff --git a/lisp/org/org-html.el b/lisp/org/org-html.el
index 85fb0c8d798..a6933978710 100644
--- a/lisp/org/org-html.el
+++ b/lisp/org/org-html.el
@@ -1,12 +1,11 @@
;;; org-html.el --- HTML export for Org-mode
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; This file is part of GNU Emacs.
;;
@@ -26,7 +25,10 @@
;;
;;; Commentary:
+;;; Code:
+
(require 'org-exp)
+
(eval-when-compile (require 'cl))
(declare-function org-id-find-id-file "org-id" (id))
@@ -57,7 +59,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 +83,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 +112,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 +125,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 +138,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 +165,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 +217,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 +352,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 +372,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 +384,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 +395,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 +408,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 +454,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 +478,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 +535,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 +551,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 +590,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 +671,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 +811,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 +897,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 +909,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 +943,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 +967,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 +1046,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 +1061,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 +1091,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,10 +1200,23 @@ 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)
+ (when (and (get-text-property 0 'org-protected line)
+ ;; Make sure it is the entire line that is protected
+ (not (< (or (next-single-property-change
+ 0 'org-protected line) 10000)
+ (length line))))
(let (par (ind (get-text-property 0 'original-indentation line)))
(when (re-search-backward
"\\(<p>\\)\\([ \t\r\n]*\\)\\=" (- (point) 100) t)
@@ -944,10 +1247,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 +1304,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 +1341,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 +1414,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 +1518,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 +1529,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 +1561,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 +1578,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 +1666,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 +1692,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 +1747,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 +1757,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 +1800,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 +1841,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 +1869,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 +1886,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 +1920,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 +1960,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 +2055,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 +2179,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 +2194,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 +2223,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 +2307,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,12 +2314,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)))
- (remove (or preferred target))
+ (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))))
(l org-level-max)
- snumber href suffix)
- (setq extra-targets (remove remove extra-targets))
+ snumber snu href suffix)
+ (setq extra-targets (remove (or preferred target) extra-targets))
(setq extra-targets
(mapconcat (lambda (x)
(if (org-uuidgen-p x) (setq x (concat "ID-" x)))
@@ -2016,7 +2338,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
@@ -2038,16 +2360,18 @@ When TITLE is nil, just close all open levels."
(progn
(org-close-li)
(if target
- (insert (format "<li id=\"%s\">" target) extra-targets title "<br/>\n")
+ (insert (format "<li id=\"%s\">" (or preferred target))
+ extra-targets title "<br/>\n")
(insert "<li>" title "<br/>\n")))
(aset org-levels-open (1- level) t)
(org-close-par-maybe)
(if target
- (insert (format "<ul>\n<li id=\"%s\">" target)
+ (insert (format "<ul>\n<li id=\"%s\">" (or preferred target))
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 +2379,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)))))
@@ -2089,5 +2414,4 @@ Replaces invalid characters with \"_\" and then prepends a prefix."
(provide 'org-html)
-;; arch-tag: 8109d84d-eb8f-460b-b1a8-f45f3a6c7ea1
;;; org-html.el ends here
diff --git a/lisp/org/org-icalendar.el b/lisp/org/org-icalendar.el
index 749d54341d0..e0ea20a4bb8 100644
--- a/lisp/org/org-icalendar.el
+++ b/lisp/org/org-icalendar.el
@@ -1,12 +1,11 @@
;;; org-icalendar.el --- iCalendar export for Org-mode
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; This file is part of GNU Emacs.
;;
@@ -26,8 +25,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 +46,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 +124,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 +149,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,7 +172,7 @@ 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
@@ -173,6 +193,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 +212,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 +299,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 +317,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 +331,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 +380,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 +407,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 +417,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 +445,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 +477,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 +551,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 +604,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,24 +624,30 @@ 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)
-;; arch-tag: 2dee2b6e-9211-4aee-8a47-a3c7e5bc30cf
;;; org-icalendar.el ends here
diff --git a/lisp/org/org-id.el b/lisp/org/org-id.el
index 44b2d917ef2..b979097dee3 100644
--- a/lisp/org/org-id.el
+++ b/lisp/org/org-id.el
@@ -1,11 +1,11 @@
;;; org-id.el --- Global identifiers for Org-mode entries
;;
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; 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)))
@@ -497,7 +519,8 @@ When CHECK is given, prepare detailed information about duplicate IDs."
(puthash id (abbreviate-file-name file) org-id-locations)
(add-to-list 'org-id-files (abbreviate-file-name file))))
-(add-hook 'kill-emacs-hook 'org-id-locations-save)
+(unless noninteractive
+ (add-hook 'kill-emacs-hook 'org-id-locations-save))
(defun org-id-hash-to-alist (hash)
"Turn an org-id hash into an alist, so that it can be written to a file."
@@ -545,7 +568,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,17 +597,22 @@ 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)))
- (desc (save-excursion
- (org-back-to-heading t)
- (or (and (looking-at org-complex-heading-regexp)
- (if (match-end 4) (match-string 4) (match-string 0)))
- link))))
- (org-store-link-props :link link :description desc :type "id")
- link))
+ (when (and (buffer-file-name (buffer-base-buffer)) (org-mode-p))
+ (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)
+ (if (match-end 4)
+ (match-string 4)
+ (match-string 0)))
+ link))))
+ (org-store-link-props :link link :description desc :type "id")
+ link)))
(defun org-id-open (id)
"Go to the entry with id ID."
@@ -613,6 +643,5 @@ optional argument MARKERP, return the position as a new marker."
;;; org-id.el ends here
-;; arch-tag: e5abaca4-e16f-4b25-832a-540cfb63a712
diff --git a/lisp/org/org-indent.el b/lisp/org/org-indent.el
index b27d3b8f92f..50dd6ac027a 100644
--- a/lisp/org/org-indent.el
+++ b/lisp/org/org-indent.el
@@ -1,10 +1,10 @@
;;; org-indent.el --- Dynamic indentation for Org-mode
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; This file is part of GNU Emacs.
;;
@@ -29,22 +29,28 @@
;; 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))
+(defvar org-inlinetask-min-level)
+(declare-function org-inlinetask-get-task-level "org-inlinetask" ())
+(declare-function org-inlinetask-in-task-p "org-inlinetask" ())
(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 +59,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 +73,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 +135,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 +207,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."
@@ -201,34 +223,49 @@ useful to make it ever so slightly different."
(defun org-indent-add-properties (beg end)
"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
- (save-excursion
- (goto-char beg)
- (while (not exit)
- (setq e end)
- (if (not (re-search-forward org-indent-outline-re nil t))
- (setq e (point-max) exit t)
- (setq e (match-beginning 0))
- (if (>= e end) (setq exit t))
- (setq level (- (match-end 0) (match-beginning 0) 1))
- (setq nstars (- (* (1- level) org-indent-indentation-per-level)
- (1- level)))
- (add-text-properties
- (point-at-bol) (point-at-eol)
- (list 'line-prefix
- (aref org-indent-stars nstars)
- 'wrap-prefix
- (aref org-indent-strings
- (* level org-indent-indentation-per-level)))))
- (when (and b (> e b))
- (add-text-properties
- 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))))))))
+ (let* ((inhibit-modification-hooks t)
+ (inlinetaskp (featurep 'org-inlinetask))
+ (get-real-level (lambda (pos lvl)
+ (save-excursion
+ (goto-char pos)
+ (if (and inlinetaskp (org-inlinetask-in-task-p))
+ (org-inlinetask-get-task-level)
+ lvl))))
+ (b beg)
+ (e end)
+ (level 0)
+ (n 0)
+ exit nstars)
+ (with-silent-modifications
+ (save-excursion
+ (goto-char beg)
+ (while (not exit)
+ (setq e end)
+ (if (not (re-search-forward org-indent-outline-re nil t))
+ (setq e (point-max) exit t)
+ (setq e (match-beginning 0))
+ (if (>= e end) (setq exit t))
+ (unless (and inlinetaskp (org-inlinetask-in-task-p))
+ (setq level (- (match-end 0) (match-beginning 0) 1)))
+ (setq nstars (* (1- (funcall get-real-level e level))
+ (1- org-indent-indentation-per-level)))
+ (add-text-properties
+ (point-at-bol) (point-at-eol)
+ (list 'line-prefix
+ (aref org-indent-stars nstars)
+ 'wrap-prefix
+ (aref org-indent-strings
+ (* (funcall get-real-level e level)
+ org-indent-indentation-per-level)))))
+ (when (> e b)
+ (add-text-properties
+ b e (list 'line-prefix (aref org-indent-strings n)
+ 'wrap-prefix (aref org-indent-strings n))))
+ (setq b (1+ (point-at-eol))
+ n (* (funcall get-real-level b level)
+ org-indent-indentation-per-level)))))))
+(defvar org-inlinetask-min-level)
(defun org-indent-refresh-section ()
"Refresh indentation properties in the current outline section.
Point is assumed to be at the beginning of a headline."
@@ -236,7 +273,11 @@ Point is assumed to be at the beginning of a headline."
(when org-indent-mode
(let (beg end)
(save-excursion
- (when (ignore-errors (org-back-to-heading))
+ (when (ignore-errors (let ((outline-regexp (format "\\*\\{1,%s\\}[ \t]+"
+ (if (featurep 'org-inlinetask)
+ (1- org-inlinetask-min-level)
+ ""))))
+ (org-back-to-heading)))
(setq beg (point))
(setq end (or (save-excursion (or (outline-next-heading) (point)))))
(org-indent-remove-properties beg end)
@@ -249,7 +290,11 @@ Point is assumed to be at the beginning of a headline."
(when org-indent-mode
(let ((beg (point)) (end limit))
(save-excursion
- (and (ignore-errors (org-back-to-heading t))
+ (and (ignore-errors (let ((outline-regexp (format "\\*\\{1,%s\\}[ \t]+"
+ (if (featurep 'org-inlinetask)
+ (1- org-inlinetask-min-level)
+ ""))))
+ (org-back-to-heading)))
(setq beg (point))))
(org-indent-remove-properties beg end)
(org-indent-add-properties beg end)))
@@ -277,5 +322,4 @@ Point is assumed to be at the beginning of a headline."
(provide 'org-indent)
-;; arch-tag: b76736bc-9f4a-43cd-977c-ecfd6689846a
;;; org-indent.el ends here
diff --git a/lisp/org/org-info.el b/lisp/org/org-info.el
index edc2476c343..edbf4268954 100644
--- a/lisp/org/org-info.el
+++ b/lisp/org/org-info.el
@@ -1,12 +1,11 @@
;;; org-info.el --- Support for links to Info nodes from within Org-Mode
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; This file is part of GNU Emacs.
;;
@@ -78,6 +77,5 @@
(provide 'org-info)
-;; arch-tag: 1e289f54-7176-487f-b575-dd4854bab15e
;;; org-info.el ends here
diff --git a/lisp/org/org-inlinetask.el b/lisp/org/org-inlinetask.el
index 5911acb88a5..53e3f782b98 100644
--- a/lisp/org/org-inlinetask.el
+++ b/lisp/org/org-inlinetask.el
@@ -1,11 +1,11 @@
;;; org-inlinetask.el --- Tasks independent of outline hierarchy
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;; 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,31 +90,151 @@ 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)
+(defvar org-inlinetask-export-templates
+ '((html "<pre class=\"inlinetask\"><b>%s%s</b><br>%s</pre>"
+ '((unless (eq todo "")
+ (format "<span class=\"%s %s\">%s%s</span> "
+ class todo todo priority))
+ heading content))
+ (latex "\\begin\{description\}\\item[%s%s]%s\\end\{description\}"
+ '((unless (eq todo "") (format "\\textsc\{%s%s\} " todo priority))
+ heading content))
+ (ascii " -- %s%s%s"
+ '((unless (eq todo "") (format "%s%s " todo priority))
+ heading
+ (unless (eq content "")
+ (format "\n ¦ %s"
+ (mapconcat 'identity (org-split-string content "\n")
+ "\n ¦ ")))))
+ (docbook "<variablelist>
+<varlistentry>
+<term>%s%s</term>
+<listitem><para>%s</para></listitem>
+</varlistentry>
+</variablelist>"
+ '((unless (eq todo "") (format "%s%s " todo priority))
+ heading content)))
+ "Templates for inline tasks in various exporters.
+
+This variable is an alist in the shape of (BACKEND STRING OBJECTS).
+
+BACKEND is the name of the backend for the template (ascii, html...).
+
+STRING is a format control string.
+
+OBJECTS is a list of elements to be substituted into the format
+string. They can be of any type, from a string to a form
+returning a value (thus allowing conditional insertion). A nil
+object will be substituted as the empty string. Obviously, there
+must be at least as many objects as %-sequences in the format
+string.
+
+Moreover, the following special keywords are provided: `todo',
+`priority', `heading', `content', `tags'. If some of them are not
+defined in an inline task, their value is the empty string.
+
+As an example, valid associations are:
+
+(html \"<ul><li>%s <p>%s</p></li></ul>\" (heading content))
+
+or, with the additional package \"todonotes\" for LaTeX,
+
+(latex \"\\todo[inline]{\\textbf{\\textsf{%s %s}}\\linebreak{} %s}\"
+ '((unless (eq todo \"\")
+ (format \"\\textsc{%s%s}\" todo priority))
+ heading content)))")
+
(defvar org-odd-levels-only)
(defvar org-keyword-time-regexp)
(defvar org-drawer-regexp)
(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)
-(defvar htmlp) ; dynamically scoped into the next function
-(defvar latexp) ; dynamically scoped into the next function
+(defun org-inlinetask-outline-regexp ()
+ "Return string matching an inline task heading.
+The number of levels is controlled by `org-inlinetask-min-level'."
+ (let ((nstars (if org-odd-levels-only
+ (1- (* org-inlinetask-min-level 2))
+ org-inlinetask-min-level)))
+ (format "^\\(\\*\\{%d,\\}\\)[ \t]+" nstars)))
+
+(defun org-inlinetask-in-task-p ()
+ "Return true if point is inside an inline task."
+ (save-excursion
+ (let* ((stars-re (org-inlinetask-outline-regexp))
+ (task-beg-re (concat stars-re "\\(?:.*\\)"))
+ (task-end-re (concat stars-re "\\(?:END\\|end\\)[ \t]*$")))
+ (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)))))))
+
+(defun org-inlinetask-goto-beginning ()
+ "Go to the beginning of the inline task at point."
+ (end-of-line)
+ (re-search-backward (org-inlinetask-outline-regexp) nil t)
+ (when (org-looking-at-p (concat (org-inlinetask-outline-regexp) "END[ \t]*$"))
+ (re-search-backward (org-inlinetask-outline-regexp) nil t)))
+
+(defun org-inlinetask-goto-end ()
+ "Go to the end of the inline task at point."
+ (beginning-of-line)
+ (cond
+ ((org-looking-at-p (concat (org-inlinetask-outline-regexp) "END[ \t]*$"))
+ (forward-line 1))
+ ((org-looking-at-p (org-inlinetask-outline-regexp))
+ (forward-line 1)
+ (when (org-inlinetask-in-task-p)
+ (re-search-forward (org-inlinetask-outline-regexp) nil t)
+ (forward-line 1)))
+ (t
+ (re-search-forward (org-inlinetask-outline-regexp) nil t)
+ (forward-line 1))))
+
+(defun org-inlinetask-get-task-level ()
+ "Get the level of the inline task around.
+This assumes the point is inside an inline task."
+ (save-excursion
+ (end-of-line)
+ (re-search-backward (org-inlinetask-outline-regexp) nil t)
+ (- (match-end 1) (match-beginning 1))))
+
+(defvar backend) ; dynamically scoped into the next function
(defun org-inlinetask-export-handler ()
"Handle headlines with level larger or equal to `org-inlinetask-min-level'.
Either remove headline and meta data, or do special formatting."
@@ -125,7 +244,7 @@ Either remove headline and meta data, or do special formatting."
(or org-inlinetask-min-level 200)))
(re1 (format "^\\(\\*\\{%d,\\}\\) .*\n" nstars))
(re2 (concat "^[ \t]*" org-keyword-time-regexp))
- headline beg end stars content indent)
+ headline beg end stars content)
(while (re-search-forward re1 nil t)
(setq headline (match-string 0)
stars (match-string 1)
@@ -146,30 +265,34 @@ Either remove headline and meta data, or do special formatting."
(delete-region beg (1+ (match-end 0))))
(goto-char beg)
(when org-inlinetask-export
- (when (string-match org-complex-heading-regexp headline)
- (setq headline (concat
- (if (match-end 2)
- (concat (match-string 2 headline) " ") "")
- (match-string 4 headline)))
- (when content
+ ;; content formatting
+ (when content
(if (not (string-match "\\S-" content))
(setq content nil)
(if (string-match "[ \t\n]+\\'" content)
(setq content (substring content 0 (match-beginning 0))))
- (setq content (org-remove-indentation content))
- (if latexp (setq content (concat "\\quad \\\\\n" content)))))
- (insert (make-string (org-inlinetask-get-current-indentation) ?\ )
- "- ")
- (setq indent (make-string (current-column) ?\ ))
- (insert headline " ::")
- (if content
- (insert (if htmlp " " (concat "\n" indent))
- (mapconcat 'identity (org-split-string content "\n")
- (concat "\n" indent)) "\n")
- (insert "\n"))
- (insert indent)
- (backward-delete-char 2)
- (insert "THISISTHEINLINELISTTEMINATOR\n"))))))
+ (setq content (org-remove-indentation content))))
+ (setq content (or content ""))
+ ;; grab elements to export
+ (when (string-match org-complex-heading-regexp headline)
+ (let* ((todo (or (match-string 2 headline) ""))
+ (class (or (and (eq "" todo) "")
+ (if (member todo org-done-keywords) "done" "todo")))
+ (priority (or (match-string 3 headline) ""))
+ (heading (or (match-string 4 headline) ""))
+ (tags (or (match-string 5 headline) ""))
+ (backend-spec (assq backend org-inlinetask-export-templates))
+ (format-str (nth 1 backend-spec))
+ (tokens (cadr (nth 2 backend-spec)))
+ ;; change nil arguments into empty strings
+ (nil-to-str (lambda (el) (or (eval el) "")))
+ ;; build and protect export string
+ (export-str (org-add-props
+ (eval (append '(format format-str)
+ (mapcar nil-to-str tokens)))
+ nil 'org-protected t)))
+ ;; eventually insert it
+ (insert export-str "\n")))))))
(defun org-inlinetask-get-current-indentation ()
"Get the indentation of the last non-while line above this one."
@@ -204,33 +327,12 @@ Either remove headline and meta data, or do special formatting."
org-inlinetask-min-level))
(replace-match "")))
-(defun org-inlinetask-remove-terminator ()
- (let (beg end)
- (save-excursion
- (goto-char (point-min))
- (while (re-search-forward "THISISTHEINLINELISTTEMINATOR\n" nil t)
- (setq beg (match-beginning 0) end (match-end 0))
- (save-excursion
- (beginning-of-line 1)
- (and (looking-at "<p\\(ara\\)?>THISISTHEINLINELISTTEMINATOR[ \t\n]*</p\\(ara\\)?>")
- (setq beg (point) end (match-end 0))))
- (delete-region beg end)))))
-
(eval-after-load "org-exp"
'(add-hook 'org-export-preprocess-after-tree-selection-hook
'org-inlinetask-export-handler))
(eval-after-load "org"
'(add-hook 'org-font-lock-hook 'org-inlinetask-fontify))
-(eval-after-load "org-html"
- '(add-hook 'org-export-html-final-hook 'org-inlinetask-remove-terminator))
-(eval-after-load "org-latex"
- '(add-hook 'org-export-latex-final-hook 'org-inlinetask-remove-terminator))
-(eval-after-load "org-ascii"
- '(add-hook 'org-export-ascii-final-hook 'org-inlinetask-remove-terminator))
-(eval-after-load "org-docbook"
- '(add-hook 'org-export-docbook-final-hook 'org-inlinetask-remove-terminator))
(provide 'org-inlinetask)
-;; arch-tag: 59fdac51-8bcc-469e-a21e-6897dd6697bb
;;; org-inlinetask.el ends here
diff --git a/lisp/org/org-install.el b/lisp/org/org-install.el
index 3bd9d9356f1..eb2d011efb9 100644
--- a/lisp/org/org-install.el
+++ b/lisp/org/org-install.el
@@ -1,7 +1,6 @@
;;; org-install.el --- Outline-based notes management and organizer
;; Carstens outline-mode for keeping track of everything.
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
@@ -35,5 +34,4 @@
(provide 'org-install)
-;; arch-tag: 0614acb4-47a3-4e7b-918a-aa3149792bcc
;;; org-install.el ends here
diff --git a/lisp/org/org-irc.el b/lisp/org/org-irc.el
index 5d836347335..8339a5640d2 100644
--- a/lisp/org/org-irc.el
+++ b/lisp/org/org-irc.el
@@ -1,10 +1,10 @@
;;; org-irc.el --- Store links to IRC sessions
;;
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;;
;; Author: Philip Jackson <emacs@shellarchive.co.uk>
;; Keywords: erc, irc, link, org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; This file is part of GNU Emacs.
;;
@@ -251,6 +251,5 @@ default."
(provide 'org-irc)
-;; arch-tag: 018d7dda-53b8-4a35-ba92-6670939e525a
;;; org-irc.el ends here
diff --git a/lisp/org/org-jsinfo.el b/lisp/org/org-jsinfo.el
index 48dff626e49..1db4860b20d 100644
--- a/lisp/org/org-jsinfo.el
+++ b/lisp/org/org-jsinfo.el
@@ -1,12 +1,11 @@
;;; org-jsinfo.el --- Support for org-info.js Javascript in Org HTML export
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; This file is part of GNU Emacs.
;;
@@ -26,12 +25,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 +86,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
@@ -205,6 +204,5 @@ Option settings will replace the %MANAGER-OPTIONS cookie."
(provide 'org-infojs)
(provide 'org-jsinfo)
-;; arch-tag: c71d1d85-3337-4817-a066-725e74ac9eac
;;; org-jsinfo.el ends here
diff --git a/lisp/org/org-latex.el b/lisp/org/org-latex.el
index 17a3c5007f9..3f4c1dcb7cf 100644
--- a/lisp/org/org-latex.el
+++ b/lisp/org/org-latex.el
@@ -1,10 +1,10 @@
;;; org-latex.el --- LaTeX exporter for org-mode
;;
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;;
;; Emacs Lisp Archive Entry
;; Filename: org-latex.el
-;; Version: 6.33x
+;; Version: 7.4
;; 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,20 @@ markup defined, the first one in the association list will be used."
:group 'org-export-latex
:type 'string)
+(defcustom org-export-latex-href-format "\\href{%s}{%s}"
+ "A printf format string to be applied to href 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-hyperref-format "\\hyperref[%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 +374,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 +383,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 +415,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 +428,41 @@ 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-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 +478,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 +494,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 +677,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 +695,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 +721,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 +789,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 +861,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 +876,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 +923,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 +936,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 +1006,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 +1014,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 +1026,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 +1050,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 +1058,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 +1085,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 +1093,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 +1160,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 +1215,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,51 +1245,60 @@ 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}}"
+ ;; beginning of the document
+ "\n\\begin{document}\n\n"
;; insert the title
(format
"\n\n\\title{%s}\n"
;; convert the title
- (org-export-latex-content
- title '(lists tables fixed-width keywords)))
+ (org-export-latex-fontify-headline title))
;; insert author info
(if (plist-get opt-plist :author-info)
(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
(or (plist-get opt-plist :date)
org-export-latex-date-format)))
- ;; beginning of the document
- "\n\\begin{document}\n\n"
;; insert the title command
(when (string-match "\\S-" title)
(if (string-match "%s" org-export-latex-title-command)
@@ -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.
@@ -1012,7 +1325,7 @@ If END is non-nil, it is the end of the region."
(save-excursion
(goto-char (or beg (point-min)))
(let* ((pt (point))
- (end (if (re-search-forward "^\\*+ " end t)
+ (end (if (re-search-forward (org-get-limited-outline-regexp) end t)
(goto-char (match-beginning 0))
(goto-char (or end (point-max))))))
(prog1
@@ -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)))))
@@ -1126,14 +1452,48 @@ links, keywords, lists, tables, fixed-width"
;; FIXME: org-inside-LaTeX-fragment-p doesn't work when the $...$ is at
;; the beginning of the buffer - inserting "\n" is safe here though.
(insert "\n" string)
+
+ ;; Preserve math snippets
+
+ (let* ((matchers (plist-get org-format-latex-options :matchers))
+ (re-list org-latex-regexps)
+ beg end re e m n block off)
+ ;; Check the different regular expressions
+ (while (setq e (pop re-list))
+ (setq m (car e) re (nth 1 e) n (nth 2 e)
+ block (if (nth 3 e) "\n\n" ""))
+ (setq off (if (member m '("$" "$1")) 1 0))
+ (when (and (member m matchers) (not (equal m "begin")))
+ (goto-char (point-min))
+ (while (re-search-forward re nil t)
+ (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{} and TeX to \TeX{}
+ (goto-char (point-min))
+ (let ((case-fold-search nil))
+ (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)))))
(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 +1552,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 +1577,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 +1600,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 +1637,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 +1655,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 +1693,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 +1740,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 +1749,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 +1758,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 +1820,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 +1844,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 +1854,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 +1922,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 +1941,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 +2000,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,43 +2033,54 @@ 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)
(cdr (assoc path org-export-code-refs)))))
- (radiop (insert (format "\\hyperref[%s]{%s}"
+ (radiop (insert (format org-export-latex-hyperref-format
(org-solidify-link-text raw-path) desc)))
((not type)
- (insert (format "\\hyperref[%s]{%s}"
+ (insert (format org-export-latex-hyperref-format
(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-href-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 +2101,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 +2115,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 +2151,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 +2163,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 +2172,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 +2190,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 +2246,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 +2284,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 +2332,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 +2346,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))))
(defconst org-latex-entities
'("\\!"
@@ -1959,7 +2490,6 @@ The conversion is made depending of STRING-BEFORE and STRING-AFTER."
"\\medskip"
"\\multicolumn"
"\\multiput"
- ("\\nbsp" "~")
"\\newcommand"
"\\newcounter"
"\\newenvironment"
@@ -2031,14 +2561,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)))
@@ -2048,6 +2573,5 @@ The conversion is made depending of STRING-BEFORE and STRING-AFTER."
(provide 'org-export-latex)
(provide 'org-latex)
-;; arch-tag: 23c2b87d-da04-4c2d-ad2d-1eb6487bc3ad
;;; org-latex.el ends here
diff --git a/lisp/org/org-list.el b/lisp/org/org-list.el
index 41fa7764240..08c733acc6f 100644
--- a/lisp/org/org-list.el
+++ b/lisp/org/org-list.el
@@ -1,13 +1,12 @@
;;; org-list.el --- Plain lists for Org-mode
;;
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Bastien Guerry <bzg AT altern DOT org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; This file is part of GNU Emacs.
;;
@@ -31,6 +30,8 @@
;;; Code:
+(eval-when-compile
+ (require 'cl))
(require 'org-macs)
(require 'org-compat)
@@ -38,20 +39,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 +72,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 +95,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 +148,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 +246,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 +273,547 @@ 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 (+ (or (get-text-property (point) 'original-indentation) 0)
+ (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 (+ (or (get-text-property (point) 'original-indentation) 0)
+ (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 (progn
+ ;; Again, ensure bottom is just after a
+ ;; non-blank line.
+ (skip-chars-backward " \r\t\n")
+ (min (point-max) (1+ (point-at-eol))))))
+ ((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))
+ (org-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 +821,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 +845,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))
+ (org-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)
+ (org-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 +1472,556 @@ 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))
+ (org-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)
+ (org-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:
-(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))
+ `-' -> `+' -> `*' -> `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")
+ (save-excursion
+ (let* ((top (org-list-top-point))
+ (bullet (progn
+ (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.
+
+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 +2029,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 ((org-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 +2091,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 +2112,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 +2186,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 +2213,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 +2253,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 +2270,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
@@ -1369,5 +2287,4 @@ with overruling parameters for `org-list-to-generic'."
(provide 'org-list)
-;; arch-tag: 73cf50c1-200f-4d1d-8a53-4e842a5b11c8
;;; org-list.el ends here
diff --git a/lisp/org/org-mac-message.el b/lisp/org/org-mac-message.el
index 563c0edc0ca..101743727c8 100644
--- a/lisp/org/org-mac-message.el
+++ b/lisp/org/org-mac-message.el
@@ -1,11 +1,11 @@
;;; org-mac-message.el --- Links to Apple Mail.app messages from within Org-mode
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
;; Christopher Suckling <suckling at gmail dot com>
-;; Version: 6.33x
+;; Version: 7.4
;; 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,11 +209,10 @@ 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)
-;; arch-tag: 3806d0c1-abe1-4db6-9c31-f3ed7d4a9b32
;;; org-mac-message.el ends here
diff --git a/lisp/org/org-macs.el b/lisp/org/org-macs.el
index 6782d39c412..5bb86888739 100644
--- a/lisp/org/org-macs.el
+++ b/lisp/org/org-macs.el
@@ -1,12 +1,11 @@
;;; org-macs.el --- Top-level definitions for Org-mode
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; This file is part of GNU Emacs.
;;
@@ -38,11 +37,39 @@
(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)))
+ (with-no-warnings (called-interactively-p ,kind)) ;; defined with no argument in <=23.1
+ (interactive-p))))
+
+(if (and (not (fboundp 'with-silent-modifications))
+ (or (< emacs-major-version 23)
+ (and (= emacs-major-version 23)
+ (< emacs-minor-version 2))))
+ (defmacro with-silent-modifications (&rest body)
+ `(org-unmodified ,@body)))
(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 +90,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 +114,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 +152,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 +189,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 +298,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 +305,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 +333,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
@@ -287,6 +343,5 @@ The number of levels is controlled by "
(provide 'org-macs)
-;; arch-tag: 7e6a73ce-aac9-4fc0-9b30-ce6f89dc6668
;;; org-macs.el ends here
diff --git a/lisp/org/org-mew.el b/lisp/org/org-mew.el
index 37a75fde774..be0c3b93d1e 100644
--- a/lisp/org/org-mew.el
+++ b/lisp/org/org-mew.el
@@ -1,11 +1,11 @@
;;; org-mew.el --- Support for links to Mew messages from within Org-mode
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; 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.4
;; 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
@@ -125,6 +135,5 @@
(provide 'org-mew)
-;; arch-tag: 07ccdca7-6020-4941-a593-588a1e51b870
;;; org-mew.el ends here
diff --git a/lisp/org/org-mhe.el b/lisp/org/org-mhe.el
index 9798d50c931..1767ddca1ee 100644
--- a/lisp/org/org-mhe.el
+++ b/lisp/org/org-mhe.el
@@ -1,12 +1,11 @@
;;; org-mhe.el --- Support for links to MH-E messages from within Org-mode
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; 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.4
;;
;; This file is part of GNU Emacs.
;;
@@ -83,13 +82,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 +189,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.
@@ -216,6 +224,5 @@ folders."
(provide 'org-mhe)
-;; arch-tag: dcb05484-8627-491d-a8c1-01dbd2bde4ae
;;; org-mhe.el ends here
diff --git a/lisp/org/org-mks.el b/lisp/org/org-mks.el
new file mode 100644
index 00000000000..e4826f801c0
--- /dev/null
+++ b/lisp/org/org-mks.el
@@ -0,0 +1,136 @@
+;;; org-mks.el --- Multi-key-selection for Org-mode
+
+;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
+
+;; Author: Carsten Dominik <carsten at orgmode dot org>
+;; Keywords: outlines, hypermedia, calendar, wp
+;; Homepage: http://orgmode.org
+;; Version: 7.4
+;;
+;; 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)
+
+
+;;; org-mks.el ends here
diff --git a/lisp/org/org-mobile.el b/lisp/org/org-mobile.el
index cc458599874..a36f1fc2d5e 100644
--- a/lisp/org/org-mobile.el
+++ b/lisp/org/org-mobile.el
@@ -1,10 +1,10 @@
;;; org-mobile.el --- Code for asymmetric sync with a mobile device
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; 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?"
@@ -938,7 +1083,6 @@ A and B must be strings or nil."
(provide 'org-mobile)
-;; arch-tag: ace0e26c-58f2-4309-8a61-05ec1535f658
;;; org-mobile.el ends here
diff --git a/lisp/org/org-mouse.el b/lisp/org/org-mouse.el
index a571bec4776..cec19d89de1 100644
--- a/lisp/org/org-mouse.el
+++ b/lisp/org/org-mouse.el
@@ -1,10 +1,10 @@
;;; org-mouse.el --- Better mouse support for org-mode
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation
+;; Copyright (C) 2006-2011 Free Software Foundation
;;
;; Author: Piotr Zielinski <piotr dot zielinski at gmail dot com>
;; Maintainer: Carsten Dominik <carsten at orgmode dot org>
-;; Version: 6.33x
+;; Version: 7.4
;;
;; This file is part of GNU Emacs.
;;
@@ -137,6 +137,8 @@
;;
;; Versions 0.01 -- 0.07: (I don't remember)
+;;; Code:
+
(eval-when-compile (require 'cl))
(require 'org)
@@ -146,6 +148,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 +192,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 +228,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 +293,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 +345,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 +434,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
@@ -474,11 +476,11 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:"
(defun org-mouse-agenda-type (type)
(case type
- ('tags "Tags: ")
- ('todo "TODO: ")
- ('tags-tree "Tags tree: ")
- ('todo-tree "TODO tree: ")
- ('occur-tree "Occur tree: ")
+ (tags "Tags: ")
+ (todo "TODO: ")
+ (tags-tree "Tags tree: ")
+ (todo-tree "TODO tree: ")
+ (occur-tree "Occur tree: ")
(t "Agenda command ???")))
@@ -575,17 +577,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 +607,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 +674,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 +909,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
@@ -1100,10 +1100,10 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:"
"--"
["Day View" org-agenda-day-view
:active (org-agenda-check-type nil 'agenda)
- :style radio :selected (equal org-agenda-ndays 1)]
+ :style radio :selected (eq org-agenda-current-span 'day)]
["Week View" org-agenda-week-view
:active (org-agenda-check-type nil 'agenda)
- :style radio :selected (equal org-agenda-ndays 7)]
+ :style radio :selected (eq org-agenda-current-span 'week)]
"--"
["Show Logbook entries" org-agenda-log-mode
:style toggle :selected org-agenda-show-log
@@ -1131,13 +1131,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))
@@ -1145,6 +1143,5 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:"
(provide 'org-mouse)
-;; 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 c94dadb5998..10722403f7e 100644
--- a/lisp/org/org-plot.el
+++ b/lisp/org/org-plot.el
@@ -1,11 +1,11 @@
;;; org-plot.el --- Support for plotting from Org-mode
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;;
;; Author: Eric Schulte <schulte dot eric at gmail dot com>
;; Keywords: tables, plotting
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; 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)
@@ -206,18 +206,18 @@ manner suitable for prepending to a user-specified script."
(y-labels (plist-get params :ylabels))
(plot-str "'%s' using %s%d%s with %s title '%s'")
(plot-cmd (case type
- ('2d "plot")
- ('3d "splot")
- ('grid "splot")))
+ (2d "plot")
+ (3d "splot")
+ (grid "splot")))
(script "reset") plot-lines)
(flet ((add-to-script (line) (setf script (format "%s\n%s" script line))))
(when file ;; output file
(add-to-script (format "set term %s" (file-name-extension file)))
(add-to-script (format "set output '%s'" file)))
(case type ;; type
- ('2d ())
- ('3d (if map (add-to-script "set map")))
- ('grid (if map
+ (2d ())
+ (3d (if map (add-to-script "set map")))
+ (grid (if map
(add-to-script "set pm3d map")
(add-to-script "set pm3d"))))
(when title (add-to-script (format "set title '%s'" title))) ;; title
@@ -243,24 +243,25 @@ manner suitable for prepending to a user-specified script."
"%Y-%m-%d-%H:%M:%S") "\"")))
(unless preface
(case type ;; plot command
- ('2d (dotimes (col num-cols)
+ (2d (dotimes (col num-cols)
(unless (and (equal type '2d)
(or (and ind (equal (+ 1 col) ind))
(and deps (not (member (+ 1 col) deps)))))
(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
(or (nth col col-labels) (format "%d" (+ 1 col))))
plot-lines)))))
- ('3d
+ (3d
(setq plot-lines (list (format "'%s' matrix with %s title ''"
data-file with))))
- ('grid
+ (grid
(setq plot-lines (list (format "'%s' with %s title ''"
data-file with)))))
(add-to-script
@@ -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,13 +301,13 @@ 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)
- ('2d (org-plot/gnuplot-to-data table data-file params))
- ('3d (org-plot/gnuplot-to-data table data-file params))
- ('grid (let ((y-labels (org-plot/gnuplot-to-grid-data
+ (2d (org-plot/gnuplot-to-data table data-file params))
+ (3d (org-plot/gnuplot-to-data table data-file params))
+ (grid (let ((y-labels (org-plot/gnuplot-to-grid-data
table data-file params)))
(when y-labels (plist-put params :ylabels y-labels)))))
;; check for timestamp ind column
@@ -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
@@ -350,5 +350,4 @@ line directly before or after the table."
(provide 'org-plot)
-;; arch-tag: 5763f7c6-0c75-416d-b070-398ee4ec0eca
;;; org-plot.el ends here
diff --git a/lisp/org/org-protocol.el b/lisp/org/org-protocol.el
index f05627fcd0b..018eadf9a23 100644
--- a/lisp/org/org-protocol.el
+++ b/lisp/org/org-protocol.el
@@ -1,7 +1,6 @@
;;; org-protocol.el --- Intercept calls from emacsclient to trigger custom actions.
;;
-;; Copyright (C) 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;;
;; Author: Bastien Guerry <bzg AT altern DOT org>
;; Author: Daniel M German <dmg AT uvic DOT org>
@@ -9,7 +8,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.4
;; This file is part of GNU Emacs.
;;
@@ -31,8 +30,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 +57,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 +83,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 +105,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 +125,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 +145,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 +154,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 +229,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 +243,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 +252,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 +276,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
@@ -308,7 +312,7 @@ encodeURIComponent. E.g. `%C3%B6' is the german Umlaut `ü'."
(let* ((start (match-beginning 0))
(end (match-end 0))
(hex (match-string 0 str))
- (replacement (org-protocol-unhex-compound hex)))
+ (replacement (org-protocol-unhex-compound (upcase hex))))
(setq tmp (concat tmp (substring str 0 start) replacement))
(setq str (substring str end))))
(setq tmp (concat tmp str))
@@ -316,7 +320,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 +416,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 +447,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 +589,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 +642,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?"
@@ -675,5 +703,4 @@ project-plist is the CDR of an element in `org-publish-project-alist', reuse
(provide 'org-protocol)
-;; arch-tag: b5c5c2ac-77cf-4a94-a649-2163dff95846
;;; org-protocol.el ends here
diff --git a/lisp/org/org-publish.el b/lisp/org/org-publish.el
index 5bb641f0014..7451587ba2f 100644
--- a/lisp/org/org-publish.el
+++ b/lisp/org/org-publish.el
@@ -1,10 +1,10 @@
;;; org-publish.el --- publish related org-mode files as a website
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2006-2011 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.4
;; This file is part of GNU Emacs.
;;
@@ -31,7 +31,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 +39,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 +70,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 +94,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 +127,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 +161,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 +215,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 +232,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 +267,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 +291,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 +340,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 +358,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 +412,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 +429,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 +465,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 +523,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 +543,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 +609,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 +658,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 +706,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 +756,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 +776,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 +799,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 +814,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,18 +836,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
;;; org-publish.el ends here
diff --git a/lisp/org/org-remember.el b/lisp/org/org-remember.el
index fcf5a8a3887..fd3064a709c 100644
--- a/lisp/org/org-remember.el
+++ b/lisp/org/org-remember.el
@@ -1,12 +1,11 @@
;;; org-remember.el --- Fast note taking in Org-mode
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; This file is part of GNU Emacs.
;;
@@ -54,14 +53,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 +94,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 +114,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 +166,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"
@@ -210,8 +214,12 @@ The remember buffer is still current when this hook runs."
:group 'org-remember
:type 'hook)
-(defvar org-remember-mode-map (make-sparse-keymap)
- "Keymap for org-remember-mode, a minor mode.
+(defvar org-remember-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\C-c\C-c" 'org-remember-finalize)
+ (define-key map "\C-c\C-k" 'org-remember-kill)
+ map)
+ "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
@@ -219,17 +227,14 @@ for a Remember buffer.")
(define-minor-mode org-remember-mode
"Minor mode for special key bindings in a remember buffer."
- nil " Rem" org-remember-mode-map
- (run-hooks 'org-remember-mode-hook))
-(define-key org-remember-mode-map "\C-c\C-c" 'org-remember-finalize)
-(define-key org-remember-mode-map "\C-c\C-k" 'org-remember-kill)
+ nil " Rem" org-remember-mode-map)
(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)))
@@ -1133,7 +1149,6 @@ See also the variable `org-reverse-note-order'."
(provide 'org-remember)
-;; arch-tag: 497f30d0-4bc3-4097-8622-2d27ac5f2698
;;; org-remember.el ends here
diff --git a/lisp/org/org-rmail.el b/lisp/org/org-rmail.el
index 86173b040c5..6e984fda687 100644
--- a/lisp/org/org-rmail.el
+++ b/lisp/org/org-rmail.el
@@ -1,12 +1,11 @@
;;; org-rmail.el --- Support for links to Rmail messages from within Org-mode
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; This file is part of GNU Emacs.
;;
@@ -59,10 +58,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))
@@ -105,6 +114,5 @@
(provide 'org-rmail)
-;; arch-tag: c6cf4a8b-6639-4b7f-821f-bdf10746b173
;;; org-rmail.el ends here
diff --git a/lisp/org/org-src.el b/lisp/org/org-src.el
index 9001a8542d4..bd1c3802044 100644
--- a/lisp/org/org-src.el
+++ b/lisp/org/org-src.el
@@ -1,14 +1,13 @@
;;; org-src.el --- Source code examples in Org
;;
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Bastien Guerry <bzg AT altern DOT org>
;; 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.4
;;
;; This file is part of GNU Emacs.
;;
@@ -34,10 +33,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 +64,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 +88,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 +103,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 +120,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 +152,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
@@ -162,10 +169,14 @@ For example, there is no ocaml-mode in Emacs, but the mode to use is
;;; Editing source examples
-(defvar org-src-mode-map (make-sparse-keymap))
-(define-key org-src-mode-map "\C-c'" 'org-edit-src-exit)
+(defvar org-src-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\C-c'" 'org-edit-src-exit)
+ map))
+
(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 +190,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 +200,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 +241,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 (1+ end)))
+ (save-excursion (goto-char (min mark end))
+ (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 +265,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 +289,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 +306,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 +323,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)
@@ -288,32 +335,34 @@ the edited version. Optional argument CONTEXT is used by
(defun org-src-switch-to-buffer (buffer context)
(case org-src-window-setup
- ('current-window
+ (current-window
(switch-to-buffer buffer))
- ('other-window
+ (other-window
(switch-to-buffer-other-window buffer))
- ('other-frame
+ (other-frame
(case context
- ('exit
+ (exit
(let ((frame (selected-frame)))
(switch-to-buffer-other-frame buffer)
(delete-frame frame)))
- ('save
+ (save
(kill-buffer (current-buffer))
(switch-to-buffer buffer))
(t
(switch-to-buffer-other-frame buffer))))
- ('reorganize-frame
+ (reorganize-frame
(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 +423,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 +448,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 +531,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 +563,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 +571,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 +583,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,19 +672,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
;;; org-src.el ends here
diff --git a/lisp/org/org-table.el b/lisp/org/org-table.el
index 7d93a82f84e..b56dc6b77c3 100644
--- a/lisp/org/org-table.el
+++ b/lisp/org/org-table.el
@@ -1,12 +1,11 @@
;;; org-table.el --- The table editor for Org-mode
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; This file is part of GNU Emacs.
;;
@@ -48,8 +47,14 @@
(defvar org-export-html-table-tag) ; defined in org-exp.el
(defvar constants-unit-system)
+(defvar orgtbl-after-send-table-hook nil
+ "Hook for functions attaching to `C-c C-c', if the table is sent.
+This can be used to add additional functionality after the table is sent
+to the receiver position, othewise, if table is not sent, the functions
+are not run.")
+
(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 +147,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 +162,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 +188,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 +201,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 +209,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 +220,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 +246,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 +257,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 +281,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 +296,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)
@@ -327,6 +332,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 +378,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 +463,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 +507,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 +604,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 +612,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 +639,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 +650,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 +660,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 +704,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 +730,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 +751,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 +812,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 +870,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 +1048,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 +1160,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 +1191,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 +1233,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 +1773,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)
@@ -2243,6 +2313,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 +2399,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 +2424,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 +2496,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 +2510,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 +2581,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 +2710,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 +2778,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 +2875,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 +2913,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 +3023,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 +3031,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 +3099,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 +3341,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 +3377,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 +3387,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 +3408,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 +3422,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 +3460,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 +3470,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 +3479,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 +3541,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 +3575,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))
@@ -3619,7 +3734,8 @@ With prefix arg, also recompute table."
(call-interactively 'org-table-recalculate)
(org-table-maybe-recalculate-line))
(call-interactively 'org-table-align)
- (orgtbl-send-table 'maybe))
+ (when (orgtbl-send-table 'maybe)
+ (run-hooks 'orgtbl-after-send-table-hook)))
((eq action 'recalc)
(save-excursion
(beginning-of-line 1)
@@ -3731,13 +3847,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)
@@ -3833,7 +3949,10 @@ this table."
(orgtbl-send-replace-tbl name txt))
(setq ntbl (1+ ntbl)))
(message "Table converted and installed at %d receiver location%s"
- ntbl (if (> ntbl 1) "s" "")))))
+ ntbl (if (> ntbl 1) "s" ""))
+ (if (> ntbl 0)
+ ntbl
+ nil))))
(defun org-remove-by-index (list indices &optional i0)
"Remove the elements in LIST with indices in INDICES.
@@ -3888,17 +4007,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 +4137,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 +4192,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 +4249,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 +4271,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 +4324,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 " | "
@@ -4216,7 +4341,7 @@ a \"#+TBLNAME:\" directive. The first table following this line
will then be used. Alternatively, it may be an ID referring to
any entry, also in a different file. In this case, the first table
in that entry will be referenced.
-FORM is a field or range descriptor like \"@2$3\" or or \"B3\" or
+FORM is a field or range descriptor like \"@2$3\" or \"B3\" or
\"@I$2..@II$2\". All the references must be absolute, not relative.
The return value is either a single string for a single field, or a
@@ -4247,26 +4372,25 @@ 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)
-;; arch-tag: 4d21cfdd-0268-440a-84b0-09237a0fe0ef
;;; org-table.el ends here
diff --git a/lisp/org/org-taskjuggler.el b/lisp/org/org-taskjuggler.el
new file mode 100644
index 00000000000..94341d80905
--- /dev/null
+++ b/lisp/org/org-taskjuggler.el
@@ -0,0 +1,648 @@
+;;; org-taskjuggler.el --- TaskJuggler exporter for org-mode
+;;
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
+;;
+;; Emacs Lisp Archive Entry
+;; Filename: org-taskjuggler.el
+;; Version: 7.4
+;; 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 3d869c3bdeb..f920062362b 100644
--- a/lisp/org/org-timer.el
+++ b/lisp/org/org-timer.el
@@ -1,11 +1,11 @@
;;; org-timer.el --- The relative timer code for Org-mode
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; 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,24 +362,37 @@ 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)
-;; arch-tag: 97538f8c-3871-4509-8f23-1e7b3ff3d107
;;; org-timer.el ends here
diff --git a/lisp/org/org-vm.el b/lisp/org/org-vm.el
index 4e49ffdaa26..7ebeadbc4d9 100644
--- a/lisp/org/org-vm.el
+++ b/lisp/org/org-vm.el
@@ -1,12 +1,11 @@
;;; org-vm.el --- Support for links to VM messages from within Org-mode
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; This file is part of GNU Emacs.
;;
@@ -66,9 +65,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
@@ -128,6 +137,5 @@
(provide 'org-vm)
-;; arch-tag: cbc3047b-935e-4d2a-96e7-c5b0117aaa6d
;;; org-vm.el ends here
diff --git a/lisp/org/org-w3m.el b/lisp/org/org-w3m.el
index d370b564f6b..ff839a9b7c2 100644
--- a/lisp/org/org-w3m.el
+++ b/lisp/org/org-w3m.el
@@ -1,11 +1,11 @@
;;; org-w3m.el --- Support from copy and paste from w3m to Org-mode
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Andy Stewart <lazycat dot manatee at gmail dot com>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; 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))
@@ -167,6 +168,5 @@ Return t if there is no previous link; otherwise, return nil."
(provide 'org-w3m)
-;; arch-tag: 851d7447-488d-49f0-a14d-46c092e84352
;;; org-w3m.el ends here
diff --git a/lisp/org/org-wl.el b/lisp/org/org-wl.el
index 47df0aacde6..f1616f8001d 100644
--- a/lisp/org/org-wl.el
+++ b/lisp/org/org-wl.el
@@ -1,12 +1,12 @@
;;; org-wl.el --- Support for links to Wanderlust messages from within Org-mode
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 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.4
;;
;; This file is part of GNU Emacs.
;;
@@ -40,9 +40,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 +83,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,83 +92,222 @@
(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 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)
-;; arch-tag: 29b75a0f-ef2e-430b-8abc-acff75bde54a
;;; org-wl.el ends here
diff --git a/lisp/org/org-xoxo.el b/lisp/org/org-xoxo.el
index 8f131bbf788..39a4cc7a447 100644
--- a/lisp/org/org-xoxo.el
+++ b/lisp/org/org-xoxo.el
@@ -1,12 +1,11 @@
;;; org-xoxo.el --- XOXO export for Org-mode
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; This file is part of GNU Emacs.
;;
@@ -25,10 +24,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 +43,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
@@ -122,5 +123,4 @@ The XOXO buffer is named *xoxo-<source buffer name>*"
(provide 'org-xoxo)
-;; arch-tag: 16e6a31f-f4f5-46f1-af18-48dc89faa702
;;; org-xoxo.el ends here
diff --git a/lisp/org/org.el b/lisp/org/org.el
index a7984df8487..4b316ab60ab 100644
--- a/lisp/org/org.el
+++ b/lisp/org/org.el
@@ -1,12 +1,11 @@
;;; org.el --- Outline-based notes management and organizer
;; Carstens outline-mode for keeping track of everything.
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.4
;;
;; This file is part of GNU Emacs.
;;
@@ -72,30 +71,123 @@
(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-complete)
(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.4"
"The version number of the file org.el.")
(defun org-version (&optional here)
@@ -134,7 +226,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 +261,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 +280,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 +298,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 +320,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 +385,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 +401,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 +419,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 +473,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 +509,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 +543,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 +666,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 +686,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 +699,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 +715,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 +746,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 +766,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 +783,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 +820,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 +832,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 +843,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 +880,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 +921,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 +933,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 +1010,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 +1032,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 +1066,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 +1078,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 +1102,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 +1120,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 +1161,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 +1200,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 +1245,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 +1276,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 +1287,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 +1296,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 +1342,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,17 +1382,20 @@ 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'.
+`org-open-at-point'. When this option is t, the entire active region
+will be placed in the search string of the file link. If set to a
+positive integer, only the first n lines of context will be stored.
+
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)
+ :type '(choice boolean integer))
(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 +1432,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 +1440,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 +1489,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 +1511,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 +1530,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 +1539,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 +1547,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 +1559,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 +1574,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 +1594,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 +1648,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 +1692,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 +1731,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 +1756,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 +1779,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 +1796,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:
@@ -1592,12 +1843,12 @@ This is list of cons cells. Each cell contains:
- a cons cell (:level . N). Any headline of level N is considered a target.
Note that, when `org-odd-levels-only' is set, level corresponds to
order in hierarchy, not to the number of stars.
- - a cons cell (:maxlevel . N). Any headline with level <= N is a target.
+ - a cons cell (:maxlevel . N). Any headline with level <= N is a target.
Note that, when `org-odd-levels-only' is set, level corresponds to
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 +1880,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 +1908,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 +1920,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 +1950,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.
@@ -1701,7 +1962,7 @@ indicating if the keywords should be interpreted as a sequence of
action steps, or as different types of TODO items. The first
keywords are states requiring action - these states will select a headline
for inclusion into the global TODO list Org-mode produces. If one of
-the \"keywords\" is the vertical bat \"|\" the remaining keywords
+the \"keywords\" is the vertical bar, \"|\", the remaining keywords
signify that no further action is necessary. If \"|\" is not found,
the last keyword is treated as the only DONE state of the sequence.
@@ -1716,7 +1977,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 +2055,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 +2079,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 +2096,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 +2141,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 +2160,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 +2178,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 +2186,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 +2290,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 +2301,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 +2311,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 +2338,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 +2384,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,19 +2397,28 @@ 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.
+through DONE. This variable forces taking a note anyway.
nil Don't force a record
time Record a time stamp
@@ -2166,7 +2446,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,19 +2471,29 @@ 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
:type 'boolean)
+(defcustom org-get-priority-function nil
+ "Function to extract the priority from a string.
+The string is normally the headline. If this is nil Org computes the
+priority from the priority cookie like [#A] in the headline. It returns
+an integer, increasing by 1000 for each priority level.
+The user can set a different function here, which should take a string
+as an argument and return the numeric priority."
+ :group 'org-priorities
+ :type 'function)
+
(defgroup org-time nil
"Options concerning time stamps and deadlines in Org-mode."
:tag "Org Time"
: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 +2514,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 +2534,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 +2562,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 +2591,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 +2610,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-read-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 +2672,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 +2730,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 capture buffers, because there no list of
+tags in that file can be created dynamically (there are none).
+
+ (add-hook 'org-capture-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 +2751,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 +2766,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 +2778,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 +2790,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 +2798,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 +2860,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 +2889,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 +3033,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 +3131,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 +3153,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 +3181,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 +3292,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 +3308,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
@@ -2994,7 +3436,7 @@ org-level-* faces."
(defcustom org-emphasis-regexp-components
'(" \t('\"{" "- \t.,:!?;'\")}\\" " \t\r\n,\"'" "." 1)
"Components used to build the regular expression for emphasis.
-This is a list with 6 entries. Terminology: In an emphasis string
+This is a list with five entries. Terminology: In an emphasis string
like \" *strong word* \", we call the initial space PREMATCH, the final
space POSTMATCH, the stars MARKERS, \"s\" and \"d\" are BORDER characters
and \"trong wor\" is the body. The different components in this variable
@@ -3008,7 +3450,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 +3475,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 +3502,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 +3511,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'.
@@ -3077,7 +3520,7 @@ Note that this variable has only an effect if `org-completion-use-ido' is nil."
:type 'boolean)
(defcustom org-completion-fallback-command 'hippie-expand
- "The expansion command called by \\[org-complete] in normal context.
+ "The expansion command called by \\[pcomplete] in normal context.
Normal means, no org-mode-specific context."
:group 'org-completion
:type 'function)
@@ -3125,9 +3568,14 @@ 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-inlinetask-goto-beginning "org-inlinetask" ())
+(declare-function org-inlinetask-goto-end "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" ())
+(declare-function orgtbl-send-table "org-table" (&optional maybe))
(defvar remember-data-file)
(defvar texmathp-why)
(declare-function speedbar-line-directory "speedbar" (&optional depth))
@@ -3144,18 +3592,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 +3630,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 +3672,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 +3687,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 +3718,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 +3756,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 +3953,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 +3962,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 +4011,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 +4052,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 +4085,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.
@@ -3664,6 +4135,9 @@ Also put tags into group 4 if tags are present.")
(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 +4194,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 +4211,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 +4227,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 +4253,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 +4272,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 +4325,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 +4345,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 +4424,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 +4468,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 +4486,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 +4525,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 +4539,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 +4569,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 +4607,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 +4615,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 +4629,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 +4662,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 +4674,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 +4699,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 +4713,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 +4730,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 +4753,37 @@ 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))
+
+ ;; Setup the pcomplete hooks
+ (set (make-local-variable 'pcomplete-command-completion-function)
+ 'org-complete-initial)
+ (set (make-local-variable 'pcomplete-command-name-function)
+ 'org-command-at-point)
+ (set (make-local-variable 'pcomplete-default-completion-function)
+ 'ignore)
+ (set (make-local-variable 'pcomplete-parse-arguments-function)
+ 'org-parse-arguments)
+ (set (make-local-variable 'pcomplete-termination-string) "")
+
;; 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
@@ -4292,13 +4801,17 @@ The following commands are available:
(nthcdr 2 time))))
(current-time)))
+(defun org-today ()
+ "Return today date, considering `org-extend-today-until'."
+ (time-to-days
+ (time-subtract (current-time)
+ (list 0 (* 3600 org-extend-today-until) 0))))
+
;;;; 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 +4822,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 +4846,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 +4938,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 +4995,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 +5050,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 +5089,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 +5117,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 +5137,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 +5170,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 +5327,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 +5349,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 +5398,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 +5431,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 +5443,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 +5462,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 +5492,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 +5536,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 +5562,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 characters")
+ (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))
@@ -4982,23 +5615,36 @@ For plain list items, if they are matched by `outline-regexp', this returns
(defvar org-l nil)
(defvar org-f nil)
(defun org-get-level-face (n)
- "Get the right face for match N in font-lock matching of headlines."
- (setq org-l (- (match-end 2) (match-beginning 1) 1))
- (if org-odd-levels-only (setq org-l (1+ (/ org-l 2))))
- (setq org-f (nth (% (1- org-l) org-n-level-faces) org-level-faces))
- (cond
- ((eq n 1) (if org-hide-leading-stars 'org-hide org-f))
- ((eq n 2) org-f)
- (t (if org-level-color-stars-only nil org-f))))
+ "Get the right face for match N in font-lock matching of headlines."
+ (setq org-l (- (match-end 2) (match-beginning 1) 1))
+ (if org-odd-levels-only (setq org-l (1+ (/ org-l 2))))
+ (if org-cycle-level-faces
+ (setq org-f (nth (% (1- org-l) org-n-level-faces) org-level-faces))
+ (setq org-f (nth (1- (min org-l org-n-level-faces)) org-level-faces)))
+ (cond
+ ((eq n 1) (if org-hide-leading-stars 'org-hide org-f))
+ ((eq n 2) org-f)
+ (t (if org-level-color-stars-only nil org-f))))
+
(defun org-get-todo-face (kwd)
"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 +5659,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 +5670,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 +5681,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 +5689,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 +5795,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 +5810,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 +5837,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 +5853,7 @@ in special contexts.
(cond
((equal arg '(16))
+ (setq last-command 'dummy)
(org-set-startup-visibility)
(message "Startup visibility, plus VISIBILITY properties"))
@@ -5146,11 +5863,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 +5961,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 +5977,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 +5984,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 +6026,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 +6041,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,7 +6070,7 @@ 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."
@@ -5436,11 +6154,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 +6184,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 +6300,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 +6355,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 +6379,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 +6404,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"))))
@@ -5739,7 +6496,7 @@ in an indirect buffer, in overview mode. You can dive into the tree in
that copy, use org-occur and incremental search to find a location.
When pressing RET or `Q', the command returns to the original buffer in
which the visibility is still unchanged. After RET is will also jump to
-the location selected in the indirect buffer and expose the
+the location selected in the indirect buffer and expose
the headline hierarchy above."
(interactive "P")
(let* ((org-refile-targets `((nil . (:maxlevel . ,org-goto-max-level))))
@@ -5755,7 +6512,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 +6535,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 +6646,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 +6668,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 +6732,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 +6807,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 +6821,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 +6857,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 +6872,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 +6942,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 +6951,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
@@ -6220,17 +7019,37 @@ in the region."
"Return the level of the current entry, or nil if before the first headline.
The level is the number of stars at the beginning of the headline."
(save-excursion
- (condition-case nil
- (progn
- (org-back-to-heading t)
- (funcall outline-level))
- (error nil))))
+ (let ((outline-regexp (org-get-limited-outline-regexp)))
+ (condition-case nil
+ (progn
+ (org-back-to-heading t)
+ (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 +7097,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 +7161,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 +7199,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 +7538,27 @@ 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 (and (org-on-heading-p) (not (eobp))) (backward-char 1))
+ (point))))))
+
+(eval-when-compile
+ (defvar org-property-drawer-re))
+(defvar org-property-start-re) ;; defined below
(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 +7572,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 +7589,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 +7601,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-start-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 +7621,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 +7655,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 +7674,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 +7692,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 +7702,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 +7734,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 +7774,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 +7916,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 +7975,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 +8217,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 +8242,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 +8273,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 +8305,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 +8347,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 +8385,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 +8448,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."
@@ -7694,12 +8507,13 @@ according to FMT (default from `org-email-link-description-format')."
(defun org-make-org-heading-search-string (&optional string heading)
"Make search string for STRING or current headline."
(interactive)
- (let ((s (or string (org-get-heading))))
+ (let ((s (or string (org-get-heading)))
+ (lines org-context-in-file-links))
(unless (and string (not heading))
;; 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,9 +8521,14 @@ 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
+ (when (and string (integerp lines) (> lines 0))
+ (let ((slines (org-split-string s "\n")))
+ (when (< lines (length slines))
+ (setq s (mapconcat
+ 'identity
+ (reverse (nthcdr (- (length slines) lines)
+ (reverse slines))) "\n")))))
(mapconcat 'identity (org-split-string s "[ \t]+") " ")))
(defun org-make-link (&rest strings)
@@ -7736,7 +8555,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 +8578,7 @@ according to FMT (default from `org-email-link-description-format')."
(?\371 . "%F9") ; `u
(?\373 . "%FB") ; ^u
(?\; . "%3B")
- (?? . "%3F")
+;; (?? . "%3F")
(?= . "%3D")
(?+ . "%2B")
)
@@ -7771,7 +8594,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 +8611,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 +8632,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)
@@ -7841,8 +8672,8 @@ be displayed in the buffer instead of the link.
If there is already a link at point, this command will allow you to edit link
and description parts.
-With a \\[universal-argument] prefix, prompts for a file to link to. The file name can
-be selected using completion. The path to the file will be relative to the
+With a \\[universal-argument] prefix, prompts for a file to link to. The file name can
+be selected using completion. The path to the file will be relative to the
current directory if the file is in the current directory or a subdirectory.
Otherwise, the link will be the absolute path as completed in the minibuffer
\(i.e. normally ~/path/to/file). You can configure this behavior using the
@@ -7899,7 +8730,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 +8755,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 +8789,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 +8805,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 +8932,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 +9061,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 +9083,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,18 +9095,21 @@ 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))
+ ((and (or (org-footnote-at-reference-p) (org-footnote-at-definition-p))
+ (not (org-in-regexp org-bracket-link-regexp)))
(org-footnote-action))
(t
(let (type path link line search (pos (point)))
(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 +9139,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 +9193,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) "\\]")))
@@ -8358,10 +9218,6 @@ application the system uses for this file type."
(dired path)
(org-open-file path in-emacs line search)))
- ((string= type "news")
- (require 'org-gnus)
- (org-gnus-follow-link path))
-
((string= type "shell")
(let ((cmd path))
(if (or (not org-confirm-shell-link-function)
@@ -8387,10 +9243,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 +9292,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 +9311,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 +9363,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 +9385,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 +9401,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 +9419,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 +9464,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 +9531,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 +9674,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 +9698,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 +9764,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 +9789,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 +9891,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 +9987,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 +10051,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 +10064,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 +10074,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 +10114,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 +10136,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 +10148,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 +10311,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 +10324,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 +10481,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,9 +10505,10 @@ 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."
+ (interactive)
(save-window-excursion
(let* ((pos (point))
(line (org-current-line))
@@ -9467,6 +10550,7 @@ Error if there is no such block at point."
(defun org-update-all-dblocks ()
"Update all dynamic blocks in the buffer.
This function can be used in a hook."
+ (interactive)
(when (org-mode-p)
(org-map-dblocks 'org-update-dblock)))
@@ -9474,9 +10558,10 @@ This function can be used in a hook."
;;;; Completion
(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_HTML" "END_HTML" "HTML:" "ATTR_HTML:"
+ "BEGIN_DocBook" "END_DocBook" "DocBook:" "ATTR_DocBook:"
+ "BEGIN_LaTeX" "END_LaTeX" "LaTeX:" "LATEX_HEADER:"
+ "LATEX_CLASS:" "LATEX_CLASS_OPTIONS:" "ATTR_LaTeX:"
"BEGIN:" "END:"
"ORGTBL" "TBLFM:" "TBLNAME:"
"BEGIN_EXAMPLE" "END_EXAMPLE"
@@ -9484,11 +10569,17 @@ This function can be used in a hook."
"BEGIN_VERSE" "END_VERSE"
"BEGIN_CENTER" "END_CENTER"
"BEGIN_SRC" "END_SRC"
- "CATEGORY" "COLUMNS"
- "CAPTION" "LABEL"
- "SETUPFILE"
- "BIND"
- "MACRO"))
+ "BEGIN_RESULT" "END_RESULT"
+ "SOURCE:" "SRCNAME:" "FUNCTION:"
+ "RESULTS:"
+ "HEADER:" "HEADERS:"
+ "BABEL:"
+ "CATEGORY:" "COLUMNS:" "PROPERTY:"
+ "CAPTION:" "LABEL:"
+ "SETUPFILE:"
+ "INCLUDE:"
+ "BIND:"
+ "MACRO:"))
(defcustom org-structure-template-alist
'(
@@ -9517,12 +10608,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
@@ -9570,132 +10661,6 @@ expands them."
(insert rpl)
(if (re-search-backward "\\?" start t) (delete-char 1))))
-
-(defun org-complete (&optional arg)
- "Perform completion on word at point.
-At the beginning of a headline, this completes TODO keywords as given in
-`org-todo-keywords'.
-If the current word is preceded by a backslash, completes the TeX symbols
-that are supported for HTML support.
-If the current word is preceded by \"#+\", completes special words for
-setting file options.
-In the line after \"#+STARTUP:, complete valid keywords.\"
-At all other locations, this simply calls the value of
-`org-completion-fallback-command'."
- (interactive "P")
- (org-without-partial-completion
- (catch 'exit
- (let* ((a nil)
- (end (point))
- (beg1 (save-excursion
- (skip-chars-backward (org-re "[:alnum:]_@"))
- (point)))
- (beg (save-excursion
- (skip-chars-backward "a-zA-Z0-9_:$")
- (point)))
- (confirm (lambda (x) (stringp (car x))))
- (searchhead (equal (char-before beg) ?*))
- (struct
- (when (and (member (char-before beg1) '(?. ?<))
- (setq a (assoc (buffer-substring beg1 (point))
- org-structure-template-alist)))
- (org-complete-expand-structure-template (1- beg1) a)
- (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)) ?*))))
- (texp (equal (char-before beg) ?\\))
- (link (equal (char-before beg) ?\[))
- (opt (equal (buffer-substring (max (point-at-bol) (- beg 2))
- beg)
- "#+"))
- (startup (string-match "^#\\+STARTUP:.*"
- (buffer-substring (point-at-bol) (point))))
- (completion-ignore-case opt)
- (type nil)
- (tbl nil)
- (table (cond
- (opt
- (setq type :opt)
- (require 'org-exp)
- (append
- (delq nil
- (mapcar
- (lambda (x)
- (if (string-match
- "^#\\+\\(\\([A-Z_]+:?\\).*\\)" x)
- (cons (match-string 2 x)
- (match-string 1 x))))
- (org-split-string (org-get-current-options) "\n")))
- (mapcar 'list org-additional-option-like-keywords)))
- (startup
- (setq type :startup)
- org-startup-options)
- (link (append org-link-abbrev-alist-local
- org-link-abbrev-alist))
- (texp
- (setq type :tex)
- org-html-entities)
- ((string-match "\\`\\*+[ \t]+\\'"
- (buffer-substring (point-at-bol) beg))
- (setq type :todo)
- (mapcar 'list org-todo-keywords-1))
- (searchhead
- (setq type :searchhead)
- (save-excursion
- (goto-char (point-min))
- (while (re-search-forward org-todo-line-regexp nil t)
- (push (list
- (org-make-org-heading-search-string
- (match-string 3) t))
- tbl)))
- tbl)
- (tag (setq type :tag beg beg1)
- (or org-tag-alist (org-get-buffer-tags)))
- (prop (setq type :prop beg beg1)
- (mapcar 'list (org-buffer-property-keys nil t t)))
- (t (progn
- (call-interactively org-completion-fallback-command)
- (throw 'exit nil)))))
- (pattern (buffer-substring-no-properties beg end))
- (completion (try-completion pattern table confirm)))
- (cond ((eq completion t)
- (if (not (assoc (upcase pattern) table))
- (message "Already complete")
- (if (and (equal type :opt)
- (not (member (car (assoc (upcase pattern) table))
- org-additional-option-like-keywords)))
- (insert (substring (cdr (assoc (upcase pattern) table))
- (length pattern)))
- (if (memq type '(:tag :prop)) (insert ":")))))
- ((null completion)
- (message "Can't find completion for \"%s\"" pattern)
- (ding))
- ((not (string= pattern completion))
- (delete-region beg end)
- (if (string-match " +$" completion)
- (setq completion (replace-match "" t t completion)))
- (insert completion)
- (if (get-buffer-window "*Completions*")
- (delete-window (get-buffer-window "*Completions*")))
- (if (assoc completion table)
- (if (eq type :todo) (insert " ")
- (if (memq type '(:tag :prop)) (insert ":"))))
- (if (and (equal type :opt) (assoc completion table))
- (message "%s" (substitute-command-keys
- "Press \\[org-complete] again to insert example settings"))))
- (t
- (message "Making completion list...")
- (let ((list (sort (all-completions pattern table confirm)
- 'string<)))
- (with-output-to-temp-buffer "*Completions*"
- (condition-case nil
- ;; Protection needed for XEmacs and emacs 21
- (display-completion-list list pattern)
- (error (display-completion-list list)))))
- (message "Making completion list...%s" "done")))))))
-
;;;; TODO, DEADLINE, Comments
(defun org-toggle-comment ()
@@ -9719,38 +10684,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 +10709,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 +10742,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 +10924,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 +11017,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 +11076,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 +11086,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 +11363,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 +11409,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 +11460,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 +11498,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 +11539,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 +11657,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 +11682,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 +11743,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 +11773,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 +11792,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 +11808,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 +11832,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,17 +11878,18 @@ 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.
-/ Show entries matching a regular expression (`r' can be used as well)
+r Show entries matching a regular expression (`/' can be used as well)
d Show deadlines due within `org-deadline-warning-days'.
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: [r]egexp [/]regexp [t]odo [T]odo-kwd [m]atch [p]roperty\n [d]eadlines [b]efore-date [a]fter-date")
(setq ans (read-char-exclusive))
(cond
((equal ans ?d)
@@ -10869,6 +11899,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 +11972,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 +12003,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 +12014,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 +12042,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 +12089,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)))
@@ -11089,11 +12134,13 @@ ACTION can be `set', `up', `down', or a character."
(defun org-get-priority (s)
"Find priority cookie and return priority."
- (save-match-data
- (if (not (string-match org-priority-regexp s))
- (* 1000 (- org-lowest-priority org-default-priority))
- (* 1000 (- org-lowest-priority
- (string-to-char (match-string 2 s)))))))
+ (if (functionp org-get-priority-function)
+ (funcall org-get-priority-function)
+ (save-match-data
+ (if (not (string-match org-priority-regexp s))
+ (* 1000 (- org-lowest-priority org-default-priority))
+ (* 1000 (- org-lowest-priority
+ (string-to-char (match-string 2 s))))))))
;;;; Tags
@@ -11130,7 +12177,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,11 +12377,11 @@ 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
- prop-p pn pv po cat-p gv rest)
+ prop-p pn pv po gv rest)
(if (string-match "/+" match)
;; match contains also a todo-matching request
(progn
@@ -11358,7 +12405,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)
@@ -11372,7 +12421,6 @@ also TODO lines."
(setq pn (match-string 5 term)
po (match-string 6 term)
pv (match-string 7 term)
- cat-p (equal pn "CATEGORY")
re-p (equal (string-to-char pv) ?{)
str-p (equal (string-to-char pv) ?\")
time-p (save-match-data
@@ -11501,7 +12549,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 +12585,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 +12612,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 +12642,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 +12702,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 +12722,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 +12736,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 +12752,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 +12779,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 +12790,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 +12849,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 +12897,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 +12926,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 +12939,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 +13012,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 +13076,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 +13097,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 +13111,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 +13236,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 +13247,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 +13256,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 +13333,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 +13372,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 +13380,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 +13402,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 +13475,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 +13504,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 +13601,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 +13614,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 +13682,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 +13803,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 +13822,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 +13865,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 +13889,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 +13901,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 +13934,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 +14124,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 +14146,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 +14207,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 +14231,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 +14275,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 +14297,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 +14305,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 +14331,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 +14359,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 +14383,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 +14457,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 +14472,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 +14487,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 +14567,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 +14596,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 +14612,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 +14622,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 +14631,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 +14888,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."
@@ -13680,9 +14947,12 @@ D may be an absolute day number, or a calendar-type list (month day year)."
(org-current-line)
(buffer-file-name) sexp)
(sleep-for 2))))))
- (cond ((stringp result) result)
+ (cond ((stringp result) (split-string 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 +15004,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 +15050,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 +15082,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 +15090,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 +15099,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 +15108,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 +15153,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 +15184,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 +15284,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 +15374,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 +15442,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 +15469,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 +15502,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 +15584,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 +15686,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))))
@@ -14440,7 +15746,7 @@ sequence appearing also before point.
Even though the matchers for math are configurable, this function assumes
that \\begin, \\(, \\[, and $$ are always used. Only the single dollar
delimiters are skipped when they have been removed by customization.
-The return value is nil, or a cons cell with the delimiter and
+The return value is nil, or a cons cell with the delimiter
and the position of this delimiter.
This function does a reasonably good job, but can locally be fooled by
@@ -14477,6 +15783,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 +15830,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 +15839,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 +15872,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 +15886,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 +15899,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 +15918,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 +16018,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 +16045,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 +16124,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
@@ -14733,9 +16207,9 @@ Some of the options can be changed using the variable
(org-defkey org-mode-map "\C-i" 'org-cycle)
(org-defkey org-mode-map [(tab)] 'org-cycle)
(org-defkey org-mode-map [(control tab)] 'org-force-cycle-archived)
-(org-defkey org-mode-map [(meta tab)] 'org-complete)
-(org-defkey org-mode-map "\M-\t" 'org-complete)
-(org-defkey org-mode-map "\M-\C-i" 'org-complete)
+(org-defkey org-mode-map [(meta tab)] 'pcomplete)
+(org-defkey org-mode-map "\M-\t" 'pcomplete)
+(org-defkey org-mode-map "\M-\C-i" 'pcomplete)
;; The following line is necessary under Suse GNU/Linux
(unless (featurep 'xemacs)
(org-defkey org-mode-map [S-iso-lefttab] 'org-shifttab))
@@ -14765,6 +16239,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
@@ -14794,7 +16274,7 @@ Some of the options can be changed using the variable
(org-defkey org-mode-map [?\C-c (right)] 'org-shiftright)
(org-defkey org-mode-map [?\C-c ?\C-x (right)] 'org-shiftcontrolright)
(org-defkey org-mode-map [?\C-c ?\C-x (left)] 'org-shiftcontrolleft)
- (org-defkey org-mode-map [?\e (tab)] 'org-complete)
+ (org-defkey org-mode-map [?\e (tab)] 'pcomplete)
(org-defkey org-mode-map [?\e (shift return)] 'org-insert-todo-heading)
(org-defkey org-mode-map [?\e (shift left)] 'org-shiftmetaleft)
(org-defkey org-mode-map [?\e (shift right)] 'org-shiftmetaright)
@@ -14822,7 +16302,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.
@@ -14876,6 +16355,7 @@ Some of the options can be changed using the variable
(org-defkey org-mode-map "\C-c\C-xf" 'org-footnote-action)
(org-defkey org-mode-map "\C-c\C-x\C-mg" 'org-mobile-pull)
(org-defkey org-mode-map "\C-c\C-x\C-mp" 'org-mobile-push)
+(org-defkey org-mode-map "\C-c@" 'org-mark-subtree)
(org-defkey org-mode-map [?\C-c (control ?*)] 'org-list-make-subtree)
;;(org-defkey org-mode-map [?\C-c (control ?-)] 'org-list-make-list-from-subtree)
@@ -14893,16 +16373,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)
@@ -14945,7 +16429,7 @@ Some of the options can be changed using the variable
("^" . org-sort)
("w" . org-refile)
("a" . org-archive-subtree-default-with-confirmation)
- ("." . outline-mark-subtree)
+ ("." . org-mark-subtree)
("Clock Commands")
("I" . org-clock-in)
("O" . org-clock-out)
@@ -14963,6 +16447,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 +16495,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 +16536,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 +16605,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 +16696,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 +16749,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 +16817,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 +16830,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 +16859,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 +16877,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 +16902,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 +16972,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 +16985,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 +16996,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 +17009,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 +17025,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 +17045,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 +17061,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 +17081,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,25 +17144,38 @@ 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))
+ ((or (org-at-table-p)
+ (save-excursion
+ (beginning-of-line 1)
+ (looking-at "[ \t]*#\\+TBLFM:")))
+ (call-interactively 'org-table-edit-formulas))
(t (call-interactively 'ffap))))
-
(defun org-ctrl-c-ctrl-c (&optional arg)
"Set tags in headline, or update according to changed information at point.
@@ -15602,21 +17205,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 +17234,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,25 +17243,25 @@ 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
(call-interactively 'org-table-recalculate)
(org-table-maybe-recalculate-line))
- (call-interactively 'org-table-align))
+ (call-interactively 'org-table-align)
+ (orgtbl-send-table 'maybe))
((or (org-footnote-at-reference-p)
(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 +17278,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 +17296,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 +17317,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 +17383,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 +17593,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"
@@ -16001,11 +17607,11 @@ See the individual commands for more information."
("Select keyword"
["Next keyword" org-shiftright (org-on-heading-p)]
["Previous keyword" org-shiftleft (org-on-heading-p)]
- ["Complete Keyword" org-complete (assq :todo-keyword (org-context))]
+ ["Complete Keyword" pcomplete (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 +17699,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 +17832,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 +17910,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 +17924,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) '("=" "~")))))
@@ -16377,6 +17992,23 @@ upon the next fontification round."
(setq l (- l (get-text-property b 'org-dwidth-n s))))
l))
+(defun org-shorten-string (s maxlength)
+ "Shorten string S so tht it is no longer than MAXLENGTH characters.
+If the string is shorter or has length MAXLENGTH, just return the
+original string. If it is longer, the functions finds a space in the
+string, breaks this string off at that locations and adds three dots
+as ellipsis. Including the ellipsis, the string will not be longer
+than MAXLENGTH. If finding a good breaking point in the string does
+not work, the string is just chopped off in the middle of a word
+if necessary."
+ (if (<= (length s) maxlength)
+ s
+ (let* ((n (max (- maxlength 4) 1))
+ (re (concat "\\`\\(.\\{1," (int-to-string n) "\\}[^ ]\\)\\([ ]\\|\\'\\)")))
+ (if (string-match re s)
+ (concat (match-string 1 s) "...")
+ (concat (substring s 0 (max (- maxlength 3) 0)) "...")))))
+
(defun org-get-indentation (&optional line)
"Get the indentation of the current line, interpreting tabs.
When LINE is given, assume it represents a line and compute its indentation."
@@ -16440,7 +18072,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 +18255,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 +18297,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 +18382,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 +18424,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 +18435,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 +18487,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."
@@ -16890,76 +18579,123 @@ which make use of the date at the cursor."
(message
"Entry marked for action; press `k' at desired date in agenda or calendar"))
+(defun org-mark-subtree ()
+ "Mark the current subtree.
+This puts point at the start of the current subtree, and mark at the end.
+
+If point is in an inline task, mark that task instead."
+ (interactive)
+ (let ((inline-task-p
+ (and (featurep 'org-inlinetask)
+ (org-inlinetask-in-task-p)))
+ (beg))
+ ;; Get beginning of subtree
+ (cond
+ (inline-task-p (org-inlinetask-goto-beginning))
+ ((org-at-heading-p) (beginning-of-line))
+ (t (let ((outline-regexp (org-get-limited-outline-regexp)))
+ (outline-previous-visible-heading 1))))
+ (setq beg (point))
+ ;; Get end of it
+ (if inline-task-p
+ (org-inlinetask-goto-end)
+ (org-end-of-subtree))
+ ;; Mark zone
+ (push-mark (point) nil t)
+ (goto-char beg)))
+
;;; Paragraph filling stuff.
;; We want this to be just right, so use the full arsenal.
(defun org-indent-line-function ()
- "Indent line like previous, but further if previous was headline or item."
+ "Indent line depending on context."
(interactive)
(let* ((pos (point))
(itemp (org-at-item-p))
(case-fold-search t)
(org-drawer-regexp (or org-drawer-regexp "\000"))
- column bpos bcol tpos tcol bullet btype bullet-type)
- ;; Find the previous relevant line
+ (inline-task-p (and (featurep 'org-inlinetask)
+ (org-inlinetask-in-task-p)))
+ column bpos bcol tpos tcol)
(beginning-of-line 1)
(cond
- ((looking-at "#") (setq column 0))
+ ;; Comments
+ ((looking-at "# ") (setq column 0))
+ ;; Headings
((looking-at "\\*+ ") (setq column 0))
+ ;; Literal examples
+ ((looking-at "[ \t]*:[ \t]")
+ (setq column (org-get-indentation))) ; do nothing
+ ;; 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)))
+ (if (> tcol (+ bcol org-description-max-indent))
+ (setq tcol (+ bcol 5)))
+ (goto-char pos)
+ (setq column (if itemp (org-get-indentation) tcol)))
+ ;; This line has nothing special, look at the previous relevant
+ ;; line to compute indentation
(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))
+ (not (looking-at org-drawer-regexp))
+ ;; skip comments, verbatim, empty lines, tables,
+ ;; inline tasks, lists, drawers and blocks
+ (or (and (looking-at "[ \t]*:END:")
+ (re-search-backward org-drawer-regexp nil t))
+ (and (looking-at "[ \t]*#\\+end_")
+ (re-search-backward "[ \t]*#\\+begin_"nil t))
+ (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)
+ (or (org-inlinetask-goto-beginning) t))))
+ (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
((looking-at org-drawer-regexp)
- (goto-char (1- (match-beginning 1)))
- (setq column (current-column)))
- ((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 (1- (match-beginning 1)))
+ (setq column (current-column)))
+ ;; Else, nothing noticeable found: get indentation and go on.
(t (setq column (org-get-indentation))))))
+ ;; Now apply indentation and move cursor accordingly
(goto-char pos)
(if (<= (current-column) (current-indentation))
(org-indent-line-to column)
(save-excursion (org-indent-line-to column)))
+ ;; Special polishing for properties, see `org-property-format'
(setq column (current-column))
(beginning-of-line 1)
(if (looking-at
@@ -16970,6 +18706,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 +18747,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 +18780,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 +18792,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 +18900,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 +18949,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)))
@@ -17215,8 +18966,6 @@ beyond the end of the headline."
(define-key org-mode-map "\C-a" 'org-beginning-of-line)
(define-key org-mode-map "\C-e" 'org-end-of-line)
-(define-key org-mode-map [home] 'org-beginning-of-line)
-(define-key org-mode-map [end] 'org-end-of-line)
(defun org-backward-sentence (&optional arg)
"Go to beginning of sentence, or beginning of table field.
@@ -17246,8 +18995,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 +19027,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
@@ -17285,7 +19040,7 @@ plainly yank the text as it is.
"Perform some yank-like command.
This function implements the behavior described in the `org-yank'
-documentation. However, it has been generalized to work for any
+documentation. However, it has been generalized to work for any
interactive command with similar behavior."
;; pretend to be command COMMAND
@@ -17363,6 +19118,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 +19145,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 +19162,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 +19245,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 +19348,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 +19363,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 +19510,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 +19547,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 +19562,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."
@@ -17846,7 +19641,5 @@ Still experimental, may disappear in the future."
(run-hooks 'org-load-hook)
-;; arch-tag: e77da1a7-acc7-4336-b19e-efa25af3f9fd
;;; org.el ends here
-
diff --git a/lisp/outline.el b/lisp/outline.el
index d5761cb205d..2f84e7d93ea 100644
--- a/lisp/outline.el
+++ b/lisp/outline.el
@@ -1,7 +1,7 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1986, 1993-1995, 1997, 2000-2011
+;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: outlines
@@ -41,7 +41,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.
@@ -50,9 +50,9 @@ Note that Outline mode only checks this regexp at the start of a line,
so the regexp need not (and usually does not) start with `^'.
The recommended way to set this is with a Local Variables: list
in the file it applies to. See also `outline-heading-end-regexp'."
- :type '(choice regexp (const nil))
+ :type 'regexp
:group 'outlines)
-;;;###autoload(put 'outline-regexp 'safe-local-variable 'string-or-null-p)
+;;;###autoload(put 'outline-regexp 'safe-local-variable 'stringp)
(defcustom outline-heading-end-regexp "\n"
"Regular expression to match the end of a heading line.
@@ -62,6 +62,7 @@ The recommended way to set this is with a `Local Variables:' list
in the file it applies to."
:type 'regexp
:group 'outlines)
+;;;###autoload(put 'outline-heading-end-regexp 'safe-local-variable 'stringp)
(defvar outline-mode-prefix-map
(let ((map (make-sparse-keymap)))
@@ -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."
@@ -803,7 +800,7 @@ If FLAG is nil then text is shown, while if FLAG is t the text is hidden."
;; Function to be set as an outline-isearch-open-invisible' property
;; to the overlay that makes the outline invisible (see
;; `outline-flag-region').
-(defun outline-isearch-open-invisible (overlay)
+(defun outline-isearch-open-invisible (_overlay)
;; We rely on the fact that isearch places point on the matched text.
(show-entry))
@@ -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 ()
@@ -1118,5 +1119,4 @@ convenient way to make a table of contents of the buffer."
(provide 'outline)
(provide 'noutline)
-;; arch-tag: 1724410e-7d4d-4f46-b801-49e18171e874
;;; outline.el ends here
diff --git a/lisp/paren.el b/lisp/paren.el
index a33f46453cd..8bd96b9317a 100644
--- a/lisp/paren.el
+++ b/lisp/paren.el
@@ -1,7 +1,6 @@
;;; paren.el --- highlight matching paren
-;; Copyright (C) 1993, 1996, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1996, 2001-2011 Free Software Foundation, Inc.
;; Author: rms@gnu.org
;; Maintainer: FSF
@@ -52,8 +51,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 +251,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 4d670bdf2bf..941428d5291 100644
--- a/lisp/password-cache.el
+++ b/lisp/password-cache.el
@@ -1,7 +1,6 @@
;;; password-cache.el --- Read passwords, possibly using a password cache.
-;; Copyright (C) 1999, 2000, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1999-2000, 2003-2011 Free Software Foundation, Inc.
;; Author: Simon Josefsson <simon@josefsson.org>
;; Created: 2003-12-21
@@ -51,11 +50,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'."
@@ -73,6 +76,13 @@ regulate cache behavior."
key
(symbol-value (intern-soft key password-data))))
+;;;###autoload
+(defun password-in-cache-p (key)
+ "Check if KEY is in the cache."
+ (and password-cache
+ key
+ (intern-soft key password-data)))
+
(defun password-read (prompt &optional key)
"Read password, for use with KEY, from user, or from cache if wanted.
KEY indicate the purpose of the password, so the cache can
@@ -101,16 +111,17 @@ 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
user again."
(let ((password (symbol-value (intern-soft key password-data))))
(when password
- (if (fboundp 'clear-string)
- (clear-string password)
- (fillarray password ?_))
+ (when (stringp password)
+ (if (fboundp 'clear-string)
+ (clear-string password)
+ (fillarray password ?_)))
(unintern key password-data))))
(defun password-cache-add (key password)
@@ -130,5 +141,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/patcomp.el b/lisp/patcomp.el
index b542dc27f46..c1965a763ca 100644
--- a/lisp/patcomp.el
+++ b/lisp/patcomp.el
@@ -19,5 +19,4 @@ It uses the command line arguments to specify the files to compile."
(let ((load-path (list (expand-file-name "lisp"))))
(batch-byte-compile)))
-;; arch-tag: cb299b78-1d6c-4c02-945b-12fa2e856d6f
;;; patcomp.el ends here
diff --git a/lisp/paths.el b/lisp/paths.el
index ef65c4440e7..161caf9cb8c 100644
--- a/lisp/paths.el
+++ b/lisp/paths.el
@@ -1,10 +1,10 @@
;;; paths.el --- define pathnames for use by various Emacs commands -*- no-byte-compile: t -*-
-;; Copyright (C) 1986, 1988, 1994, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1986, 1988, 1994, 1999-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -185,5 +185,4 @@ If non-nil, Emacs startup does (load (concat term-file-prefix (getenv \"TERM\"))
You may set this variable to nil in your `.emacs' file if you do not wish
the terminal-initialization file to be loaded.")
-;; arch-tag: bae27ffb-9944-4c87-b569-30d4635a99e1
;;; paths.el ends here
diff --git a/lisp/pcmpl-cvs.el b/lisp/pcmpl-cvs.el
index 49522ea9da8..b6c5eb62b17 100644
--- a/lisp/pcmpl-cvs.el
+++ b/lisp/pcmpl-cvs.el
@@ -1,9 +1,9 @@
;;; pcmpl-cvs.el --- functions for dealing with cvs completions
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
+;; Package: pcomplete
;; This file is part of GNU Emacs.
@@ -184,5 +184,4 @@ operation character applies, as displayed by 'cvs -n update'."
(setq pcomplete-stub nondir)
(pcomplete-uniqify-list entries)))
-;; arch-tag: d2aeac43-4bf5-4509-a496-74b863c6642b
;;; pcmpl-cvs.el ends here
diff --git a/lisp/pcmpl-gnu.el b/lisp/pcmpl-gnu.el
index 2b4334f89ee..62f5fafe2c4 100644
--- a/lisp/pcmpl-gnu.el
+++ b/lisp/pcmpl-gnu.el
@@ -1,7 +1,8 @@
;;; pcmpl-gnu.el --- completions for GNU project tools
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
+
+;; Package: pcomplete
;; This file is part of GNU Emacs.
@@ -305,5 +306,4 @@
;;;###autoload
(defalias 'pcomplete/gdb 'pcomplete/xargs)
-;; arch-tag: 06d2b429-dcb1-4a57-84e1-f70d87781183
;;; pcmpl-gnu.el ends here
diff --git a/lisp/pcmpl-linux.el b/lisp/pcmpl-linux.el
index 7f2d67fc3cd..8090397627e 100644
--- a/lisp/pcmpl-linux.el
+++ b/lisp/pcmpl-linux.el
@@ -1,7 +1,8 @@
;;; pcmpl-linux.el --- functions for dealing with GNU/Linux completions
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
+
+;; Package: pcomplete
;; This file is part of GNU Emacs.
@@ -97,5 +98,4 @@
(pcomplete-uniqify-list points)
(cons "swap" (pcmpl-linux-mounted-directories))))))
-;; arch-tag: bb0961a6-a623-463d-92c6-497c317293b1
;;; pcmpl-linux.el ends here
diff --git a/lisp/pcmpl-rpm.el b/lisp/pcmpl-rpm.el
index 6d160a68085..475215b1622 100644
--- a/lisp/pcmpl-rpm.el
+++ b/lisp/pcmpl-rpm.el
@@ -1,7 +1,8 @@
;;; pcmpl-rpm.el --- functions for dealing with rpm completions
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
+
+;; Package: pcomplete
;; This file is part of GNU Emacs.
@@ -320,5 +321,4 @@
(provide 'pcmpl-rpm)
-;; arch-tag: 4e64b490-fecf-430e-b2b9-70a8ad64b8c1
;;; pcmpl-rpm.el ends here
diff --git a/lisp/pcmpl-unix.el b/lisp/pcmpl-unix.el
index afa951b184b..e947bfe1da6 100644
--- a/lisp/pcmpl-unix.el
+++ b/lisp/pcmpl-unix.el
@@ -1,7 +1,8 @@
;;; pcmpl-unix.el --- standard UNIX completions
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
+
+;; Package: pcomplete
;; This file is part of GNU Emacs.
@@ -38,14 +39,23 @@
(defcustom pcmpl-ssh-known-hosts-file "~/.ssh/known_hosts"
"If non-nil, a string naming your SSH \"known_hosts\" file.
-This allows completion of SSH host names. Note that newer
-versions of ssh hash the hosts by default to prevent
-Island-hopping SSH attacks. This can be disabled, at some risk,
-with the SSH option \"HashKnownHosts no\"."
+This allows one method of completion of SSH host names, the other
+being via `pcmpl-ssh-config-file'. Note that newer versions of
+ssh hash the hosts by default, to prevent Island-hopping SSH
+attacks. This can be disabled, at some risk, with the SSH option
+\"HashKnownHosts no\"."
:type '(choice file (const nil))
:group 'pcmpl-unix
:version "23.1")
+(defcustom pcmpl-ssh-config-file "~/.ssh/config"
+ "If non-nil, a string naming your SSH \"config\" file.
+This allows one method of completion of SSH host names, the other
+being via `pcmpl-ssh-known-hosts-file'."
+ :type '(choice file (const nil))
+ :group 'pcmpl-unix
+ :version "24.1")
+
;; Functions:
;;;###autoload
@@ -136,7 +146,7 @@ documentation), this function returns nil."
;; ssh support by Phil Hagelberg.
;; http://www.emacswiki.org/cgi-bin/wiki/pcmpl-ssh.el
-(defun pcmpl-ssh-hosts ()
+(defun pcmpl-ssh-known-hosts ()
"Return a list of hosts found in `pcmpl-ssh-known-hosts-file'."
(when (and pcmpl-ssh-known-hosts-file
(file-readable-p pcmpl-ssh-known-hosts-file))
@@ -151,6 +161,27 @@ documentation), this function returns nil."
(add-to-list 'ssh-hosts-list (match-string 1))))
ssh-hosts-list))))
+(defun pcmpl-ssh-config-hosts ()
+ "Return a list of hosts found in `pcmpl-ssh-config-file'."
+ (when (and pcmpl-ssh-config-file
+ (file-readable-p pcmpl-ssh-config-file))
+ (with-temp-buffer
+ (insert-file-contents-literally pcmpl-ssh-config-file)
+ (let (ssh-hosts-list
+ (case-fold-search t))
+ (while (re-search-forward "^ *host\\(name\\)? +\\([-.[:alnum:]]+\\)"
+ nil t)
+ (add-to-list 'ssh-hosts-list (match-string 2)))
+ ssh-hosts-list))))
+
+(defun pcmpl-ssh-hosts ()
+ "Return a list of known SSH hosts.
+Uses both `pcmpl-ssh-config-file' and `pcmpl-ssh-known-hosts-file'."
+ (let ((hosts (pcmpl-ssh-known-hosts)))
+ (dolist (h (pcmpl-ssh-config-hosts))
+ (add-to-list 'hosts h))
+ hosts))
+
;;;###autoload
(defun pcomplete/ssh ()
"Completion rules for the `ssh' command."
@@ -169,5 +200,4 @@ Includes files as well as host names followed by a colon."
(provide 'pcmpl-unix)
-;; arch-tag: 3f9eb5af-7e0e-449d-b586-381cbbf8fc5c
;;; pcmpl-unix.el ends here
diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el
index 309c266015f..2f5dcdfb5e8 100644
--- a/lisp/pcomplete.el
+++ b/lisp/pcomplete.el
@@ -1,7 +1,6 @@
;;; pcomplete.el --- programmable completion
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
;; Keywords: processes abbrev
@@ -349,6 +348,16 @@ modified to be an empty string, or the desired separation string."
(defvar pcomplete-show-list nil)
(defvar pcomplete-expand-only-p nil)
+;; for the sake of the bye-compiler, when compiling other files that
+;; contain completion functions
+(defvar pcomplete-args nil)
+(defvar pcomplete-begins nil)
+(defvar pcomplete-last nil)
+(defvar pcomplete-index nil)
+(defvar pcomplete-stub nil)
+(defvar pcomplete-seen nil)
+(defvar pcomplete-norm-func nil)
+
;;; User Functions:
;;; Alternative front-end using the standard completion facilities.
@@ -440,16 +449,18 @@ in the same way as TABLE completes strings of the form (concat S2 S)."
(if (string-match re c)
(substring c (match-end 0))))
res))))))))))
-
+
;; 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
@@ -467,7 +478,7 @@ Same as `pcomplete' but using the standard completion UI."
;; pcomplete-parse-arguments-function does, that connection
;; might not be that close. E.g. in eshell,
;; pcomplete-parse-arguments-function expands envvars.
- ;;
+ ;;
;; Since we use minibuffer-complete, which doesn't know
;; pcomplete-stub and works from the buffer's text instead,
;; we need to trick minibuffer-complete, into using
@@ -478,56 +489,65 @@ Same as `pcomplete' but using the standard completion UI."
;; prefix from pcomplete-stub.
(beg (max (- (point) (length pcomplete-stub))
(pcomplete-begin)))
- (buftext (buffer-substring beg (point)))
- (table
- (cond
- ((null completions) nil)
- ((not (equal pcomplete-stub buftext))
- ;; This isn't always strictly right (e.g. if
- ;; FOO="toto/$FOO", then completion of /$FOO/bar may
- ;; result in something incorrect), but given the lack of
- ;; any other info, it's about as good as it gets, and in
- ;; practice it should work just fine (fingers crossed).
- (let ((prefixes (pcomplete--common-quoted-suffix
- pcomplete-stub buftext)))
- (apply-partially
- 'pcomplete--table-subvert
- completions
- (cdr prefixes) (car prefixes))))
- (t
- (lexical-let ((completions completions))
- (lambda (string pred action)
- (let ((res (complete-with-action
- action completions string pred)))
- (if (stringp res)
- (pcomplete-quote-argument res)
- res)))))))
- (pred
- ;; pare it down, if applicable
- (when (and table pcomplete-use-paring pcomplete-seen)
- (setq pcomplete-seen
- (mapcar (lambda (f)
- (funcall pcomplete-norm-func
- (directory-file-name f)))
- pcomplete-seen))
- (lambda (f)
- (not (member
- (funcall pcomplete-norm-func
- (directory-file-name f))
- pcomplete-seen))))))
-
- (completion-in-region
- beg (point)
- ;; Add a space at the end of completion. Use a terminator-regexp
- ;; that never matches since the terminator cannot appear
- ;; within the completion field anyway.
- (if (zerop (length pcomplete-termination-string))
- table
- (apply-partially 'completion-table-with-terminator
- (cons pcomplete-termination-string
- "\\`a\\`")
- table))
- pred))))
+ (buftext (buffer-substring beg (point))))
+ (when completions
+ (let ((table
+ (cond
+ ((not (equal pcomplete-stub buftext))
+ ;; This isn't always strictly right (e.g. if
+ ;; FOO="toto/$FOO", then completion of /$FOO/bar may
+ ;; result in something incorrect), but given the lack of
+ ;; any other info, it's about as good as it gets, and in
+ ;; practice it should work just fine (fingers crossed).
+ (let ((prefixes (pcomplete--common-quoted-suffix
+ pcomplete-stub buftext)))
+ (apply-partially
+ 'pcomplete--table-subvert
+ completions
+ (cdr prefixes) (car prefixes))))
+ (t
+ (lexical-let ((completions completions))
+ (lambda (string pred action)
+ (let ((res (complete-with-action
+ action completions string pred)))
+ (if (stringp res)
+ (pcomplete-quote-argument res)
+ res)))))))
+ (pred
+ ;; Pare it down, if applicable.
+ (when (and pcomplete-use-paring pcomplete-seen)
+ (setq pcomplete-seen
+ (mapcar (lambda (f)
+ (funcall pcomplete-norm-func
+ (directory-file-name f)))
+ pcomplete-seen))
+ (lambda (f)
+ (not (when pcomplete-seen
+ (member
+ (funcall pcomplete-norm-func
+ (directory-file-name f))
+ pcomplete-seen)))))))
+ (unless (zerop (length pcomplete-termination-string))
+ ;; Add a space at the end of completion. Use a terminator-regexp
+ ;; that never matches since the terminator cannot appear
+ ;; within the completion field anyway.
+ (setq table
+ (apply-partially #'completion-table-with-terminator
+ (cons pcomplete-termination-string
+ "\\`a\\`")
+ table)))
+ (when pcomplete-ignore-case
+ (setq table
+ (apply-partially #'completion-table-case-fold table)))
+ (list beg (point) table :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 ((data (pcomplete-completions-at-point)))
+ (completion-in-region (nth 0 data) (nth 1 data) (nth 2 data)
+ (plist-get :predicate (nthcdr 3 data)))))
;;; Pcomplete's native UI.
@@ -544,7 +564,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 +627,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 +650,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))
@@ -639,17 +659,6 @@ This will modify the current buffer."
;;; Internal Functions:
;; argument handling
-
-;; for the sake of the bye-compiler, when compiling other files that
-;; contain completion functions
-(defvar pcomplete-args nil)
-(defvar pcomplete-begins nil)
-(defvar pcomplete-last nil)
-(defvar pcomplete-index nil)
-(defvar pcomplete-stub nil)
-(defvar pcomplete-seen nil)
-(defvar pcomplete-norm-func nil)
-
(defun pcomplete-arg (&optional index offset)
"Return the textual content of the INDEXth argument.
INDEX is based from the current processing position. If INDEX is
@@ -774,7 +783,9 @@ this is `comint-dynamic-complete-functions'."
(set (make-local-variable completef-sym)
(copy-sequence (symbol-value completef-sym)))
(let* ((funs (symbol-value completef-sym))
- (elem (or (memq 'shell-dynamic-complete-filename funs)
+ (elem (or (memq 'comint-filename-completion funs)
+ (memq 'shell-filename-completion funs)
+ (memq 'shell-dynamic-complete-filename funs)
(memq 'comint-dynamic-complete-filename funs))))
(if elem
(setcar elem 'pcomplete)
@@ -987,13 +998,14 @@ component, `default-directory' is used as the basis for completion."
(pcomplete-next-arg)
(funcall sym)))))))
-(defun pcomplete-opt (options &optional prefix no-ganging args-follow)
+(defun pcomplete-opt (options &optional prefix _no-ganging _args-follow)
"Complete a set of OPTIONS, each beginning with PREFIX (?- by default).
PREFIX may be t, in which case no PREFIX character is necessary.
If NO-GANGING is non-nil, each option is separate (-xy is not allowed).
If ARGS-FOLLOW is non-nil, then options which take arguments may have
the argument appear after a ganged set of options. This is how tar
-behaves, for example."
+behaves, for example.
+Arguments NO-GANGING and ARGS-FOLLOW are currently ignored."
(if (and (= pcomplete-index pcomplete-last)
(string= (pcomplete-arg) "-"))
(let ((len (length options))
@@ -1198,7 +1210,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) ?\\)
@@ -1240,11 +1252,12 @@ extra checking, and munging of the COMPLETIONS list."
(setq completions
(apply-partially 'completion-table-with-predicate
completions
- (lambda (f)
- (not (member
- (funcall pcomplete-norm-func
- (directory-file-name f))
- pcomplete-seen)))
+ (when pcomplete-seen
+ (lambda (f)
+ (not (member
+ (funcall pcomplete-norm-func
+ (directory-file-name f))
+ pcomplete-seen))))
'strict)))
;; OK, we've got a list of completions.
(if pcomplete-show-list
@@ -1382,5 +1395,4 @@ Returns the resultant list."
(provide 'pcomplete)
-;; arch-tag: ae32ef2d-dbed-4244-8b0f-cf5a2a3b07a4
;;; pcomplete.el ends here
diff --git a/lisp/play/5x5.el b/lisp/play/5x5.el
index 9efc9870628..46c3c867304 100644
--- a/lisp/play/5x5.el
+++ b/lisp/play/5x5.el
@@ -1,7 +1,6 @@
;;; 5x5.el --- simple little puzzle game
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Dave Pearson <davep@davep.org>
;; Maintainer: Dave Pearson <davep@davep.org>
@@ -108,12 +107,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 +135,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.
@@ -373,15 +368,15 @@ should return a grid vector array that is the new solution."
(5x5-copy-grid best-solution)))))
(setq 5x5-cracking nil))
-(defun 5x5-make-random-solution (&rest ignore)
+(defun 5x5-make-random-solution (&rest _ignore)
"Make a random solution."
(5x5-make-random-grid))
-(defun 5x5-make-mutate-current (current best)
+(defun 5x5-make-mutate-current (current _best)
"Mutate the current solution."
(5x5-mutate-solution current))
-(defun 5x5-make-mutate-best (current best)
+(defun 5x5-make-mutate-best (_current best)
"Mutate the best solution."
(5x5-mutate-solution best))
@@ -516,5 +511,4 @@ in progress because it is an animated attempt."
(provide '5x5)
-;; arch-tag: ec4dabd5-572d-41ea-b48c-ec5ce0d68fa9
;;; 5x5.el ends here
diff --git a/lisp/play/animate.el b/lisp/play/animate.el
index 505468b363d..157a2fe7593 100644
--- a/lisp/play/animate.el
+++ b/lisp/play/animate.el
@@ -1,7 +1,6 @@
;;; animate.el --- make text dance
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;; Maintainer: Richard Stallman <rms@gnu.org>
;; Keywords: games
@@ -191,5 +190,4 @@ You can specify the one's name by NAME; the default value is \"Sarah\"."
(provide 'animate)
-;; arch-tag: 275289a3-6ac4-41da-b527-a1147045392f
;;; animate.el ends here
diff --git a/lisp/play/blackbox.el b/lisp/play/blackbox.el
index b197060a752..42d1d8e09fa 100644
--- a/lisp/play/blackbox.el
+++ b/lisp/play/blackbox.el
@@ -1,7 +1,6 @@
;;; blackbox.el --- blackbox game in Emacs Lisp
-;; Copyright (C) 1985, 1986, 1987, 1992, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1987, 1992, 2001-2011 Free Software Foundation, Inc.
;; Author: F. Thomas May <uw-nsr!uw-warp!tom@beaver.cs.washington.edu>
;; Adapted-By: ESR
@@ -434,5 +433,4 @@ a reflection."
(provide 'blackbox)
-;; arch-tag: 6c474c62-5617-4b10-9b44-ac430168c0e2
;;; blackbox.el ends here
diff --git a/lisp/play/bruce.el b/lisp/play/bruce.el
index 22772f4e3d6..168d528ecb1 100644
--- a/lisp/play/bruce.el
+++ b/lisp/play/bruce.el
@@ -1,8 +1,7 @@
;;; bruce.el --- bruce phrase utility for overloading the Communications -*- no-byte-compile: t -*-
;;; Decency Act snoops, if any.
-;; Copyright (C) 1988, 1993, 1997, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1988, 1993, 1997, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: games
@@ -146,5 +145,4 @@
(provide 'bruce)
-;; arch-tag: b83ded51-4ccb-41ef-8bd6-3b521e81dd9b
;;; bruce.el ends here
diff --git a/lisp/play/bubbles.el b/lisp/play/bubbles.el
index eb624ca959c..f2b7294e2d0 100644
--- a/lisp/play/bubbles.el
+++ b/lisp/play/bubbles.el
@@ -1,6 +1,6 @@
-;;; bubbles.el --- Puzzle game for Emacs.
+;;; bubbles.el --- Puzzle game for Emacs
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Ulf Jasper <ulf.jasper@web.de>
;; URL: http://ulf.epplejasper.de/
@@ -719,57 +719,57 @@ static char * dot3d_xpm[] = {
(defsubst bubbles--grid-width ()
"Return the grid width for the current game theme."
(car (case bubbles-game-theme
- ('easy
+ (easy
bubbles--grid-small)
- ('medium
+ (medium
bubbles--grid-medium)
- ('difficult
+ (difficult
bubbles--grid-large)
- ('hard
+ (hard
bubbles--grid-huge)
- ('user-defined
+ (user-defined
bubbles-grid-size))))
(defsubst bubbles--grid-height ()
"Return the grid height for the current game theme."
(cdr (case bubbles-game-theme
- ('easy
+ (easy
bubbles--grid-small)
- ('medium
+ (medium
bubbles--grid-medium)
- ('difficult
+ (difficult
bubbles--grid-large)
- ('hard
+ (hard
bubbles--grid-huge)
- ('user-defined
+ (user-defined
bubbles-grid-size))))
(defsubst bubbles--colors ()
"Return the color list for the current game theme."
(case bubbles-game-theme
- ('easy
+ (easy
bubbles--colors-2)
- ('medium
+ (medium
bubbles--colors-3)
- ('difficult
+ (difficult
bubbles--colors-4)
- ('hard
+ (hard
bubbles--colors-5)
- ('user-defined
+ (user-defined
bubbles-colors)))
(defsubst bubbles--shift-mode ()
"Return the shift mode for the current game theme."
(case bubbles-game-theme
- ('easy
+ (easy
'default)
- ('medium
+ (medium
'default)
- ('difficult
+ (difficult
'always)
- ('hard
+ (hard
'always)
- ('user-defined
+ (user-defined
bubbles-shift-mode)))
(defun bubbles-save-settings ()
@@ -921,7 +921,8 @@ static char * dot3d_xpm[] = {
(define-derived-mode bubbles-mode nil "Bubbles"
"Major mode for playing bubbles.
\\{bubbles-mode-map}"
- (setq buffer-read-only t)
+ (setq buffer-read-only t
+ show-trailing-whitespace nil)
(buffer-disable-undo)
(force-mode-line-update)
(redisplay)
@@ -1317,8 +1318,7 @@ Use optional parameter POS instead of point if given."
Return t if new char is non-empty."
(save-excursion
(when (bubbles--goto row col)
- (let ((char-org (char-after (point)))
- (char-new (bubbles--empty-char))
+ (let ((char-new (bubbles--empty-char))
(removed nil)
(trow row)
(tcol col)
@@ -1346,11 +1346,11 @@ Return t if new char is non-empty."
(when (and (display-images-p)
(not (eq bubbles-graphics-theme 'ascii)))
(let ((template (case bubbles-graphics-theme
- ('circles bubbles--image-template-circle)
- ('balls bubbles--image-template-ball)
- ('squares bubbles--image-template-square)
- ('diamonds bubbles--image-template-diamond)
- ('emacs bubbles--image-template-emacs))))
+ (circles bubbles--image-template-circle)
+ (balls bubbles--image-template-ball)
+ (squares bubbles--image-template-square)
+ (diamonds bubbles--image-template-diamond)
+ (emacs bubbles--image-template-emacs))))
(setq bubbles--empty-image
(create-image (replace-regexp-in-string
"^\"\\(.*\\)\t.*c .*\",$"
@@ -1416,9 +1416,8 @@ Return t if new char is non-empty."
(dotimes (i (bubbles--grid-height))
(dotimes (j (bubbles--grid-width))
(bubbles--goto i j)
- (let* ((index (get-text-property (point) 'index))
- (face (nth index bubbles--faces))
- (fg-col (face-foreground face)))
+ (let ((face (nth (get-text-property (point) 'index)
+ bubbles--faces)))
(when (get-text-property (point) 'active)
(set-face-foreground 'bubbles--highlight-face "#ff0000")
(setq face 'bubbles--highlight-face))
@@ -1434,8 +1433,7 @@ Return t if new char is non-empty."
(save-excursion
(goto-char (point-min))
(forward-line 1)
- (let ((inhibit-read-only t)
- char)
+ (let ((inhibit-read-only t))
(dotimes (i (bubbles--grid-height))
(dotimes (j (bubbles--grid-width))
(forward-char 1)
@@ -1460,5 +1458,4 @@ Return t if new char is non-empty."
(provide 'bubbles)
-;; arch-tag: 2cd7237a-b0ad-400d-a7fd-75f676dceb70
;;; bubbles.el ends here
diff --git a/lisp/play/cookie1.el b/lisp/play/cookie1.el
index dc984d10947..837213665fc 100644
--- a/lisp/play/cookie1.el
+++ b/lisp/play/cookie1.el
@@ -1,7 +1,6 @@
;;; cookie1.el --- retrieve random phrases from fortune cookie files
-;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2001-2011 Free Software Foundation, Inc.
;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
;; Maintainer: FSF
@@ -164,5 +163,4 @@ Optional fifth arg REQUIRE-MATCH non-nil forces a matching cookie."
(provide 'cookie1)
-;; arch-tag: 4a8a8712-df6a-4f34-b030-108a1b47f9f2
;;; cookie1.el ends here
diff --git a/lisp/play/decipher.el b/lisp/play/decipher.el
index 38a858bbf29..b9ce669533a 100644
--- a/lisp/play/decipher.el
+++ b/lisp/play/decipher.el
@@ -1,7 +1,6 @@
;;; decipher.el --- cryptanalyze monoalphabetic substitution ciphers
;;
-;; Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-1996, 2001-2011 Free Software Foundation, Inc.
;;
;; Author: Christopher J. Madsen <chris_madsen@geocities.com>
;; Keywords: games
@@ -154,38 +153,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")
@@ -355,7 +353,7 @@ The most useful commands are:
(let ((char-a (following-char))
(char-b (decipher-last-command-char)))
(or (and (not (= ?w (char-syntax char-a)))
- (= char-b ?\ )) ;Spacebar just advances on non-letters
+ (= char-b ?\s)) ;Spacebar just advances on non-letters
(funcall decipher-function char-a char-b)))))
(forward-char))
@@ -368,10 +366,10 @@ The most useful commands are:
(decipher-set-map a b))
((and (>= a ?a) (<= a ?z))
;; If A is lowercase, then it is in the plaintext alphabet:
- (if (= b ?\ )
+ (if (= b ?\s)
;; We are clearing the association (if any):
- (if (/= ?\ (setq b (cdr (assoc a decipher-alphabet))))
- (decipher-set-map b ?\ ))
+ (if (/= ?\s (setq b (cdr (assoc a decipher-alphabet))))
+ (decipher-set-map b ?\s))
;; Associate the plaintext char with the char pressed:
(decipher-set-map b a)))
(t
@@ -434,12 +432,12 @@ The most useful commands are:
;; modified using setcdr.
(let ((cipher-map (decipher-copy-cons (rassoc cipher-char decipher-alphabet)))
(plain-map (decipher-copy-cons (assoc plain-char decipher-alphabet))))
- (cond ((equal ?\ plain-char)
+ (cond ((equal ?\s plain-char)
cipher-map)
((equal cipher-char (cdr plain-map))
nil) ;We aren't changing anything
- ((equal ?\ (cdr plain-map))
- (or cipher-map (cons ?\ cipher-char)))
+ ((equal ?\s (cdr plain-map))
+ (or cipher-map (cons ?\s cipher-char)))
(cipher-map
(list plain-map cipher-map))
(t
@@ -468,15 +466,15 @@ The most useful commands are:
(goto-char (point-min))
(if (setq mapping (rassoc cipher-char decipher-alphabet))
(progn
- (setcdr mapping ?\ )
+ (setcdr mapping ?\s)
(search-forward-regexp (concat "^([a-z]*"
(char-to-string (car mapping))))
- (decipher-insert ?\ )
+ (decipher-insert ?\s)
(beginning-of-line)))
(if (setq mapping (assoc plain-char decipher-alphabet))
(progn
- (if (/= ?\ (cdr mapping))
- (decipher-set-map (cdr mapping) ?\ t))
+ (if (/= ?\s (cdr mapping))
+ (decipher-set-map (cdr mapping) ?\s t))
(setcdr mapping cipher-char)
(search-forward-regexp (concat "^([a-z]*" plain-string))
(decipher-insert cipher-char)
@@ -488,7 +486,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)))))))
@@ -529,8 +527,7 @@ Type `\\[decipher-restore-checkpoint]' to restore a checkpoint."
(or (stringp desc)
(setq desc ""))
(let (alphabet
- buffer-read-only ;Make buffer writable
- mapping)
+ buffer-read-only) ;Make buffer writable
(goto-char (point-min))
(re-search-forward "^)")
(move-to-column 27 t)
@@ -587,12 +584,12 @@ you have determined the keyword."
buffer-read-only ;Make buffer writable
plain-map undo-rec)
(while (setq plain-map (pop ptr))
- (if (equal ?\ (cdr plain-map))
+ (if (equal ?\s (cdr plain-map))
(progn
(while (rassoc cipher-char decipher-alphabet)
;; Find the next unused letter
(incf cipher-char))
- (push (cons ?\ cipher-char) undo-rec)
+ (push (cons ?\s cipher-char) undo-rec)
(decipher-set-map cipher-char (car plain-map) t))))
(decipher-add-undo undo-rec)))
@@ -626,7 +623,7 @@ You should use this if you edit the ciphertext."
(replace-match ">" nil nil))
(decipher-read-alphabet)
(while (setq mapping (pop alphabet))
- (or (equal ?\ (cdr mapping))
+ (or (equal ?\s (cdr mapping))
(decipher-set-map (cdr mapping) (car mapping))))))
(setq decipher-undo-list nil
decipher-undo-list-size 0)
@@ -753,8 +750,8 @@ FUNC is called exactly once between words, with `decipher-char' set to
a space.
See `decipher-loop-no-breaks' if you do not care about word divisions."
- (let ((decipher-char ?\ )
- (decipher--loop-prev-char ?\ ))
+ (let ((decipher-char ?\s)
+ (decipher--loop-prev-char ?\s))
(save-excursion
(goto-char (point-min))
(funcall func) ;Space marks beginning of first word
@@ -762,16 +759,16 @@ See `decipher-loop-no-breaks' if you do not care about word divisions."
(while (not (eolp))
(setq decipher-char (upcase (following-char)))
(or (and (>= decipher-char ?A) (<= decipher-char ?Z))
- (setq decipher-char ?\ ))
- (or (and (equal decipher-char ?\ )
- (equal decipher--loop-prev-char ?\ ))
+ (setq decipher-char ?\s))
+ (or (and (equal decipher-char ?\s)
+ (equal decipher--loop-prev-char ?\s))
(funcall func))
(setq decipher--loop-prev-char decipher-char)
(forward-char))
- (or (equal decipher-char ?\ )
+ (or (equal decipher-char ?\s)
(progn
(setq decipher-char ?\s
- decipher--loop-prev-char ?\ )
+ decipher--loop-prev-char ?\s)
(funcall func)))))))
(defun decipher-loop-no-breaks (func)
@@ -846,13 +843,13 @@ TOTAL is the total number of letters in the ciphertext."
decipher--digram-list)))))
(and (>= decipher--prev-char ?A)
(incf (aref (aref decipher--before (- decipher--prev-char ?A))
- (if (equal decipher-char ?\ )
+ (if (equal decipher-char ?\s)
26
(- decipher-char ?A)))))
(and (>= decipher-char ?A)
(incf (aref decipher--freqs (- decipher-char ?A)))
(incf (aref (aref decipher--after (- decipher-char ?A))
- (if (equal decipher--prev-char ?\ )
+ (if (equal decipher--prev-char ?\s)
26
(- decipher--prev-char ?A)))))
(setq decipher--prev-char decipher-char))
@@ -885,7 +882,7 @@ TOTAL is the total number of letters in the ciphertext."
(defun decipher-analyze-buffer ()
"Perform frequency analysis and store results in statistics buffer.
Creates the statistics buffer if it doesn't exist."
- (let ((decipher--prev-char (if decipher-ignore-spaces ?\ ?\*))
+ (let ((decipher--prev-char (if decipher-ignore-spaces ?\s ?\*))
(decipher--before (make-vector 26 nil))
(decipher--after (make-vector 26 nil))
(decipher--freqs (make-vector 26 0))
@@ -1059,9 +1056,8 @@ if it can't, it signals an error."
;; (setq undo-rec (list undo-rec)))
;; (insert ?\()
;; (while (setq undo-map (pop undo-rec))
-;; (insert (cdr undo-map) (car undo-map) ?\ ))
-;; (delete-backward-char 1)
+;; (insert (cdr undo-map) (car undo-map) ?\s))
+;; (delete-char -1)
;; (insert ")\n"))))))
-;; arch-tag: 8f094d88-ffe1-4f99-afe3-a5e81dd939d9
;;; decipher.el ends here
diff --git a/lisp/play/dissociate.el b/lisp/play/dissociate.el
index 17ec375035f..4530e586de8 100644
--- a/lisp/play/dissociate.el
+++ b/lisp/play/dissociate.el
@@ -1,7 +1,6 @@
;;; dissociate.el --- scramble text amusingly for Emacs
-;; Copyright (C) 1985, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: games
@@ -99,5 +98,4 @@ Default is 2."
(provide 'dissociate)
-;; arch-tag: 90d197d1-409b-45c5-a0b5-fbfb2e06334f
;;; dissociate.el ends here
diff --git a/lisp/play/doctor.el b/lisp/play/doctor.el
index fd69497dc42..54a5a4ef6c9 100644
--- a/lisp/play/doctor.el
+++ b/lisp/play/doctor.el
@@ -1,7 +1,7 @@
;;; doctor.el --- psychological help for frustrated users
-;; Copyright (C) 1985, 1987, 1994, 1996, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1987, 1994, 1996, 2000-2011
+;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: games
@@ -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,476 +140,403 @@ 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) \.
- each time you are finished talking, type \R\E\T twice \.))
+ (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.
@@ -563,7 +544,7 @@ reads the sentence before point, and prints the Doctor's answer."
(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))
+ `(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."
@@ -881,44 +862,44 @@ Otherwise call the Doctor to parse preceding sentence."
(defun doctor-doc (sent)
(cond
((equal sent '(foo))
- (doctor-type '(bar! (doc$ please)(doc$ continue) \.)))
- ((member sent howareyoulst)
- (doctor-type '(i\'m ok \. (doc$ describe) yourself \.)))
+ (doctor-type '(bar! (doc$ doctor--please) (doc$ doctor--continue) \.)))
+ ((member sent doctor--howareyoulst)
+ (doctor-type '(i\'m ok \. (doc$ doctor--describe) yourself \.)))
((or (member sent '((good bye) (see you later) (i quit) (so long)
(go away) (get lost)))
(memq (car sent)
'(bye halt break quit done exit goodbye
bye\, stop pause goodbye\, stop pause)))
- (doctor-type (doc$ bye)))
+ (doctor-type (doc$ doctor--bye)))
((and (eq (car sent) 'you)
- (memq (cadr sent) abusewords))
- (setq found (cadr sent))
- (doctor-type (doc$ abuselst)))
+ (memq (cadr sent) doctor--abusewords))
+ (setq doctor-found (cadr sent))
+ (doctor-type (doc$ doctor--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 (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))))
+ '(doc// doctor--bak))))
((memq (car sent) '(are is do has have how when where who why))
- (doctor-type (doc$ qlist)))
+ (doctor-type (doc$ doctor--qlist)))
;; ((eq (car sent) 'forget)
;; (set (cadr sent) nil)
- ;; (doctor-type '((doc$ isee)(doc$ please)
- ;; (doc$ continue)\.)))
+ ;; (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))
+ (if (doctor-defq sent) (doctor-define sent doctor-found))
+ (if (> (length sent) 12) (setq sent (doctor-shorten sent)))
+ (setq sent (doctor-correct-spelling (doctor-replace sent doctor--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))
@@ -932,13 +913,13 @@ Otherwise call the Doctor to parse preceding sentence."
(setq sent (doctor-fixup sent))
(if (and (eq (car sent) 'do) (eq (cadr 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
+ (doctor-type '((doc$ doctor--whysay) that i shouldn\'t
(cddr sent)
\?))))
(doctor-go (doctor-wherego sent))))))))
@@ -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/dunnet.el b/lisp/play/dunnet.el
index 2d59d205f3f..696442ee8cb 100644
--- a/lisp/play/dunnet.el
+++ b/lisp/play/dunnet.el
@@ -1,7 +1,6 @@
;;; dunnet.el --- text adventure for Emacs -*- byte-compile-warnings: nil -*-
-;; Copyright (C) 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992-1993, 2001-2011 Free Software Foundation, Inc.
;; Author: Ron Schnell <ronnie@driver-aces.com>
;; Created: 25 Jul 1992
@@ -3357,5 +3356,4 @@ File not found")))
(provide 'dunnet)
-;; arch-tag: 4cc8e47c-d9e1-4ef4-936b-578e7f529558
;;; dunnet.el ends here
diff --git a/lisp/play/fortune.el b/lisp/play/fortune.el
index c130593ede1..a61b52f4ad1 100644
--- a/lisp/play/fortune.el
+++ b/lisp/play/fortune.el
@@ -1,7 +1,6 @@
;;; fortune.el --- use fortune to create signatures
-;; Copyright (C) 1999, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2001-2011 Free Software Foundation, Inc.
;; Author: Holger Schauer <Holger.Schauer@gmx.de>
;; Keywords: games utils mail
@@ -283,7 +282,7 @@ and choose the directory as the fortune-file."
;;; **************
;;; Display fortune
-(defun fortune-in-buffer (interactive &optional file)
+(defun fortune-in-buffer (_interactive &optional file)
"Put a fortune cookie in the *fortune* buffer.
INTERACTIVE is ignored. Optional argument FILE, when supplied,
specifies the file to choose the fortune from."
diff --git a/lisp/play/gamegrid.el b/lisp/play/gamegrid.el
index 82be2bfbcad..e245e70a55c 100644
--- a/lisp/play/gamegrid.el
+++ b/lisp/play/gamegrid.el
@@ -1,7 +1,6 @@
;;; gamegrid.el --- library for implementing grid-based games on Emacs
-;; Copyright (C) 1997, 1998, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-1998, 2001-2011 Free Software Foundation, Inc.
;; Author: Glynn Clements <glynn@sensei.co.uk>
;; Version: 1.02
@@ -214,19 +213,19 @@ static unsigned char gamegrid_bits[] = {
(let ((data (gamegrid-match-spec-list data-spec-list))
(color (gamegrid-match-spec-list color-spec-list)))
(case data
- ('color-x
+ (color-x
(gamegrid-make-color-x-face color))
- ('grid-x
+ (grid-x
(unless gamegrid-grid-x-face
(setq gamegrid-grid-x-face (gamegrid-make-grid-x-face)))
gamegrid-grid-x-face)
- ('mono-x
+ (mono-x
(unless gamegrid-mono-x-face
(setq gamegrid-mono-x-face (gamegrid-make-mono-x-face)))
gamegrid-mono-x-face)
- ('color-tty
+ (color-tty
(gamegrid-make-color-tty-face color))
- ('mono-tty
+ (mono-tty
(unless gamegrid-mono-tty-face
(setq gamegrid-mono-tty-face (gamegrid-make-mono-tty-face)))
gamegrid-mono-tty-face))))
@@ -486,12 +485,11 @@ FILE is created there."
(defvar gamegrid-shared-game-dir)
(defun gamegrid-add-score-with-update-game-score (file score)
- (let* ((result nil) ;; What is this good for? -- os
- (gamegrid-shared-game-dir
- (not (zerop (logand (file-modes
- (expand-file-name "update-game-score"
- exec-directory))
- #o4000)))))
+ (let ((gamegrid-shared-game-dir
+ (not (zerop (logand (file-modes
+ (expand-file-name "update-game-score"
+ exec-directory))
+ #o4000)))))
(cond ((file-name-absolute-p file)
(gamegrid-add-score-insecure file score))
((and gamegrid-shared-game-dir
@@ -597,5 +595,4 @@ FILE is created there."
(provide 'gamegrid)
-;; arch-tag: a96c2ff4-1c12-427e-bd3d-faeaf174cd46
;;; gamegrid.el ends here
diff --git a/lisp/play/gametree.el b/lisp/play/gametree.el
index 329e936f5bf..4d514d2d0aa 100644
--- a/lisp/play/gametree.el
+++ b/lisp/play/gametree.el
@@ -1,7 +1,6 @@
;;; gametree.el --- manage game analysis trees in Emacs
-;; Copyright (C) 1997, 1999, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 1999, 2001-2011 Free Software Foundation, Inc.
;; Author: Ian T Zimmerman <itz@rahul.net>
;; Created: Wed Dec 10 07:41:46 PST 1997
@@ -201,7 +200,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))
@@ -259,23 +258,20 @@ This value is simply the outline heading level of the current line."
(defun gametree-children-shown-p ()
(save-excursion
- (condition-case nil
+ (ignore-errors
(let ((depth (gametree-current-branch-depth)))
(outline-next-visible-heading 1)
- (< depth (gametree-current-branch-depth)))
- (error nil))))
+ (< depth (gametree-current-branch-depth))))))
-(defun gametree-current-layout (depth &optional top-level)
+(defun gametree-current-layout (depth &optional from-top-level)
(let ((layout nil) (first-time t))
(while (save-excursion
- (condition-case nil
- (progn
- (or (and first-time top-level
- (bolp) (looking-at outline-regexp))
- (setq first-time nil)
- (outline-next-visible-heading 1))
- (< depth (gametree-current-branch-depth)))
- (error nil)))
+ (ignore-errors
+ (or (and first-time from-top-level
+ (bolp) (looking-at outline-regexp))
+ (setq first-time nil)
+ (outline-next-visible-heading 1))
+ (< depth (gametree-current-branch-depth))))
(if (not first-time)
(outline-next-visible-heading 1))
(setq first-time nil)
@@ -298,18 +294,16 @@ This value is simply the outline heading level of the current line."
(goto-char (point-min))
(setq gametree-local-layout (gametree-current-layout 0 t))))
-(defun gametree-apply-layout (layout depth &optional top-level)
+(defun gametree-apply-layout (layout depth &optional from-top-level)
(let ((first-time t))
(while (and layout
(save-excursion
- (condition-case nil
- (progn
- (or (and first-time top-level
- (bolp) (looking-at outline-regexp))
- (setq first-time nil)
- (outline-next-visible-heading 1))
- (< depth (gametree-current-branch-depth)))
- (error nil))))
+ (ignore-errors
+ (or (and first-time from-top-level
+ (bolp) (looking-at outline-regexp))
+ (setq first-time nil)
+ (outline-next-visible-heading 1))
+ (< depth (gametree-current-branch-depth)))))
(if (not first-time)
(outline-next-visible-heading 1))
(setq first-time nil)
@@ -376,9 +370,7 @@ Subnodes which have been manually scored are honored."
(while (not done) ;handle subheadings
(setq running (funcall minmax running
(gametree-compute-reduced-score)))
- (setq done (condition-case nil
- (outline-forward-same-level 1)
- (error nil)))))
+ (setq done (ignore-errors (outline-forward-same-level 1)))))
running)))))
;;;; Commands
@@ -566,6 +558,20 @@ buffer, it is replaced by the new value. See the documentation for
(gametree-hack-file-layout))
nil)
+;;;; Key bindings
+(defvar gametree-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\C-c\C-j" 'gametree-break-line-here)
+ (define-key map "\C-c\C-v" 'gametree-insert-new-leaf)
+ (define-key map "\C-c\C-m" 'gametree-merge-line)
+ (define-key map "\C-c\C-r " 'gametree-layout-to-register)
+ (define-key map "\C-c\C-r/" 'gametree-layout-to-register)
+ (define-key map "\C-c\C-rj" 'gametree-apply-register-layout)
+ (define-key map "\C-c\C-y" 'gametree-save-and-hack-layout)
+ (define-key map "\C-c;" 'gametree-insert-score)
+ (define-key map "\C-c^" 'gametree-compute-and-insert-score)
+ map))
+
(define-derived-mode gametree-mode outline-mode "GameTree"
"Major mode for managing game analysis trees.
Useful to postal and email chess (and, it is hoped, also checkers, go,
@@ -576,18 +582,6 @@ shogi, etc.) players, it is a slightly modified version of Outline mode.
(make-local-variable 'write-contents-hooks)
(add-hook 'write-contents-hooks 'gametree-save-and-hack-layout))
-;;;; Key bindings
-
-(define-key gametree-mode-map "\C-c\C-j" 'gametree-break-line-here)
-(define-key gametree-mode-map "\C-c\C-v" 'gametree-insert-new-leaf)
-(define-key gametree-mode-map "\C-c\C-m" 'gametree-merge-line)
-(define-key gametree-mode-map "\C-c\C-r " 'gametree-layout-to-register)
-(define-key gametree-mode-map "\C-c\C-r/" 'gametree-layout-to-register)
-(define-key gametree-mode-map "\C-c\C-rj" 'gametree-apply-register-layout)
-(define-key gametree-mode-map "\C-c\C-y" 'gametree-save-and-hack-layout)
-(define-key gametree-mode-map "\C-c;" 'gametree-insert-score)
-(define-key gametree-mode-map "\C-c^" 'gametree-compute-and-insert-score)
-
;;;; Goodies for mousing users
(and (fboundp 'track-mouse)
(defun gametree-mouse-break-line-here (event)
@@ -617,5 +611,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 5f9f9416cc0..33fcf451ebb 100644
--- a/lisp/play/gomoku.el
+++ b/lisp/play/gomoku.el
@@ -1,7 +1,6 @@
;;; gomoku.el --- Gomoku game between you and Emacs
-;; Copyright (C) 1988, 1994, 1996, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1988, 1994, 1996, 2001-2011 Free Software Foundation, Inc.
;; Author: Philippe Schnoebelen <phs@lsv.ens-cachan.fr>
;; Maintainer: FSF
@@ -102,59 +101,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 +182,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 +277,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 +298,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 +319,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 +333,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 +393,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 +420,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 +871,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 +928,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."
@@ -1055,11 +1043,11 @@ If the game is finished, this command requests for another game."
(insert-char ?\n gomoku-square-height))
(or (eq (char-after 1) ?.)
(put-text-property 1 2 'point-entered
- (lambda (x y) (if (bobp) (forward-char)))))
+ (lambda (_x _y) (if (bobp) (forward-char)))))
(or intangible
(put-text-property point (point) 'intangible 2))
(put-text-property point (point) 'point-entered
- (lambda (x y) (if (eobp) (backward-char))))
+ (lambda (_x _y) (if (eobp) (backward-char))))
(put-text-property (point-min) (point) 'category 'gomoku-mode))
(gomoku-goto-xy (/ (1+ n) 2) (/ (1+ m) 2)) ; center of the board
(sit-for 0)) ; Display NOW
diff --git a/lisp/play/handwrite.el b/lisp/play/handwrite.el
index 21e3d912fe5..70c10da5405 100644
--- a/lisp/play/handwrite.el
+++ b/lisp/play/handwrite.el
@@ -1,7 +1,6 @@
;;; handwrite.el --- turns your emacs buffer into a handwritten document -*- coding: iso-latin-1; -*-
-;; Copyright (C) 1996, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 2001-2011 Free Software Foundation, Inc.
;; Author: Danny Roozendaal (was: <danny@tvs.kun.nl>)
;; Created: October 21 1996
@@ -68,8 +67,10 @@
;;; Code:
+;; From ps-print.el
(defvar ps-printer-name)
(defvar ps-lpr-command)
+(defvar ps-lpr-switches)
;; Variables
@@ -81,8 +82,24 @@
(defvar handwrite-psindex 0
"The index of the PostScript buffer.")
-(defvar menu-bar-handwrite-map (make-sparse-keymap "Handwrite functions."))
-(fset 'menu-bar-handwrite-map (symbol-value 'menu-bar-handwrite-map))
+(defvar menu-bar-handwrite-map
+ (let ((map (make-sparse-keymap "Handwrite functions.")))
+ (define-key map [numbering]
+ '(menu-item "Page numbering" handwrite-set-pagenumber
+ :button (:toggle . handwrite-pagenumbering)))
+ (define-key map [handwrite-separator2] '("----" . nil))
+ (define-key map [10pt] '(menu-item "10 pt" handwrite-10pt
+ :button (:radio . (eq handwrite-fontsize 10))))
+ (define-key map [11pt] '(menu-item "11 pt" handwrite-11pt
+ :button (:radio . (eq handwrite-fontsize 11))))
+ (define-key map [12pt] '(menu-item "12 pt" handwrite-12pt
+ :button (:radio . (eq handwrite-fontsize 12))))
+ (define-key map [13pt] '(menu-item "13 pt" handwrite-13pt
+ :button (:radio . (eq handwrite-fontsize 13))))
+ (define-key map [handwrite-separator1] '("----" . nil))
+ (define-key map [handwrite] '("Write by hand" . handwrite))
+ map))
+(fset 'menu-bar-handwrite-map menu-bar-handwrite-map)
;; User definable variables
@@ -136,14 +153,13 @@
The functions `handwrite-10pt', `handwrite-11pt', `handwrite-12pt'
and `handwrite-13pt' set up for various sizes of output.
-Variables: handwrite-linespace (default 12)
- handwrite-fontsize (default 11)
- handwrite-numlines (default 60)
- handwrite-pagenumbering (default nil)"
+Variables: `handwrite-linespace' (default 12)
+ `handwrite-fontsize' (default 11)
+ `handwrite-numlines' (default 60)
+ `handwrite-pagenumbering' (default nil)"
(interactive)
(let
- ((pmin) ; thanks, Havard
- (lastp)
+ (;(pmin) ; thanks, Havard
(cur-buf (current-buffer))
(tpoint (point))
(ps-ypos 63)
@@ -259,7 +275,8 @@ Variables: handwrite-linespace (default 12)
"Toggle the value of `handwrite-pagenumbering'."
(interactive)
(if handwrite-pagenumbering
- (handwrite-set-pagenumber-off)(handwrite-set-pagenumber-on)))
+ (handwrite-set-pagenumber-off)
+ (handwrite-set-pagenumber-on)))
(defun handwrite-10pt ()
"Specify 10-point output for `handwrite.
@@ -269,14 +286,6 @@ values for `handwrite-linespace' and `handwrite-numlines'."
(setq handwrite-fontsize 10)
(setq handwrite-linespace 11)
(setq handwrite-numlines handwrite-10pt-numlines)
- (define-key menu-bar-handwrite-map [10pt]
- '("10 pt *" . handwrite-10pt))
- (define-key menu-bar-handwrite-map [11pt]
- '("11 pt" . handwrite-11pt))
- (define-key menu-bar-handwrite-map [12pt]
- '("12 pt" . handwrite-12pt))
- (define-key menu-bar-handwrite-map [13pt]
- '("13 pt" . handwrite-13pt))
(message "Handwrite output size set to 10 points"))
@@ -288,14 +297,6 @@ values for `handwrite-linespace' and `handwrite-numlines'."
(setq handwrite-fontsize 11)
(setq handwrite-linespace 12)
(setq handwrite-numlines handwrite-11pt-numlines)
- (define-key menu-bar-handwrite-map [10pt]
- '("10 pt" . handwrite-10pt))
- (define-key menu-bar-handwrite-map [11pt]
- '("11 pt *" . handwrite-11pt))
- (define-key menu-bar-handwrite-map [12pt]
- '("12 pt" . handwrite-12pt))
- (define-key menu-bar-handwrite-map [13pt]
- '("13 pt" . handwrite-13pt))
(message "Handwrite output size set to 11 points"))
(defun handwrite-12pt ()
@@ -306,14 +307,6 @@ values for `handwrite-linespace' and `handwrite-numlines'."
(setq handwrite-fontsize 12)
(setq handwrite-linespace 13)
(setq handwrite-numlines handwrite-12pt-numlines)
- (define-key menu-bar-handwrite-map [10pt]
- '("10 pt" . handwrite-10pt))
- (define-key menu-bar-handwrite-map [11pt]
- '("11 pt" . handwrite-11pt))
- (define-key menu-bar-handwrite-map [12pt]
- '("12 pt *" . handwrite-12pt))
- (define-key menu-bar-handwrite-map [13pt]
- '("13 pt" . handwrite-13pt))
(message "Handwrite output size set to 12 points"))
(defun handwrite-13pt ()
@@ -324,14 +317,6 @@ values for `handwrite-linespace' and `handwrite-numlines'."
(setq handwrite-fontsize 13)
(setq handwrite-linespace 14)
(setq handwrite-numlines handwrite-13pt-numlines)
- (define-key menu-bar-handwrite-map [10pt]
- '("10 pt" . handwrite-10pt))
- (define-key menu-bar-handwrite-map [11pt]
- '("11 pt" . handwrite-11pt))
- (define-key menu-bar-handwrite-map [12pt]
- '("12 pt" . handwrite-12pt))
- (define-key menu-bar-handwrite-map [13pt]
- '("13 pt *" . handwrite-13pt))
(message "Handwrite output size set to 13 points"))
@@ -1264,64 +1249,25 @@ end
;;Sets page numbering off
(defun handwrite-set-pagenumber-off ()
(setq handwrite-pagenumbering nil)
- (define-key menu-bar-handwrite-map
- [numbering]
- '("Page numbering Off" . handwrite-set-pagenumber))
(message "page numbering off"))
;;Sets page numbering on
(defun handwrite-set-pagenumber-on ()
(setq handwrite-pagenumbering t)
- (define-key menu-bar-handwrite-map
- [numbering]
- '("Page numbering On" . handwrite-set-pagenumber))
(message "page numbering on" ))
;; Key bindings
-
-;;; I'd rather not fill up the menu bar menus with
-;;; lots of random miscellaneous features. -- rms.
+;; I'd rather not fill up the menu bar menus with
+;; lots of random miscellaneous features. -- rms.
;;;(define-key-after
;;; (lookup-key global-map [menu-bar edit])
;;; [handwrite]
;;; '("Write by hand" . menu-bar-handwrite-map)
;;; 'spell)
-(define-key menu-bar-handwrite-map [numbering]
- '("Page numbering Off" . handwrite-set-pagenumber))
-
-(define-key menu-bar-handwrite-map [10pt]
- '("10 pt" . handwrite-10pt))
-
-(define-key menu-bar-handwrite-map [11pt]
- '("11 pt *" . handwrite-11pt))
-
-(define-key menu-bar-handwrite-map [12pt]
- '("12 pt" . handwrite-12pt))
-
-(define-key menu-bar-handwrite-map [13pt]
- '("13 pt" . handwrite-13pt))
-
-(define-key menu-bar-handwrite-map [handwrite]
- '("Write by hand" . handwrite))
-
-(define-key-after
- (lookup-key menu-bar-handwrite-map [ ])
- [handwrite-separator1]
- '("----" . nil)
- 'handwrite)
-
-(define-key-after
- (lookup-key menu-bar-handwrite-map [ ])
- [handwrite-separator2]
- '("----" . nil)
- '10pt)
-
-
(provide 'handwrite)
-;; arch-tag: f2285ae9-e41b-4c96-8343-87dce41e44b7
;;; handwrite.el ends here
diff --git a/lisp/play/hanoi.el b/lisp/play/hanoi.el
index 5185b810918..ac78a86757c 100644
--- a/lisp/play/hanoi.el
+++ b/lisp/play/hanoi.el
@@ -355,7 +355,6 @@ BITS must be of length nrings. Start at START-TIME."
(fly-steps (abs (/ (- (cdr to) (cdr from)) fly-step)))
(directed-fly-step (/ (- (cdr to) (cdr from)) fly-steps))
(baseward-steps (/ (- (car to) (cdr to)) baseward-step))
- (total-steps (+ flyward-steps fly-steps baseward-steps))
;; A step is a character cell. A tick is a time-unit. To
;; make horizontal and vertical motion appear roughly the
;; same speed, we allow one tick per horizontal step and two
@@ -447,5 +446,4 @@ BITS must be of length nrings. Start at START-TIME."
(provide 'hanoi)
-;; arch-tag: 7a901659-4346-495c-8883-14cbf540610c
;;; hanoi.el ends here
diff --git a/lisp/play/landmark.el b/lisp/play/landmark.el
index 5aa0a442b92..f0e6670fe58 100644
--- a/lisp/play/landmark.el
+++ b/lisp/play/landmark.el
@@ -1,7 +1,6 @@
;;; landmark.el --- neural-network robot that learns landmarks
-;; Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1997, 2000-2011 Free Software Foundation, Inc.
;; Author: Terrence Brannon (was: <brannon@rana.usc.edu>)
;; Created: December 16, 1996 - first release to usenet
@@ -10,7 +9,7 @@
;;;_* Usage
;;; Just type
;;; M-x eval-buffer
-;;; M-x lm-test-run
+;;; M-x landmark-test-run
;; This file is part of GNU Emacs.
@@ -30,31 +29,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.
+;; Landmark 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))
@@ -63,9 +62,9 @@
;;; Code:
-(defgroup lm nil
+(defgroup landmark nil
"Neural-network robot that learns landmarks."
- :prefix "lm-"
+ :prefix "landmark-"
:group 'games)
;;;_ + THE BOARD.
@@ -75,199 +74,199 @@
;; containing padding squares (coded with -1). These squares allow us to
;; detect when we are trying to move out of the board. We denote a square by
;; its (X,Y) coords, or by the INDEX corresponding to them in the vector. The
-;; leftmost topmost square has coords (1,1) and index lm-board-width + 2.
+;; leftmost topmost square has coords (1,1) and index landmark-board-width + 2.
;; Similarly, vectors between squares may be given by two DX, DY coords or by
;; one DEPL (the difference between indexes).
-(defvar lm-board-width nil
- "Number of columns on the Lm board.")
-(defvar lm-board-height nil
- "Number of lines on the Lm board.")
+(defvar landmark-board-width nil
+ "Number of columns on the Landmark board.")
+(defvar landmark-board-height nil
+ "Number of lines on the Landmark board.")
-(defvar lm-board nil
- "Vector recording the actual state of the Lm board.")
+(defvar landmark-board nil
+ "Vector recording the actual state of the Landmark board.")
-(defvar lm-vector-length nil
- "Length of lm-board vector.")
+(defvar landmark-vector-length nil
+ "Length of landmark-board vector.")
-(defvar lm-draw-limit nil
+(defvar landmark-draw-limit nil
;; This is usually set to 70% of the number of squares.
"After how many moves will Emacs offer a draw?")
-(defvar lm-cx 0
+(defvar landmark-cx 0
"This is the x coordinate of the center of the board.")
-(defvar lm-cy 0
+(defvar landmark-cy 0
"This is the y coordinate of the center of the board.")
-(defvar lm-m 0
+(defvar landmark-m 0
"This is the x dimension of the playing board.")
-(defvar lm-n 0
+(defvar landmark-n 0
"This is the y dimension of the playing board.")
-(defun lm-xy-to-index (x y)
+(defun landmark-xy-to-index (x y)
"Translate X, Y cartesian coords into the corresponding board index."
- (+ (* y lm-board-width) x y))
+ (+ (* y landmark-board-width) x y))
-(defun lm-index-to-x (index)
+(defun landmark-index-to-x (index)
"Return corresponding x-coord of board INDEX."
- (% index (1+ lm-board-width)))
+ (% index (1+ landmark-board-width)))
-(defun lm-index-to-y (index)
+(defun landmark-index-to-y (index)
"Return corresponding y-coord of board INDEX."
- (/ index (1+ lm-board-width)))
+ (/ index (1+ landmark-board-width)))
-(defun lm-init-board ()
- "Create the lm-board vector and fill it with initial values."
- (setq lm-board (make-vector lm-vector-length 0))
+(defun landmark-init-board ()
+ "Create the landmark-board vector and fill it with initial values."
+ (setq landmark-board (make-vector landmark-vector-length 0))
;; Every square is 0 (i.e. empty) except padding squares:
- (let ((i 0) (ii (1- lm-vector-length)))
- (while (<= i lm-board-width) ; The squares in [0..width] and in
- (aset lm-board i -1) ; [length - width - 1..length - 1]
- (aset lm-board ii -1) ; are padding squares.
+ (let ((i 0) (ii (1- landmark-vector-length)))
+ (while (<= i landmark-board-width) ; The squares in [0..width] and in
+ (aset landmark-board i -1) ; [length - width - 1..length - 1]
+ (aset landmark-board ii -1) ; are padding squares.
(setq i (1+ i)
ii (1- ii))))
(let ((i 0))
- (while (< i lm-vector-length)
- (aset lm-board i -1) ; and also all k*(width+1)
- (setq i (+ i lm-board-width 1)))))
+ (while (< i landmark-vector-length)
+ (aset landmark-board i -1) ; and also all k*(width+1)
+ (setq i (+ i landmark-board-width 1)))))
;;;_ + DISPLAYING THE BOARD.
;; You may change these values if you have a small screen or if the squares
;; look rectangular, but spacings SHOULD be at least 2 (MUST BE at least 1).
-(defconst lm-square-width 2
- "*Horizontal spacing between squares on the Lm board.")
+(defconst landmark-square-width 2
+ "*Horizontal spacing between squares on the Landmark board.")
-(defconst lm-square-height 1
- "*Vertical spacing between squares on the Lm board.")
+(defconst landmark-square-height 1
+ "*Vertical spacing between squares on the Landmark board.")
-(defconst lm-x-offset 3
- "*Number of columns between the Lm board and the side of the window.")
+(defconst landmark-x-offset 3
+ "*Number of columns between the Landmark board and the side of the window.")
-(defconst lm-y-offset 1
- "*Number of lines between the Lm board and the top of the window.")
+(defconst landmark-y-offset 1
+ "*Number of lines between the Landmark board and the top of the window.")
-;;;_ + LM MODE AND KEYMAP.
+;;;_ + LANDMARK MODE AND KEYMAP.
-(defcustom lm-mode-hook nil
- "If non-nil, its value is called on entry to Lm mode."
+(defcustom landmark-mode-hook nil
+ "If non-nil, its value is called on entry to Landmark mode."
:type 'hook
- :group 'lm)
-
-(defvar lm-mode-map nil
- "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 ()
+ :group 'landmark)
+
+(defvar landmark-mode-map
+ (let ((map (make-sparse-keymap)))
+ ;; Key bindings for cursor motion.
+ (define-key map "y" 'landmark-move-nw) ; y
+ (define-key map "u" 'landmark-move-ne) ; u
+ (define-key map "b" 'landmark-move-sw) ; b
+ (define-key map "n" 'landmark-move-se) ; n
+ (define-key map "h" 'backward-char) ; h
+ (define-key map "l" 'forward-char) ; l
+ (define-key map "j" 'landmark-move-down) ; j
+ (define-key map "k" 'landmark-move-up) ; k
+
+ (define-key map [kp-7] 'landmark-move-nw)
+ (define-key map [kp-9] 'landmark-move-ne)
+ (define-key map [kp-1] 'landmark-move-sw)
+ (define-key map [kp-3] 'landmark-move-se)
+ (define-key map [kp-4] 'backward-char)
+ (define-key map [kp-6] 'forward-char)
+ (define-key map [kp-2] 'landmark-move-down)
+ (define-key map [kp-8] 'landmark-move-up)
+
+ (define-key map "\C-n" 'landmark-move-down) ; C-n
+ (define-key map "\C-p" 'landmark-move-up) ; C-p
+
+ ;; Key bindings for entering Human moves.
+ (define-key map "X" 'landmark-human-plays) ; X
+ (define-key map "x" 'landmark-human-plays) ; x
+
+ (define-key map " " 'landmark-start-robot) ; SPC
+ (define-key map [down-mouse-1] 'landmark-start-robot)
+ (define-key map [drag-mouse-1] 'landmark-click)
+ (define-key map [mouse-1] 'landmark-click)
+ (define-key map [down-mouse-2] 'landmark-click)
+ (define-key map [mouse-2] 'landmark-mouse-play)
+ (define-key map [drag-mouse-2] 'landmark-mouse-play)
+
+ (define-key map [remap previous-line] 'landmark-move-up)
+ (define-key map [remap next-line] 'landmark-move-down)
+ (define-key map [remap beginning-of-line] 'landmark-beginning-of-line)
+ (define-key map [remap end-of-line] 'landmark-end-of-line)
+ (define-key map [remap undo] 'landmark-human-takes-back)
+ (define-key map [remap advertised-undo] 'landmark-human-takes-back)
+ map)
+ "Local keymap to use in Landmark mode.")
+
+
+
+(defvar landmark-emacs-won ()
"*For making font-lock use the winner's face for the line.")
-(defface lm-font-lock-face-O '((((class color)) :foreground "red")
+(defface landmark-font-lock-face-O '((((class color)) :foreground "red")
(t :weight bold))
"Face to use for Emacs' O."
:version "22.1"
- :group 'lm)
+ :group 'landmark)
-(defface lm-font-lock-face-X '((((class color)) :foreground "green")
+(defface landmark-font-lock-face-X '((((class color)) :foreground "green")
(t :weight bold))
"Face to use for your X."
:version "22.1"
- :group 'lm)
-
-(defvar lm-font-lock-keywords
- '(("O" . 'lm-font-lock-face-O)
- ("X" . 'lm-font-lock-face-X)
- ("[-|/\\]" 0 (if lm-emacs-won
- 'lm-font-lock-face-O
- 'lm-font-lock-face-X)))
- "*Font lock rules for Lm.")
-
-(put 'lm-mode 'front-sticky
- (put 'lm-mode 'rear-nonsticky '(intangible)))
-(put 'lm-mode 'intangible 1)
+ :group 'landmark)
+
+(defvar landmark-font-lock-keywords
+ '(("O" . 'landmark-font-lock-face-O)
+ ("X" . 'landmark-font-lock-face-X)
+ ("[-|/\\]" 0 (if landmark-emacs-won
+ 'landmark-font-lock-face-O
+ 'landmark-font-lock-face-X)))
+ "*Font lock rules for Landmark.")
+
+(put 'landmark-mode 'front-sticky
+ (put 'landmark-mode 'rear-nonsticky '(intangible)))
+(put 'landmark-mode 'intangible 1)
;; This one is for when they set view-read-only to t: Landmark cannot
;; allow View Mode to be activated in its buffer.
-(put 'lm-mode 'mode-class 'special)
+(put 'landmark-mode 'mode-class 'special)
-(defun lm-mode ()
- "Major mode for playing Lm against Emacs.
+(defun landmark-mode ()
+ "Major mode for playing Landmark 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.
-You play by moving the cursor over the square you choose and hitting \\[lm-human-plays].
+You play by moving the cursor over the square you choose and hitting \\[landmark-human-plays].
Other useful commands:
-\\{lm-mode-map}
-Entry to this mode calls the value of `lm-mode-hook' if that value
+\\{landmark-mode-map}
+Entry to this mode calls the value of `landmark-mode-hook' if that value
is non-nil. One interesting value is `turn-on-font-lock'."
(interactive)
(kill-all-local-variables)
- (setq major-mode 'lm-mode
- mode-name "Lm")
- (lm-display-statistics)
- (use-local-map lm-mode-map)
+ (setq major-mode 'landmark-mode
+ mode-name "Landmark")
+ (landmark-display-statistics)
+ (use-local-map landmark-mode-map)
(make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults '(lm-font-lock-keywords t)
+ (setq font-lock-defaults '(landmark-font-lock-keywords t)
buffer-read-only t)
- (run-mode-hooks 'lm-mode-hook))
+ (run-mode-hooks 'landmark-mode-hook))
;;;_ + THE SCORE TABLE.
;; Every (free) square has a score associated to it, recorded in the
-;; LM-SCORE-TABLE vector. The program always plays in the square having
+;; LANDMARK-SCORE-TABLE vector. The program always plays in the square having
;; the highest score.
-(defvar lm-score-table nil
+(defvar landmark-score-table nil
"Vector recording the actual score of the free squares.")
@@ -282,7 +281,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.
@@ -294,7 +293,7 @@ is non-nil. One interesting value is `turn-on-font-lock'."
;; the qtuples.
;;
;; This algorithm is rather simple but anyway it gives a not so dumb level of
-;; play. It easily extends to "n-dimensional Lm", where a win should not
+;; play. It easily extends to "n-dimensional Landmark", where a win should not
;; be obtained with as few as 5 contiguous marks: 6 or 7 (depending on n !)
;; should be preferred.
@@ -303,47 +302,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-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)
+(defconst landmark-nil-score 7 "Score of an empty qtuple.")
+
+(defconst landmark-score-trans-table
+ (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 landmark-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,16 +351,18 @@ 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 landmark-winning-threshold
+ (aref landmark-score-trans-table (+ 6 6 6 6)) ;; OOOOscore
"Threshold score beyond which an Emacs move is winning.")
-(defconst lm-loosing-threshold XXXXscore
+(defconst landmark-losing-threshold
+ (aref landmark-score-trans-table (+ 1 1 1 1)) ;; XXXXscore
"Threshold score beyond which a human move is winning.")
-(defun lm-strongest-square ()
+(defun landmark-strongest-square ()
"Compute index of free square with highest score, or nil if none."
;; We just have to loop other all squares. However there are two problems:
;; 1/ The SCORE-TABLE only gives correct scores to free squares. To speed
@@ -370,23 +371,23 @@ is non-nil. One interesting value is `turn-on-font-lock'."
;; 2/ We want to choose randomly between equally good moves.
(let ((score-max 0)
(count 0) ; Number of equally good moves
- (square (lm-xy-to-index 1 1)) ; First square
- (end (lm-xy-to-index lm-board-width lm-board-height))
+ (square (landmark-xy-to-index 1 1)) ; First square
+ (end (landmark-xy-to-index landmark-board-width landmark-board-height))
best-square score)
(while (<= square end)
(cond
;; If score is lower (i.e. most of the time), skip to next:
- ((< (aref lm-score-table square) score-max))
+ ((< (aref landmark-score-table square) score-max))
;; If score is better, beware of non free squares:
- ((> (setq score (aref lm-score-table square)) score-max)
- (if (zerop (aref lm-board square)) ; is it free ?
+ ((> (setq score (aref landmark-score-table square)) score-max)
+ (if (zerop (aref landmark-board square)) ; is it free ?
(setq count 1 ; yes: take it !
best-square square
score-max score)
- (aset lm-score-table square -1))) ; no: kill it !
+ (aset landmark-score-table square -1))) ; no: kill it !
;; If score is equally good, choose randomly. But first check freeness:
- ((not (zerop (aref lm-board square)))
- (aset lm-score-table square -1))
+ ((not (zerop (aref landmark-board square)))
+ (aset landmark-score-table square -1))
((zerop (random (setq count (1+ count))))
(setq best-square square
score-max score)))
@@ -405,28 +406,28 @@ is non-nil. One interesting value is `turn-on-font-lock'."
;; Also, as it is likely that successive games will be played on a board with
;; same size, it is a good idea to save the initial SCORE-TABLE configuration.
-(defvar lm-saved-score-table nil
+(defvar landmark-saved-score-table nil
"Recorded initial value of previous score table.")
-(defvar lm-saved-board-width nil
+(defvar landmark-saved-board-width nil
"Recorded value of previous board width.")
-(defvar lm-saved-board-height nil
+(defvar landmark-saved-board-height nil
"Recorded value of previous board height.")
-(defun lm-init-score-table ()
+(defun landmark-init-score-table ()
"Create the score table vector and fill it with initial values."
- (if (and lm-saved-score-table ; Has it been stored last time ?
- (= lm-board-width lm-saved-board-width)
- (= lm-board-height lm-saved-board-height))
- (setq lm-score-table (copy-sequence lm-saved-score-table))
+ (if (and landmark-saved-score-table ; Has it been stored last time ?
+ (= landmark-board-width landmark-saved-board-width)
+ (= landmark-board-height landmark-saved-board-height))
+ (setq landmark-score-table (copy-sequence landmark-saved-score-table))
;; No, compute it:
- (setq lm-score-table
- (make-vector lm-vector-length (* 20 nil-score)))
+ (setq landmark-score-table
+ (make-vector landmark-vector-length (* 20 landmark-nil-score)))
(let (i j maxi maxj maxi2 maxj2)
- (setq maxi (/ (1+ lm-board-width) 2)
- maxj (/ (1+ lm-board-height) 2)
+ (setq maxi (/ (1+ landmark-board-width) 2)
+ maxj (/ (1+ landmark-board-height) 2)
maxi2 (min 4 maxi)
maxj2 (min 4 maxj))
;; We took symmetry into account and could use it more if the board
@@ -438,43 +439,43 @@ is non-nil. One interesting value is `turn-on-font-lock'."
(while (<= i maxi2)
(setq j 1)
(while (<= j maxj)
- (lm-init-square-score i j)
+ (landmark-init-square-score i j)
(setq j (1+ j)))
(setq i (1+ i)))
(while (<= i maxi)
(setq j 1)
(while (<= j maxj2)
- (lm-init-square-score i j)
+ (landmark-init-square-score i j)
(setq j (1+ j)))
(setq i (1+ i))))
- (setq lm-saved-score-table (copy-sequence lm-score-table)
- lm-saved-board-width lm-board-width
- lm-saved-board-height lm-board-height)))
+ (setq landmark-saved-score-table (copy-sequence landmark-score-table)
+ landmark-saved-board-width landmark-board-width
+ landmark-saved-board-height landmark-board-height)))
-(defun lm-nb-qtuples (i j)
+(defun landmark-nb-qtuples (i j)
"Return the number of qtuples containing square I,J."
;; This function is complicated because we have to deal
;; with ugly cases like 3 by 6 boards, but it works.
;; If you have a simpler (and correct) solution, send it to me. Thanks !
(let ((left (min 4 (1- i)))
- (right (min 4 (- lm-board-width i)))
+ (right (min 4 (- landmark-board-width i)))
(up (min 4 (1- j)))
- (down (min 4 (- lm-board-height j))))
+ (down (min 4 (- landmark-board-height j))))
(+ -12
(min (max (+ left right) 3) 8)
(min (max (+ up down) 3) 8)
(min (max (+ (min left up) (min right down)) 3) 8)
(min (max (+ (min right up) (min left down)) 3) 8))))
-(defun lm-init-square-score (i j)
+(defun landmark-init-square-score (i j)
"Give initial score to square I,J and to its mirror images."
- (let ((ii (1+ (- lm-board-width i)))
- (jj (1+ (- lm-board-height j)))
- (sc (* (lm-nb-qtuples i j) (aref lm-score-trans-table 0))))
- (aset lm-score-table (lm-xy-to-index i j) sc)
- (aset lm-score-table (lm-xy-to-index ii j) sc)
- (aset lm-score-table (lm-xy-to-index i jj) sc)
- (aset lm-score-table (lm-xy-to-index ii jj) sc)))
+ (let ((ii (1+ (- landmark-board-width i)))
+ (jj (1+ (- landmark-board-height j)))
+ (sc (* (landmark-nb-qtuples i j) (aref landmark-score-trans-table 0))))
+ (aset landmark-score-table (landmark-xy-to-index i j) sc)
+ (aset landmark-score-table (landmark-xy-to-index ii j) sc)
+ (aset landmark-score-table (landmark-xy-to-index i jj) sc)
+ (aset landmark-score-table (landmark-xy-to-index ii jj) sc)))
;;;_ - MAINTAINING THE SCORE TABLE.
@@ -484,7 +485,7 @@ is non-nil. One interesting value is `turn-on-font-lock'."
;; SCORE-TABLE after each move. Updating needs not modify more than 36
;; squares: it is done in constant time.
-(defun lm-update-score-table (square dval)
+(defun landmark-update-score-table (square dval)
"Update score table after SQUARE received a DVAL increment."
;; The board has already been updated when this function is called.
;; Updating scores is done by looking for qtuples boundaries in all four
@@ -492,25 +493,25 @@ is non-nil. One interesting value is `turn-on-font-lock'."
;; Finally all squares received the right increment, and then are up to
;; date, except possibly for SQUARE itself if we are taking a move back for
;; its score had been set to -1 at the time.
- (let* ((x (lm-index-to-x square))
- (y (lm-index-to-y square))
+ (let* ((x (landmark-index-to-x square))
+ (y (landmark-index-to-y square))
(imin (max -4 (- 1 x)))
(jmin (max -4 (- 1 y)))
- (imax (min 0 (- lm-board-width x 4)))
- (jmax (min 0 (- lm-board-height y 4))))
- (lm-update-score-in-direction imin imax
+ (imax (min 0 (- landmark-board-width x 4)))
+ (jmax (min 0 (- landmark-board-height y 4))))
+ (landmark-update-score-in-direction imin imax
square 1 0 dval)
- (lm-update-score-in-direction jmin jmax
+ (landmark-update-score-in-direction jmin jmax
square 0 1 dval)
- (lm-update-score-in-direction (max imin jmin) (min imax jmax)
+ (landmark-update-score-in-direction (max imin jmin) (min imax jmax)
square 1 1 dval)
- (lm-update-score-in-direction (max (- 1 y) -4
- (- x lm-board-width))
+ (landmark-update-score-in-direction (max (- 1 y) -4
+ (- x landmark-board-width))
(min 0 (- x 5)
- (- lm-board-height y 4))
+ (- landmark-board-height y 4))
square -1 1 dval)))
-(defun lm-update-score-in-direction (left right square dx dy dval)
+(defun landmark-update-score-in-direction (left right square dx dy dval)
"Update scores for all squares in the qtuples in range.
That is, those between the LEFTth square and the RIGHTth after SQUARE,
along the DX, DY direction, considering that DVAL has been added on SQUARE."
@@ -521,7 +522,7 @@ along the DX, DY direction, considering that DVAL has been added on SQUARE."
((> left right)) ; Quit
(t ; Else ..
(let (depl square0 square1 square2 count delta)
- (setq depl (lm-xy-to-index dx dy)
+ (setq depl (landmark-xy-to-index dx dy)
square0 (+ square (* left depl))
square1 (+ square (* right depl))
square2 (+ square0 (* 4 depl)))
@@ -529,25 +530,25 @@ along the DX, DY direction, considering that DVAL has been added on SQUARE."
(setq square square0
count 0)
(while (<= square square2)
- (setq count (+ count (aref lm-board square))
+ (setq count (+ count (aref landmark-board square))
square (+ square depl)))
(while (<= square0 square1)
;; Update the squares of the qtuple beginning in SQUARE0 and ending
;; in SQUARE2.
- (setq delta (- (aref lm-score-trans-table count)
- (aref lm-score-trans-table (- count dval))))
+ (setq delta (- (aref landmark-score-trans-table count)
+ (aref landmark-score-trans-table (- count dval))))
(cond ((not (zerop delta)) ; or else nothing to update
(setq square square0)
(while (<= square square2)
- (if (zerop (aref lm-board square)) ; only for free squares
- (aset lm-score-table square
- (+ (aref lm-score-table square) delta)))
+ (if (zerop (aref landmark-board square)) ; only for free squares
+ (aset landmark-score-table square
+ (+ (aref landmark-score-table square) delta)))
(setq square (+ square depl)))))
;; Then shift the qtuple one square along DEPL, this only requires
;; modifying SQUARE0 and SQUARE2.
(setq square2 (+ square2 depl)
- count (+ count (- (aref lm-board square0))
- (aref lm-board square2))
+ count (+ count (- (aref landmark-board square0))
+ (aref landmark-board square2))
square0 (+ square0 depl)))))))
;;;
@@ -559,332 +560,328 @@ along the DX, DY direction, considering that DVAL has been added on SQUARE."
;; (anti-updating the score table) and to compute the table from scratch in
;; case of an interruption.
-(defvar lm-game-in-progress nil
+(defvar landmark-game-in-progress nil
"Non-nil if a game is in progress.")
-(defvar lm-game-history nil
+(defvar landmark-game-history nil
"A record of all moves that have been played during current game.")
-(defvar lm-number-of-moves nil
+(defvar landmark-number-of-moves nil
"Number of moves already played in current game.")
-(defvar lm-number-of-human-moves nil
+(defvar landmark-number-of-human-moves nil
"Number of moves already played by human in current game.")
-(defvar lm-emacs-played-first nil
+(defvar landmark-emacs-played-first nil
"Non-nil if Emacs played first.")
-(defvar lm-human-took-back nil
+(defvar landmark-human-took-back nil
"Non-nil if Human took back a move during the game.")
-(defvar lm-human-refused-draw nil
+(defvar landmark-human-refused-draw nil
"Non-nil if Human refused Emacs offer of a draw.")
-(defvar lm-emacs-is-computing nil
+(defvar landmark-emacs-is-computing nil
;; This is used to detect interruptions. Hopefully, it should not be needed.
"Non-nil if Emacs is in the middle of a computation.")
-(defun lm-start-game (n m)
+(defun landmark-start-game (n m)
"Initialize a new game on an N by M board."
- (setq lm-emacs-is-computing t) ; Raise flag
- (setq lm-game-in-progress t)
- (setq lm-board-width n
- lm-board-height m
- lm-vector-length (1+ (* (+ m 2) (1+ n)))
- lm-draw-limit (/ (* 7 n m) 10))
- (setq lm-emacs-won nil
- lm-game-history nil
- lm-number-of-moves 0
- lm-number-of-human-moves 0
- lm-emacs-played-first nil
- lm-human-took-back nil
- lm-human-refused-draw nil)
- (lm-init-display n m) ; Display first: the rest takes time
- (lm-init-score-table) ; INIT-BOARD requires that the score
- (lm-init-board) ; table be already created.
- (setq lm-emacs-is-computing nil))
-
-(defun lm-play-move (square val &optional dont-update-score)
+ (setq landmark-emacs-is-computing t) ; Raise flag
+ (setq landmark-game-in-progress t)
+ (setq landmark-board-width n
+ landmark-board-height m
+ landmark-vector-length (1+ (* (+ m 2) (1+ n)))
+ landmark-draw-limit (/ (* 7 n m) 10))
+ (setq landmark-emacs-won nil
+ landmark-game-history nil
+ landmark-number-of-moves 0
+ landmark-number-of-human-moves 0
+ landmark-emacs-played-first nil
+ landmark-human-took-back nil
+ landmark-human-refused-draw nil)
+ (landmark-init-display n m) ; Display first: the rest takes time
+ (landmark-init-score-table) ; INIT-BOARD requires that the score
+ (landmark-init-board) ; table be already created.
+ (setq landmark-emacs-is-computing nil))
+
+(defun landmark-play-move (square val &optional dont-update-score)
"Go to SQUARE, play VAL and update everything."
- (setq lm-emacs-is-computing t) ; Raise flag
+ (setq landmark-emacs-is-computing t) ; Raise flag
(cond ((= 1 val) ; a Human move
- (setq lm-number-of-human-moves (1+ lm-number-of-human-moves)))
- ((zerop lm-number-of-moves) ; an Emacs move. Is it first ?
- (setq lm-emacs-played-first t)))
- (setq lm-game-history
- (cons (cons square (aref lm-score-table square))
- lm-game-history)
- lm-number-of-moves (1+ lm-number-of-moves))
- (lm-plot-square square val)
- (aset lm-board square val) ; *BEFORE* UPDATE-SCORE !
+ (setq landmark-number-of-human-moves (1+ landmark-number-of-human-moves)))
+ ((zerop landmark-number-of-moves) ; an Emacs move. Is it first ?
+ (setq landmark-emacs-played-first t)))
+ (setq landmark-game-history
+ (cons (cons square (aref landmark-score-table square))
+ landmark-game-history)
+ landmark-number-of-moves (1+ landmark-number-of-moves))
+ (landmark-plot-square square val)
+ (aset landmark-board square val) ; *BEFORE* UPDATE-SCORE !
(if dont-update-score nil
- (lm-update-score-table square val) ; previous val was 0: dval = val
- (aset lm-score-table square -1))
- (setq lm-emacs-is-computing nil))
+ (landmark-update-score-table square val) ; previous val was 0: dval = val
+ (aset landmark-score-table square -1))
+ (setq landmark-emacs-is-computing nil))
-(defun lm-take-back ()
+(defun landmark-take-back ()
"Take back last move and update everything."
- (setq lm-emacs-is-computing t)
- (let* ((last-move (car lm-game-history))
+ (setq landmark-emacs-is-computing t)
+ (let* ((last-move (car landmark-game-history))
(square (car last-move))
- (oldval (aref lm-board square)))
+ (oldval (aref landmark-board square)))
(if (= 1 oldval)
- (setq lm-number-of-human-moves (1- lm-number-of-human-moves)))
- (setq lm-game-history (cdr lm-game-history)
- lm-number-of-moves (1- lm-number-of-moves))
- (lm-plot-square square 0)
- (aset lm-board square 0) ; *BEFORE* UPDATE-SCORE !
- (lm-update-score-table square (- oldval))
- (aset lm-score-table square (cdr last-move)))
- (setq lm-emacs-is-computing nil))
+ (setq landmark-number-of-human-moves (1- landmark-number-of-human-moves)))
+ (setq landmark-game-history (cdr landmark-game-history)
+ landmark-number-of-moves (1- landmark-number-of-moves))
+ (landmark-plot-square square 0)
+ (aset landmark-board square 0) ; *BEFORE* UPDATE-SCORE !
+ (landmark-update-score-table square (- oldval))
+ (aset landmark-score-table square (cdr last-move)))
+ (setq landmark-emacs-is-computing nil))
;;;_ + SESSION CONTROL.
-(defvar lm-number-of-trials 0
+(defvar landmark-number-of-trials 0
"The number of times that landmark has been run.")
-(defvar lm-sum-of-moves 0
+(defvar landmark-sum-of-moves 0
"The total number of moves made in all games.")
-(defvar lm-number-of-emacs-wins 0
+(defvar landmark-number-of-emacs-wins 0
"Number of games Emacs won in this session.")
-(defvar lm-number-of-human-wins 0
+(defvar landmark-number-of-human-wins 0
"Number of games you won in this session.")
-(defvar lm-number-of-draws 0
+(defvar landmark-number-of-draws 0
"Number of games already drawn in this session.")
-(defun lm-terminate-game (result)
+(defun landmark-terminate-game (result)
"Terminate the current game with RESULT."
- (setq lm-number-of-trials (1+ lm-number-of-trials))
- (setq lm-sum-of-moves (+ lm-sum-of-moves lm-number-of-moves))
+ (setq landmark-number-of-trials (1+ landmark-number-of-trials))
+ (setq landmark-sum-of-moves (+ landmark-sum-of-moves landmark-number-of-moves))
(if (eq result 'crash-game)
(message
"Sorry, I have been interrupted and cannot resume that game..."))
- (lm-display-statistics)
+ (landmark-display-statistics)
;;(ding)
- (setq lm-game-in-progress nil))
+ (setq landmark-game-in-progress nil))
-(defun lm-crash-game ()
+(defun landmark-crash-game ()
"What to do when Emacs detects it has been interrupted."
- (setq lm-emacs-is-computing nil)
- (lm-terminate-game 'crash-game)
+ (setq landmark-emacs-is-computing nil)
+ (landmark-terminate-game 'crash-game)
(sit-for 4) ; Let's see the message
- (lm-prompt-for-other-game))
+ (landmark-prompt-for-other-game))
;;;_ + INTERACTIVE COMMANDS.
-(defun lm-emacs-plays ()
+(defun landmark-emacs-plays ()
"Compute Emacs next move and play it."
(interactive)
- (lm-switch-to-window)
+ (landmark-switch-to-window)
(cond
- (lm-emacs-is-computing
- (lm-crash-game))
- ((not lm-game-in-progress)
- (lm-prompt-for-other-game))
+ (landmark-emacs-is-computing
+ (landmark-crash-game))
+ ((not landmark-game-in-progress)
+ (landmark-prompt-for-other-game))
(t
(message "Let me think...")
(let (square score)
- (setq square (lm-strongest-square))
+ (setq square (landmark-strongest-square))
(cond ((null square)
- (lm-terminate-game 'nobody-won))
+ (landmark-terminate-game 'nobody-won))
(t
- (setq score (aref lm-score-table square))
- (lm-play-move square 6)
- (cond ((>= score lm-winning-threshold)
- (setq lm-emacs-won t) ; for font-lock
- (lm-find-filled-qtuple square 6)
- (lm-terminate-game 'emacs-won))
+ (setq score (aref landmark-score-table square))
+ (landmark-play-move square 6)
+ (cond ((>= score landmark-winning-threshold)
+ (setq landmark-emacs-won t) ; for font-lock
+ (landmark-find-filled-qtuple square 6)
+ (landmark-terminate-game 'emacs-won))
((zerop score)
- (lm-terminate-game 'nobody-won))
- ((and (> lm-number-of-moves lm-draw-limit)
- (not lm-human-refused-draw)
- (lm-offer-a-draw))
- (lm-terminate-game 'draw-agreed))
+ (landmark-terminate-game 'nobody-won))
+ ((and (> landmark-number-of-moves landmark-draw-limit)
+ (not landmark-human-refused-draw)
+ (landmark-offer-a-draw))
+ (landmark-terminate-game 'draw-agreed))
(t
- (lm-prompt-for-move)))))))))
+ (landmark-prompt-for-move)))))))))
;; For small square dimensions this is approximate, since though measured in
;; pixels, event's (X . Y) is a character's top-left corner.
-(defun lm-click (click)
+(defun landmark-click (click)
"Position at the square where you click."
(interactive "e")
(and (windowp (posn-window (setq click (event-end click))))
(numberp (posn-point click))
(select-window (posn-window click))
(setq click (posn-col-row click))
- (lm-goto-xy
+ (landmark-goto-xy
(min (max (/ (+ (- (car click)
- lm-x-offset
+ landmark-x-offset
1)
(window-hscroll)
- lm-square-width
- (% lm-square-width 2)
- (/ lm-square-width 2))
- lm-square-width)
+ landmark-square-width
+ (% landmark-square-width 2)
+ (/ landmark-square-width 2))
+ landmark-square-width)
1)
- lm-board-width)
+ landmark-board-width)
(min (max (/ (+ (- (cdr click)
- lm-y-offset
+ landmark-y-offset
1)
(let ((inhibit-point-motion-hooks t))
(count-lines 1 (window-start)))
- lm-square-height
- (% lm-square-height 2)
- (/ lm-square-height 2))
- lm-square-height)
+ landmark-square-height
+ (% landmark-square-height 2)
+ (/ landmark-square-height 2))
+ landmark-square-height)
1)
- lm-board-height))))
+ landmark-board-height))))
-(defun lm-mouse-play (click)
+(defun landmark-mouse-play (click)
"Play at the square where you click."
(interactive "e")
- (if (lm-click click)
- (lm-human-plays)))
+ (if (landmark-click click)
+ (landmark-human-plays)))
-(defun lm-human-plays ()
- "Signal to the Lm program that you have played.
+(defun landmark-human-plays ()
+ "Signal to the Landmark program that you have played.
You must have put the cursor on the square where you want to play.
If the game is finished, this command requests for another game."
(interactive)
- (lm-switch-to-window)
+ (landmark-switch-to-window)
(cond
- (lm-emacs-is-computing
- (lm-crash-game))
- ((not lm-game-in-progress)
- (lm-prompt-for-other-game))
+ (landmark-emacs-is-computing
+ (landmark-crash-game))
+ ((not landmark-game-in-progress)
+ (landmark-prompt-for-other-game))
(t
(let (square score)
- (setq square (lm-point-square))
+ (setq square (landmark-point-square))
(cond ((null square)
(error "Your point is not on a square. Retry!"))
- ((not (zerop (aref lm-board square)))
+ ((not (zerop (aref landmark-board square)))
(error "Your point is not on a free square. Retry!"))
(t
- (setq score (aref lm-score-table square))
- (lm-play-move square 1)
- (cond ((and (>= score lm-loosing-threshold)
+ (setq score (aref landmark-score-table square))
+ (landmark-play-move square 1)
+ (cond ((and (>= score landmark-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.
- (lm-find-filled-qtuple square 1))
- (lm-terminate-game 'human-won))
+ ;; we confirm with LANDMARK-FIND-FILLED-QTUPLE.
+ (landmark-find-filled-qtuple square 1))
+ (landmark-terminate-game 'human-won))
(t
- (lm-emacs-plays)))))))))
+ (landmark-emacs-plays)))))))))
-(defun lm-human-takes-back ()
- "Signal to the Lm program that you wish to take back your last move."
+(defun landmark-human-takes-back ()
+ "Signal to the Landmark program that you wish to take back your last move."
(interactive)
- (lm-switch-to-window)
+ (landmark-switch-to-window)
(cond
- (lm-emacs-is-computing
- (lm-crash-game))
- ((not lm-game-in-progress)
+ (landmark-emacs-is-computing
+ (landmark-crash-game))
+ ((not landmark-game-in-progress)
(message "Too late for taking back...")
(sit-for 4)
- (lm-prompt-for-other-game))
- ((zerop lm-number-of-human-moves)
+ (landmark-prompt-for-other-game))
+ ((zerop landmark-number-of-human-moves)
(message "You have not played yet... Your move?"))
(t
(message "One moment, please...")
;; It is possible for the user to let Emacs play several consecutive
;; moves, so that the best way to know when to stop taking back moves is
;; to count the number of human moves:
- (setq lm-human-took-back t)
- (let ((number lm-number-of-human-moves))
- (while (= number lm-number-of-human-moves)
- (lm-take-back)))
- (lm-prompt-for-move))))
-
-(defun lm-human-resigns ()
- "Signal to the Lm program that you may want to resign."
+ (setq landmark-human-took-back t)
+ (let ((number landmark-number-of-human-moves))
+ (while (= number landmark-number-of-human-moves)
+ (landmark-take-back)))
+ (landmark-prompt-for-move))))
+
+(defun landmark-human-resigns ()
+ "Signal to the Landmark program that you may want to resign."
(interactive)
- (lm-switch-to-window)
+ (landmark-switch-to-window)
(cond
- (lm-emacs-is-computing
- (lm-crash-game))
- ((not lm-game-in-progress)
+ (landmark-emacs-is-computing
+ (landmark-crash-game))
+ ((not landmark-game-in-progress)
(message "There is no game in progress"))
((y-or-n-p "You mean, you resign? ")
- (lm-terminate-game 'human-resigned))
+ (landmark-terminate-game 'human-resigned))
((y-or-n-p "You mean, we continue? ")
- (lm-prompt-for-move))
+ (landmark-prompt-for-move))
(t
- (lm-terminate-game 'human-resigned)))) ; OK. Accept it
+ (landmark-terminate-game 'human-resigned)))) ; OK. Accept it
;;;_ + PROMPTING THE HUMAN PLAYER.
-(defun lm-prompt-for-move ()
+(defun landmark-prompt-for-move ()
"Display a message asking for Human's move."
- (message (if (zerop lm-number-of-human-moves)
+ (message (if (zerop landmark-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 ()
+(defun landmark-prompt-for-other-game ()
"Ask for another game, and start it."
(if (y-or-n-p "Another game? ")
(if (y-or-n-p "Retain learned weights ")
- (lm 2)
- (lm 1))
+ (landmark 2)
+ (landmark 1))
(message "Chicken!")))
-(defun lm-offer-a-draw ()
+(defun landmark-offer-a-draw ()
"Offer a draw and return t if Human accepted it."
(or (y-or-n-p "I offer you a draw. Do you accept it? ")
- (not (setq lm-human-refused-draw t))))
+ (not (setq landmark-human-refused-draw t))))
-(defun lm-max-width ()
+(defun landmark-max-width ()
"Largest possible board width for the current window."
(1+ (/ (- (window-width (selected-window))
- lm-x-offset lm-x-offset 1)
- lm-square-width)))
+ landmark-x-offset landmark-x-offset 1)
+ landmark-square-width)))
-(defun lm-max-height ()
+(defun landmark-max-height ()
"Largest possible board height for the current window."
(1+ (/ (- (window-height (selected-window))
- lm-y-offset lm-y-offset 2)
+ landmark-y-offset landmark-y-offset 2)
;; 2 instead of 1 because WINDOW-HEIGHT includes the mode line !
- lm-square-height)))
+ landmark-square-height)))
-(defun lm-point-y ()
+(defun landmark-point-y ()
"Return the board row where point is."
(let ((inhibit-point-motion-hooks t))
- (1+ (/ (- (count-lines 1 (point)) lm-y-offset (if (bolp) 0 1))
- lm-square-height))))
+ (1+ (/ (- (count-lines 1 (point)) landmark-y-offset (if (bolp) 0 1))
+ landmark-square-height))))
-(defun lm-point-square ()
+(defun landmark-point-square ()
"Return the index of the square point is on."
(let ((inhibit-point-motion-hooks t))
- (lm-xy-to-index (1+ (/ (- (current-column) lm-x-offset)
- lm-square-width))
- (lm-point-y))))
+ (landmark-xy-to-index (1+ (/ (- (current-column) landmark-x-offset)
+ landmark-square-width))
+ (landmark-point-y))))
-(defun lm-goto-square (index)
+(defun landmark-goto-square (index)
"Move point to square number INDEX."
- (lm-goto-xy (lm-index-to-x index) (lm-index-to-y index)))
+ (landmark-goto-xy (landmark-index-to-x index) (landmark-index-to-y index)))
-(defun lm-goto-xy (x y)
+(defun landmark-goto-xy (x y)
"Move point to square at X, Y coords."
(let ((inhibit-point-motion-hooks t))
(goto-char (point-min))
- (forward-line (+ lm-y-offset (* lm-square-height (1- y)))))
- (move-to-column (+ lm-x-offset (* lm-square-width (1- x)))))
+ (forward-line (+ landmark-y-offset (* landmark-square-height (1- y)))))
+ (move-to-column (+ landmark-x-offset (* landmark-square-width (1- x)))))
-(defun lm-plot-square (square value)
+(defun landmark-plot-square (square value)
"Draw 'X', 'O' or '.' on SQUARE depending on VALUE, leave point there."
(or (= value 1)
- (lm-goto-square square))
+ (landmark-goto-square square))
(let ((inhibit-read-only t)
(inhibit-point-motion-hooks t))
(insert-and-inherit (cond ((= value 1) ?.)
@@ -903,8 +900,8 @@ mouse-1: get robot moving, mouse-2: play on this square")))
(backward-char 1))
(sit-for 0)) ; Display NOW
-(defun lm-init-display (n m)
- "Display an N by M Lm board."
+(defun landmark-init-display (n m)
+ "Display an N by M Landmark board."
(buffer-disable-undo (current-buffer))
(let ((inhibit-read-only t)
(point 1) opoint
@@ -912,17 +909,17 @@ mouse-1: get robot moving, mouse-2: play on this square")))
(i m) j x)
;; Try to minimize number of chars (because of text properties)
(setq tab-width
- (if (zerop (% lm-x-offset lm-square-width))
- lm-square-width
- (max (/ (+ (% lm-x-offset lm-square-width)
- lm-square-width 1) 2) 2)))
+ (if (zerop (% landmark-x-offset landmark-square-width))
+ landmark-square-width
+ (max (/ (+ (% landmark-x-offset landmark-square-width)
+ landmark-square-width 1) 2) 2)))
(erase-buffer)
- (newline lm-y-offset)
+ (newline landmark-y-offset)
(while (progn
(setq j n
- x (- lm-x-offset lm-square-width))
+ x (- landmark-x-offset landmark-square-width))
(while (>= (setq j (1- j)) 0)
- (insert-char ?\t (/ (- (setq x (+ x lm-square-width))
+ (insert-char ?\t (/ (- (setq x (+ x landmark-square-width))
(current-column))
tab-width))
(insert-char ? (- x (current-column)))
@@ -943,40 +940,40 @@ mouse-1: get robot moving, mouse-2: play on this square")))
(> (setq i (1- i)) 0))
(if (= i (1- m))
(setq opoint point))
- (insert-char ?\n lm-square-height))
+ (insert-char ?\n landmark-square-height))
(or (eq (char-after 1) ?.)
(put-text-property 1 2 'point-entered
- (lambda (x y) (if (bobp) (forward-char)))))
+ (lambda (_x _y) (if (bobp) (forward-char)))))
(or intangible
(put-text-property point (point) 'intangible 2))
(put-text-property point (point) 'point-entered
- (lambda (x y) (if (eobp) (backward-char))))
- (put-text-property (point-min) (point) 'category 'lm-mode))
- (lm-goto-xy (/ (1+ n) 2) (/ (1+ m) 2)) ; center of the board
+ (lambda (_x _y) (if (eobp) (backward-char))))
+ (put-text-property (point-min) (point) 'category 'landmark-mode))
+ (landmark-goto-xy (/ (1+ n) 2) (/ (1+ m) 2)) ; center of the board
(sit-for 0)) ; Display NOW
-(defun lm-display-statistics ()
+(defun landmark-display-statistics ()
"Obnoxiously display some statistics about previous games in mode line."
;; We store this string in the mode-line-process local variable.
;; This is certainly not the cleanest way out ...
(setq mode-line-process
(format ": Trials: %d, Avg#Moves: %d"
- lm-number-of-trials
- (if (zerop lm-number-of-trials)
+ landmark-number-of-trials
+ (if (zerop landmark-number-of-trials)
0
- (/ lm-sum-of-moves lm-number-of-trials))))
+ (/ landmark-sum-of-moves landmark-number-of-trials))))
(force-mode-line-update))
-(defun lm-switch-to-window ()
- "Find or create the Lm buffer, and display it."
+(defun landmark-switch-to-window ()
+ "Find or create the Landmark buffer, and display it."
(interactive)
- (let ((buff (get-buffer "*Lm*")))
+ (let ((buff (get-buffer "*Landmark*")))
(if buff ; Buffer exists:
(switch-to-buffer buff) ; no problem.
- (if lm-game-in-progress
- (lm-crash-game)) ; buffer has been killed or something
- (switch-to-buffer "*Lm*") ; Anyway, start anew.
- (lm-mode))))
+ (if landmark-game-in-progress
+ (landmark-crash-game)) ; buffer has been killed or something
+ (switch-to-buffer "*Landmark*") ; Anyway, start anew.
+ (landmark-mode))))
;;;_ + CROSSING WINNING QTUPLES.
@@ -986,61 +983,61 @@ mouse-1: get robot moving, mouse-2: play on this square")))
;; squares ! It only knows the square where the last move has been played and
;; who won. The solution is to scan the board along all four directions.
-(defun lm-find-filled-qtuple (square value)
+(defun landmark-find-filled-qtuple (square value)
"Return t if SQUARE belongs to a qtuple filled with VALUEs."
- (or (lm-check-filled-qtuple square value 1 0)
- (lm-check-filled-qtuple square value 0 1)
- (lm-check-filled-qtuple square value 1 1)
- (lm-check-filled-qtuple square value -1 1)))
+ (or (landmark-check-filled-qtuple square value 1 0)
+ (landmark-check-filled-qtuple square value 0 1)
+ (landmark-check-filled-qtuple square value 1 1)
+ (landmark-check-filled-qtuple square value -1 1)))
-(defun lm-check-filled-qtuple (square value dx dy)
+(defun landmark-check-filled-qtuple (square value dx dy)
"Return t if SQUARE belongs to a qtuple filled with VALUEs along DX, DY."
(let ((a 0) (b 0)
(left square) (right square)
- (depl (lm-xy-to-index dx dy)))
+ (depl (landmark-xy-to-index dx dy)))
(while (and (> a -4) ; stretch tuple left
- (= value (aref lm-board (setq left (- left depl)))))
+ (= value (aref landmark-board (setq left (- left depl)))))
(setq a (1- a)))
(while (and (< b (+ a 4)) ; stretch tuple right
- (= value (aref lm-board (setq right (+ right depl)))))
+ (= value (aref landmark-board (setq right (+ right depl)))))
(setq b (1+ b)))
(cond ((= b (+ a 4)) ; tuple length = 5 ?
- (lm-cross-qtuple (+ square (* a depl)) (+ square (* b depl))
+ (landmark-cross-qtuple (+ square (* a depl)) (+ square (* b depl))
dx dy)
t))))
-(defun lm-cross-qtuple (square1 square2 dx dy)
+(defun landmark-cross-qtuple (square1 square2 dx dy)
"Cross every square between SQUARE1 and SQUARE2 in the DX, DY direction."
(save-excursion ; Not moving point from last square
- (let ((depl (lm-xy-to-index dx dy))
+ (let ((depl (landmark-xy-to-index dx dy))
(inhibit-read-only t)
(inhibit-point-motion-hooks t))
;; WARNING: this function assumes DEPL > 0 and SQUARE2 > SQUARE1
(while (/= square1 square2)
- (lm-goto-square square1)
+ (landmark-goto-square square1)
(setq square1 (+ square1 depl))
(cond
((= dy 0) ; Horizontal
(forward-char 1)
- (insert-char ?- (1- lm-square-width) t)
+ (insert-char ?- (1- landmark-square-width) t)
(delete-region (point) (progn
(skip-chars-forward " \t")
(point))))
((= dx 0) ; Vertical
- (let ((lm-n 1)
+ (let ((landmark-n 1)
(column (current-column)))
- (while (< lm-n lm-square-height)
- (setq lm-n (1+ lm-n))
+ (while (< landmark-n landmark-square-height)
+ (setq landmark-n (1+ landmark-n))
(forward-line 1)
(indent-to column)
(insert-and-inherit ?|))))
((= dx -1) ; 1st Diagonal
- (indent-to (prog1 (- (current-column) (/ lm-square-width 2))
- (forward-line (/ lm-square-height 2))))
+ (indent-to (prog1 (- (current-column) (/ landmark-square-width 2))
+ (forward-line (/ landmark-square-height 2))))
(insert-and-inherit ?/))
(t ; 2nd Diagonal
- (indent-to (prog1 (+ (current-column) (/ lm-square-width 2))
- (forward-line (/ lm-square-height 2))))
+ (indent-to (prog1 (+ (current-column) (/ landmark-square-width 2))
+ (forward-line (/ landmark-square-height 2))))
(insert-and-inherit ?\\))))))
(sit-for 0)) ; Display NOW
@@ -1048,301 +1045,301 @@ mouse-1: get robot moving, mouse-2: play on this square")))
;;;_ + CURSOR MOTION.
;; previous-line and next-line don't work right with intangible newlines
-(defun lm-move-down ()
- "Move point down one row on the Lm board."
+(defun landmark-move-down ()
+ "Move point down one row on the Landmark board."
(interactive)
- (if (< (lm-point-y) lm-board-height)
- (forward-line 1)));;; lm-square-height)))
+ (if (< (landmark-point-y) landmark-board-height)
+ (forward-line 1)));;; landmark-square-height)))
-(defun lm-move-up ()
- "Move point up one row on the Lm board."
+(defun landmark-move-up ()
+ "Move point up one row on the Landmark board."
(interactive)
- (if (> (lm-point-y) 1)
- (forward-line (- lm-square-height))))
+ (if (> (landmark-point-y) 1)
+ (forward-line (- landmark-square-height))))
-(defun lm-move-ne ()
- "Move point North East on the Lm board."
+(defun landmark-move-ne ()
+ "Move point North East on the Landmark board."
(interactive)
- (lm-move-up)
+ (landmark-move-up)
(forward-char))
-(defun lm-move-se ()
- "Move point South East on the Lm board."
+(defun landmark-move-se ()
+ "Move point South East on the Landmark board."
(interactive)
- (lm-move-down)
+ (landmark-move-down)
(forward-char))
-(defun lm-move-nw ()
- "Move point North West on the Lm board."
+(defun landmark-move-nw ()
+ "Move point North West on the Landmark board."
(interactive)
- (lm-move-up)
+ (landmark-move-up)
(backward-char))
-(defun lm-move-sw ()
- "Move point South West on the Lm board."
+(defun landmark-move-sw ()
+ "Move point South West on the Landmark board."
(interactive)
- (lm-move-down)
+ (landmark-move-down)
(backward-char))
-(defun lm-beginning-of-line ()
- "Move point to first square on the Lm board row."
+(defun landmark-beginning-of-line ()
+ "Move point to first square on the Landmark board row."
(interactive)
- (move-to-column lm-x-offset))
+ (move-to-column landmark-x-offset))
-(defun lm-end-of-line ()
- "Move point to last square on the Lm board row."
+(defun landmark-end-of-line ()
+ "Move point to last square on the Landmark board row."
(interactive)
- (move-to-column (+ lm-x-offset
- (* lm-square-width (1- lm-board-width)))))
+ (move-to-column (+ landmark-x-offset
+ (* landmark-square-width (1- landmark-board-width)))))
;;;_ + Simulation variables
-;;;_ - lm-nvar
-(defvar lm-nvar 0.0075
+;;;_ - landmark-nvar
+(defvar landmark-nvar 0.0075
"Not used.
Affects a noise generator which was used in an earlier incarnation of
this program to add a random element to the way moves were made.")
;;;_ - lists of cardinal directions
;;;_ :
-(defvar lm-ns '(lm-n lm-s)
+(defvar landmark-ns '(landmark-n landmark-s)
"Used when doing something relative to the north and south axes.")
-(defvar lm-ew '(lm-e lm-w)
+(defvar landmark-ew '(landmark-e landmark-w)
"Used when doing something relative to the east and west axes.")
-(defvar lm-directions '(lm-n lm-s lm-e lm-w)
+(defvar landmark-directions '(landmark-n landmark-s landmark-e landmark-w)
"The cardinal directions.")
-(defvar lm-8-directions
- '((lm-n) (lm-n lm-w) (lm-w) (lm-s lm-w)
- (lm-s) (lm-s lm-e) (lm-e) (lm-n lm-e))
+(defvar landmark-8-directions
+ '((landmark-n) (landmark-n landmark-w) (landmark-w) (landmark-s landmark-w)
+ (landmark-s) (landmark-s landmark-e) (landmark-e) (landmark-n landmark-e))
"The full 8 possible directions.")
-(defvar lm-number-of-moves
+(defvar landmark-number-of-moves
"The number of moves made by the robot so far.")
;;;_* Terry's mods to create lm.el
-;;;(setq lm-debug nil)
-(defvar lm-debug nil
+;;;(setq landmark-debug nil)
+(defvar landmark-debug nil
"If non-nil, debugging is printed.")
-(defcustom lm-one-moment-please nil
+(defcustom landmark-one-moment-please nil
"If non-nil, print \"One moment please\" when a new board is generated.
The drawback of this is you don't see how many moves the last run took
because it is overwritten by \"One moment please\"."
:type 'boolean
- :group 'lm)
-(defcustom lm-output-moves t
+ :group 'landmark)
+(defcustom landmark-output-moves t
"If non-nil, output number of moves so far on a move-by-move basis."
:type 'boolean
- :group 'lm)
+ :group 'landmark)
-(defun lm-weights-debug ()
- (if lm-debug
- (progn (lm-print-wts) (lm-blackbox) (lm-print-y,s,noise)
- (lm-print-smell))))
+(defun landmark-weights-debug ()
+ (if landmark-debug
+ (progn (landmark-print-wts) (landmark-blackbox) (landmark-print-y-s-noise)
+ (landmark-print-smell))))
;;;_ - Printing various things
-(defun lm-print-distance-int (direction)
+(defun landmark-print-distance-int (direction)
(interactive)
(insert (format "%S %S " direction (get direction 'distance))))
-(defun lm-print-distance ()
- (insert (format "tree: %S \n" (calc-distance-of-robot-from 'lm-tree)))
- (mapc 'lm-print-distance-int lm-directions))
+(defun landmark-print-distance ()
+ (insert (format "tree: %S \n" (calc-distance-of-robot-from 'landmark-tree)))
+ (mapc 'landmark-print-distance-int landmark-directions))
-;;(setq direction 'lm-n)
-;;(get 'lm-n 'lm-s)
-(defun lm-nslify-wts-int (direction)
+;;(setq direction 'landmark-n)
+;;(get 'landmark-n 'landmark-s)
+(defun landmark-nslify-wts-int (direction)
(mapcar (lambda (target-direction)
(get direction target-direction))
- lm-directions))
+ landmark-directions))
-(defun lm-nslify-wts ()
+(defun landmark-nslify-wts ()
(interactive)
- (let ((l (apply 'append (mapcar 'lm-nslify-wts-int lm-directions))))
+ (let ((l (apply 'append (mapcar 'landmark-nslify-wts-int landmark-directions))))
(insert (format "set data_value WTS \n %s \n" l))
(insert (format "/* max: %S min: %S */"
(eval (cons 'max l)) (eval (cons 'min l))))))
-(defun lm-print-wts-int (direction)
+(defun landmark-print-wts-int (direction)
(mapc (lambda (target-direction)
(insert (format "%S %S %S "
direction
target-direction
(get direction target-direction))))
- lm-directions)
+ landmark-directions)
(insert "\n"))
-(defun lm-print-wts ()
+(defun landmark-print-wts ()
(interactive)
- (with-current-buffer "*lm-wts*"
+ (with-current-buffer "*landmark-wts*"
(insert "==============================\n")
- (mapc 'lm-print-wts-int lm-directions)))
+ (mapc 'landmark-print-wts-int landmark-directions)))
-(defun lm-print-moves (moves)
+(defun landmark-print-moves (moves)
(interactive)
- (with-current-buffer "*lm-moves*"
+ (with-current-buffer "*landmark-moves*"
(insert (format "%S\n" moves))))
-(defun lm-print-y,s,noise-int (direction)
- (insert (format "%S:lm-y %S, s %S, noise %S \n"
+(defun landmark-print-y-s-noise-int (direction)
+ (insert (format "%S:landmark-y %S, s %S, noise %S \n"
(symbol-name direction)
(get direction 'y_t)
(get direction 's)
(get direction 'noise)
)))
-(defun lm-print-y,s,noise ()
+(defun landmark-print-y-s-noise ()
(interactive)
- (with-current-buffer "*lm-y,s,noise*"
+ (with-current-buffer "*landmark-y,s,noise*"
(insert "==============================\n")
- (mapc 'lm-print-y,s,noise-int lm-directions)))
+ (mapc 'landmark-print-y-s-noise-int landmark-directions)))
-(defun lm-print-smell-int (direction)
+(defun landmark-print-smell-int (direction)
(insert (format "%S: smell: %S \n"
(symbol-name direction)
(get direction 'smell))))
-(defun lm-print-smell ()
+(defun landmark-print-smell ()
(interactive)
- (with-current-buffer "*lm-smell*"
+ (with-current-buffer "*landmark-smell*"
(insert "==============================\n")
(insert (format "tree: %S \n" (get 'z 't)))
- (mapc 'lm-print-smell-int lm-directions)))
+ (mapc 'landmark-print-smell-int landmark-directions)))
-(defun lm-print-w0-int (direction)
+(defun landmark-print-w0-int (direction)
(insert (format "%S: w0: %S \n"
(symbol-name direction)
(get direction 'w0))))
-(defun lm-print-w0 ()
+(defun landmark-print-w0 ()
(interactive)
- (with-current-buffer "*lm-w0*"
+ (with-current-buffer "*landmark-w0*"
(insert "==============================\n")
- (mapc 'lm-print-w0-int lm-directions)))
+ (mapc 'landmark-print-w0-int landmark-directions)))
-(defun lm-blackbox ()
- (with-current-buffer "*lm-blackbox*"
+(defun landmark-blackbox ()
+ (with-current-buffer "*landmark-blackbox*"
(insert "==============================\n")
(insert "I smell: ")
(mapc (lambda (direction)
(if (> (get direction 'smell) 0)
(insert (format "%S " direction))))
- lm-directions)
+ landmark-directions)
(insert "\n")
(insert "I move: ")
(mapc (lambda (direction)
(if (> (get direction 'y_t) 0)
(insert (format "%S " direction))))
- lm-directions)
+ landmark-directions)
(insert "\n")
- (lm-print-wts-blackbox)
+ (landmark-print-wts-blackbox)
(insert (format "z_t-z_t-1: %S" (- (get 'z 't) (get 'z 't-1))))
- (lm-print-distance)
+ (landmark-print-distance)
(insert "\n")))
-(defun lm-print-wts-blackbox ()
+(defun landmark-print-wts-blackbox ()
(interactive)
- (mapc 'lm-print-wts-int lm-directions))
+ (mapc 'landmark-print-wts-int landmark-directions))
;;;_ - learning parameters
-(defcustom lm-bound 0.005
+(defcustom landmark-bound 0.005
"The maximum that w0j may be."
:type 'number
- :group 'lm)
-(defcustom lm-c 1.0
+ :group 'landmark)
+(defcustom landmark-c 1.0
"A factor applied to modulate the increase in wij.
-Used in the function lm-update-normal-weights."
+Used in the function landmark-update-normal-weights."
:type 'number
- :group 'lm)
-(defcustom lm-c-naught 0.5
+ :group 'landmark)
+(defcustom landmark-c-naught 0.5
"A factor applied to modulate the increase in w0j.
-Used in the function lm-update-naught-weights."
+Used in the function landmark-update-naught-weights."
:type 'number
- :group 'lm)
-(defvar lm-initial-w0 0.0)
-(defvar lm-initial-wij 0.0)
-(defcustom lm-no-payoff 0
+ :group 'landmark)
+(defvar landmark-initial-w0 0.0)
+(defvar landmark-initial-wij 0.0)
+(defcustom landmark-no-payoff 0
"The amount of simulation cycles that have occurred with no movement.
Used to move the robot when he is stuck in a rut for some reason."
:type 'integer
- :group 'lm)
-(defcustom lm-max-stall-time 2
+ :group 'landmark)
+(defcustom landmark-max-stall-time 2
"The maximum number of cycles that the robot can remain stuck in a place.
-After this limit is reached, lm-random-move is called to push him out of it."
+After this limit is reached, landmark-random-move is called to push him out of it."
:type 'integer
- :group 'lm)
+ :group 'landmark)
;;;_ + Randomizing functions
-;;;_ - lm-flip-a-coin ()
-(defun lm-flip-a-coin ()
+;;;_ - landmark-flip-a-coin ()
+(defun landmark-flip-a-coin ()
(if (> (random 5000) 2500)
-1
1))
-;;;_ : lm-very-small-random-number ()
-;(defun lm-very-small-random-number ()
+;;;_ : landmark-very-small-random-number ()
+;(defun landmark-very-small-random-number ()
; (/
; (* (/ (random 900000) 900000.0) .0001)))
-;;;_ : lm-randomize-weights-for (direction)
-(defun lm-randomize-weights-for (direction)
+;;;_ : landmark-randomize-weights-for (direction)
+(defun landmark-randomize-weights-for (direction)
(mapc (lambda (target-direction)
(put direction
target-direction
- (* (lm-flip-a-coin) (/ (random 10000) 10000.0))))
- lm-directions))
-;;;_ : lm-noise ()
-(defun lm-noise ()
- (* (- (/ (random 30001) 15000.0) 1) lm-nvar))
-
-;;;_ : lm-fix-weights-for (direction)
-(defun lm-fix-weights-for (direction)
+ (* (landmark-flip-a-coin) (/ (random 10000) 10000.0))))
+ landmark-directions))
+;;;_ : landmark-noise ()
+(defun landmark-noise ()
+ (* (- (/ (random 30001) 15000.0) 1) landmark-nvar))
+
+;;;_ : landmark-fix-weights-for (direction)
+(defun landmark-fix-weights-for (direction)
(mapc (lambda (target-direction)
(put direction
target-direction
- lm-initial-wij))
- lm-directions))
+ landmark-initial-wij))
+ landmark-directions))
;;;_ + Plotting functions
-;;;_ - lm-plot-internal (sym)
-(defun lm-plot-internal (sym)
- (lm-plot-square (lm-xy-to-index
+;;;_ - landmark-plot-internal (sym)
+(defun landmark-plot-internal (sym)
+ (landmark-plot-square (landmark-xy-to-index
(get sym 'x)
(get sym 'y))
(get sym 'sym)))
-;;;_ - lm-plot-landmarks ()
-(defun lm-plot-landmarks ()
- (setq lm-cx (/ lm-board-width 2))
- (setq lm-cy (/ lm-board-height 2))
+;;;_ - landmark-plot-landmarks ()
+(defun landmark-plot-landmarks ()
+ (setq landmark-cx (/ landmark-board-width 2))
+ (setq landmark-cy (/ landmark-board-height 2))
- (put 'lm-n 'x lm-cx)
- (put 'lm-n 'y 1)
- (put 'lm-n 'sym 2)
+ (put 'landmark-n 'x landmark-cx)
+ (put 'landmark-n 'y 1)
+ (put 'landmark-n 'sym 2)
- (put 'lm-tree 'x lm-cx)
- (put 'lm-tree 'y lm-cy)
- (put 'lm-tree 'sym 6)
+ (put 'landmark-tree 'x landmark-cx)
+ (put 'landmark-tree 'y landmark-cy)
+ (put 'landmark-tree 'sym 6)
- (put 'lm-s 'x lm-cx)
- (put 'lm-s 'y lm-board-height)
- (put 'lm-s 'sym 3)
+ (put 'landmark-s 'x landmark-cx)
+ (put 'landmark-s 'y landmark-board-height)
+ (put 'landmark-s 'sym 3)
- (put 'lm-w 'x 1)
- (put 'lm-w 'y (/ lm-board-height 2))
- (put 'lm-w 'sym 5)
+ (put 'landmark-w 'x 1)
+ (put 'landmark-w 'y (/ landmark-board-height 2))
+ (put 'landmark-w 'sym 5)
- (put 'lm-e 'x lm-board-width)
- (put 'lm-e 'y (/ lm-board-height 2))
- (put 'lm-e 'sym 4)
+ (put 'landmark-e 'x landmark-board-width)
+ (put 'landmark-e 'y (/ landmark-board-height 2))
+ (put 'landmark-e 'sym 4)
- (mapc 'lm-plot-internal '(lm-n lm-s lm-e lm-w lm-tree)))
+ (mapc 'landmark-plot-internal '(landmark-n landmark-s landmark-e landmark-w landmark-tree)))
@@ -1359,9 +1356,9 @@ After this limit is reached, lm-random-move is called to push him out of it."
(defun calc-distance-of-robot-from (direction)
(put direction 'distance
(distance (get direction 'x)
- (lm-index-to-x (lm-point-square))
+ (landmark-index-to-x (landmark-point-square))
(get direction 'y)
- (lm-index-to-y (lm-point-square)))))
+ (landmark-index-to-y (landmark-point-square)))))
;;;_ - calc-smell-internal (sym)
(defun calc-smell-internal (sym)
@@ -1373,269 +1370,259 @@ After this limit is reached, lm-random-move is called to push him out of it."
;;;_ + Learning (neural) functions
-(defun lm-f (x)
+(defun landmark-f (x)
(cond
- ((> x lm-bound) lm-bound)
+ ((> x landmark-bound) landmark-bound)
((< x 0.0) 0.0)
(t x)))
-(defun lm-y (direction)
- (let ((noise (put direction 'noise (lm-noise))))
- (put direction 'y_t
- (if (> (get direction 's) 0.0)
- 1.0
- 0.0))))
+(defun landmark-y (direction)
+ (put direction 'noise (landmark-noise))
+ (put direction 'y_t
+ (if (> (get direction 's) 0.0)
+ 1.0
+ 0.0)))
-(defun lm-update-normal-weights (direction)
+(defun landmark-update-normal-weights (direction)
(mapc (lambda (target-direction)
(put direction target-direction
(+
(get direction target-direction)
- (* lm-c
+ (* landmark-c
(- (get 'z 't) (get 'z 't-1))
(get target-direction 'y_t)
(get direction 'smell)))))
- lm-directions))
+ landmark-directions))
-(defun lm-update-naught-weights (direction)
- (mapc (lambda (target-direction)
+(defun landmark-update-naught-weights (direction)
+ (mapc (lambda (_target-direction)
(put direction 'w0
- (lm-f
+ (landmark-f
(+
(get direction 'w0)
- (* lm-c-naught
+ (* landmark-c-naught
(- (get 'z 't) (get 'z 't-1))
(get direction 'y_t))))))
- lm-directions))
+ landmark-directions))
;;;_ + Statistics gathering and creating functions
-(defun lm-calc-current-smells ()
+(defun landmark-calc-current-smells ()
(mapc (lambda (direction)
(put direction 'smell (calc-smell-internal direction)))
- lm-directions))
+ landmark-directions))
-(defun lm-calc-payoff ()
+(defun landmark-calc-payoff ()
(put 'z 't-1 (get 'z 't))
- (put 'z 't (calc-smell-internal 'lm-tree))
+ (put 'z 't (calc-smell-internal 'landmark-tree))
(if (= (- (get 'z 't) (get 'z 't-1)) 0.0)
- (incf lm-no-payoff)
- (setf lm-no-payoff 0)))
+ (incf landmark-no-payoff)
+ (setf landmark-no-payoff 0)))
-(defun lm-store-old-y_t ()
+(defun landmark-store-old-y_t ()
(mapc (lambda (direction)
(put direction 'y_t-1 (get direction 'y_t)))
- lm-directions))
+ landmark-directions))
;;;_ + Functions to move robot
-(defun lm-confidence-for (target-direction)
+(defun landmark-confidence-for (target-direction)
(apply '+
(get target-direction 'w0)
(mapcar (lambda (direction)
(*
(get direction target-direction)
(get direction 'smell)))
- lm-directions)))
+ landmark-directions)))
-(defun lm-calc-confidences ()
+(defun landmark-calc-confidences ()
(mapc (lambda (direction)
- (put direction 's (lm-confidence-for direction)))
- lm-directions))
+ (put direction 's (landmark-confidence-for direction)))
+ landmark-directions))
-(defun lm-move ()
- (if (and (= (get 'lm-n 'y_t) 1.0) (= (get 'lm-s 'y_t) 1.0))
+(defun landmark-move ()
+ (if (and (= (get 'landmark-n 'y_t) 1.0) (= (get 'landmark-s 'y_t) 1.0))
(progn
- (mapc (lambda (dir) (put dir 'y_t 0)) lm-ns)
- (if lm-debug
+ (mapc (lambda (dir) (put dir 'y_t 0)) landmark-ns)
+ (if landmark-debug
(message "n-s normalization."))))
- (if (and (= (get 'lm-w 'y_t) 1.0) (= (get 'lm-e 'y_t) 1.0))
+ (if (and (= (get 'landmark-w 'y_t) 1.0) (= (get 'landmark-e 'y_t) 1.0))
(progn
- (mapc (lambda (dir) (put dir 'y_t 0)) lm-ew)
- (if lm-debug
+ (mapc (lambda (dir) (put dir 'y_t 0)) landmark-ew)
+ (if landmark-debug
(message "e-w normalization"))))
(mapc (lambda (pair)
(if (> (get (car pair) 'y_t) 0)
(funcall (car (cdr pair)))))
'(
- (lm-n lm-move-up)
- (lm-s lm-move-down)
- (lm-e forward-char)
- (lm-w backward-char)))
- (lm-plot-square (lm-point-square) 1)
- (incf lm-number-of-moves)
- (if lm-output-moves
- (message "Moves made: %d" lm-number-of-moves)))
+ (landmark-n landmark-move-up)
+ (landmark-s landmark-move-down)
+ (landmark-e forward-char)
+ (landmark-w backward-char)))
+ (landmark-plot-square (landmark-point-square) 1)
+ (incf landmark-number-of-moves)
+ (if landmark-output-moves
+ (message "Moves made: %d" landmark-number-of-moves)))
-(defun lm-random-move ()
+(defun landmark-random-move ()
(mapc
(lambda (direction) (put direction 'y_t 0))
- lm-directions)
- (dolist (direction (nth (random 8) lm-8-directions))
+ landmark-directions)
+ (dolist (direction (nth (random 8) landmark-8-directions))
(put direction 'y_t 1.0))
- (lm-move))
+ (landmark-move))
-(defun lm-amble-robot ()
+(defun landmark-amble-robot ()
(interactive)
- (while (> (calc-distance-of-robot-from 'lm-tree) 0)
+ (while (> (calc-distance-of-robot-from 'landmark-tree) 0)
- (lm-store-old-y_t)
- (lm-calc-current-smells)
+ (landmark-store-old-y_t)
+ (landmark-calc-current-smells)
- (if (> lm-no-payoff lm-max-stall-time)
- (lm-random-move)
+ (if (> landmark-no-payoff landmark-max-stall-time)
+ (landmark-random-move)
(progn
- (lm-calc-confidences)
- (mapc 'lm-y lm-directions)
- (lm-move)))
+ (landmark-calc-confidences)
+ (mapc 'landmark-y landmark-directions)
+ (landmark-move)))
- (lm-calc-payoff)
+ (landmark-calc-payoff)
- (mapc 'lm-update-normal-weights lm-directions)
- (mapc 'lm-update-naught-weights lm-directions)
- (if lm-debug
- (lm-weights-debug)))
- (lm-terminate-game nil))
+ (mapc 'landmark-update-normal-weights landmark-directions)
+ (mapc 'landmark-update-naught-weights landmark-directions)
+ (if landmark-debug
+ (landmark-weights-debug)))
+ (landmark-terminate-game nil))
-;;;_ - lm-start-robot ()
-(defun lm-start-robot ()
- "Signal to the Lm program that you have played.
+;;;_ - landmark-start-robot ()
+(defun landmark-start-robot ()
+ "Signal to the Landmark program that you have played.
You must have put the cursor on the square where you want to play.
If the game is finished, this command requests for another game."
(interactive)
- (lm-switch-to-window)
+ (landmark-switch-to-window)
(cond
- (lm-emacs-is-computing
- (lm-crash-game))
- ((not lm-game-in-progress)
- (lm-prompt-for-other-game))
+ (landmark-emacs-is-computing
+ (landmark-crash-game))
+ ((not landmark-game-in-progress)
+ (landmark-prompt-for-other-game))
(t
- (let (square score)
- (setq square (lm-point-square))
+ (let (square)
+ (setq square (landmark-point-square))
(cond ((null square)
(error "Your point is not on a square. Retry!"))
- ((not (zerop (aref lm-board square)))
+ ((not (zerop (aref landmark-board square)))
(error "Your point is not on a free square. Retry!"))
(t
(progn
- (lm-plot-square square 1)
+ (landmark-plot-square square 1)
- (lm-store-old-y_t)
- (lm-calc-current-smells)
- (put 'z 't (calc-smell-internal 'lm-tree))
+ (landmark-store-old-y_t)
+ (landmark-calc-current-smells)
+ (put 'z 't (calc-smell-internal 'landmark-tree))
- (lm-random-move)
+ (landmark-random-move)
- (lm-calc-payoff)
+ (landmark-calc-payoff)
- (mapc 'lm-update-normal-weights lm-directions)
- (mapc 'lm-update-naught-weights lm-directions)
- (lm-amble-robot)
+ (mapc 'landmark-update-normal-weights landmark-directions)
+ (mapc 'landmark-update-naught-weights landmark-directions)
+ (landmark-amble-robot)
)))))))
;;;_ + Misc functions
-;;;_ - lm-init (auto-start save-weights)
-(defvar lm-tree-r "")
+;;;_ - landmark-init (auto-start save-weights)
+(defvar landmark-tree-r "")
-(defun lm-init (auto-start save-weights)
+(defun landmark-init (auto-start save-weights)
- (setq lm-number-of-moves 0)
+ (setq landmark-number-of-moves 0)
- (lm-plot-landmarks)
+ (landmark-plot-landmarks)
- (if lm-debug
+ (if landmark-debug
(save-current-buffer
- (set-buffer (get-buffer-create "*lm-w0*"))
+ (set-buffer (get-buffer-create "*landmark-w0*"))
(erase-buffer)
- (set-buffer (get-buffer-create "*lm-moves*"))
- (set-buffer (get-buffer-create "*lm-wts*"))
+ (set-buffer (get-buffer-create "*landmark-moves*"))
+ (set-buffer (get-buffer-create "*landmark-wts*"))
(erase-buffer)
- (set-buffer (get-buffer-create "*lm-y,s,noise*"))
+ (set-buffer (get-buffer-create "*landmark-y,s,noise*"))
(erase-buffer)
- (set-buffer (get-buffer-create "*lm-smell*"))
+ (set-buffer (get-buffer-create "*landmark-smell*"))
(erase-buffer)
- (set-buffer (get-buffer-create "*lm-blackbox*"))
+ (set-buffer (get-buffer-create "*landmark-blackbox*"))
(erase-buffer)
- (set-buffer (get-buffer-create "*lm-distance*"))
+ (set-buffer (get-buffer-create "*landmark-distance*"))
(erase-buffer)))
- (lm-set-landmark-signal-strengths)
+ (landmark-set-landmark-signal-strengths)
- (dolist (direction lm-directions)
+ (dolist (direction landmark-directions)
(put direction 'y_t 0.0))
(if (not save-weights)
(progn
- (mapc 'lm-fix-weights-for lm-directions)
- (dolist (direction lm-directions)
- (put direction 'w0 lm-initial-w0)))
+ (mapc 'landmark-fix-weights-for landmark-directions)
+ (dolist (direction landmark-directions)
+ (put direction 'w0 landmark-initial-w0)))
(message "Weights preserved for this run."))
(if auto-start
(progn
- (lm-goto-xy (1+ (random lm-board-width)) (1+ (random lm-board-height)))
- (lm-start-robot))))
+ (landmark-goto-xy (1+ (random landmark-board-width)) (1+ (random landmark-board-height)))
+ (landmark-start-robot))))
;;;_ - something which doesn't work
; no-a-worka!!
-;(defum lm-sum-list (list)
+;(defum landmark-sum-list (list)
; (if (> (length list) 0)
-; (+ (car list) (lm-sum-list (cdr list)))
+; (+ (car list) (landmark-sum-list (cdr list)))
; 0))
; this a worka!
; (eval (cons '+ list))
-;;;_ - lm-set-landmark-signal-strengths ()
+;;;_ - landmark-set-landmark-signal-strengths ()
;;; on a screen higher than wide, I noticed that the robot would amble
-;;; left and right and not move forward. examining *lm-blackbox*
+;;; left and right and not move forward. examining *landmark-blackbox*
;;; revealed that there was no scent from the north and south
;;; landmarks, hence, they need less factoring down of the effect of
;;; distance on scent.
-(defun lm-set-landmark-signal-strengths ()
-
- (setq lm-tree-r (* (sqrt (+ (square lm-cx) (square lm-cy))) 1.5))
-
+(defun landmark-set-landmark-signal-strengths ()
+ (setq landmark-tree-r (* (sqrt (+ (square landmark-cx) (square landmark-cy))) 1.5))
(mapc (lambda (direction)
- (put direction 'r (* lm-cx 1.1)))
- lm-ew)
+ (put direction 'r (* landmark-cx 1.1)))
+ landmark-ew)
(mapc (lambda (direction)
- (put direction 'r (* lm-cy 1.1)))
- lm-ns)
- (put 'lm-tree 'r lm-tree-r))
+ (put direction 'r (* landmark-cy 1.1)))
+ landmark-ns)
+ (put 'landmark-tree 'r landmark-tree-r))
-;;;_ + lm-test-run ()
+;;;_ + landmark-test-run ()
;;;###autoload
-(defalias 'landmark-repeat 'lm-test-run)
+(defalias 'landmark-repeat 'landmark-test-run)
;;;###autoload
-(defun lm-test-run ()
- "Run 100 Lm games, each time saving the weights from the previous game."
+(defun landmark-test-run ()
+ "Run 100 Landmark games, each time saving the weights from the previous game."
(interactive)
-
- (lm 1)
-
+ (landmark 1)
(dotimes (scratch-var 100)
+ (landmark 2)))
- (lm 2)))
-
-
-;;;_ + lm: The function you invoke to play
-
-;;;###autoload
-(defalias 'landmark 'lm)
;;;###autoload
-(defun lm (parg)
- "Start or resume an Lm game.
+(defun landmark (parg)
+ "Start or resume an Landmark game.
If a game is in progress, this command allows you to resume it.
Here is the relation between prefix args and game options:
@@ -1646,37 +1633,37 @@ none / 1 | yes | no
3 | no | yes
4 | no | no
-You start by moving to a square and typing \\[lm-start-robot],
+You start by moving to a square and typing \\[landmark-start-robot],
if you did not use a prefix arg to ask for automatic start.
Use \\[describe-mode] for more info."
(interactive "p")
- (setf lm-n nil lm-m nil)
- (lm-switch-to-window)
+ (setf landmark-n nil landmark-m nil)
+ (landmark-switch-to-window)
(cond
- (lm-emacs-is-computing
- (lm-crash-game))
- ((or (not lm-game-in-progress)
- (<= lm-number-of-moves 2))
- (let ((max-width (lm-max-width))
- (max-height (lm-max-height)))
- (or lm-n (setq lm-n max-width))
- (or lm-m (setq lm-m max-height))
- (cond ((< lm-n 1)
+ (landmark-emacs-is-computing
+ (landmark-crash-game))
+ ((or (not landmark-game-in-progress)
+ (<= landmark-number-of-moves 2))
+ (let ((max-width (landmark-max-width))
+ (max-height (landmark-max-height)))
+ (or landmark-n (setq landmark-n max-width))
+ (or landmark-m (setq landmark-m max-height))
+ (cond ((< landmark-n 1)
(error "I need at least 1 column"))
- ((< lm-m 1)
+ ((< landmark-m 1)
(error "I need at least 1 row"))
- ((> lm-n max-width)
- (error "I cannot display %d columns in that window" lm-n)))
- (if (and (> lm-m max-height)
- (not (eq lm-m lm-saved-board-height))
+ ((> landmark-n max-width)
+ (error "I cannot display %d columns in that window" landmark-n)))
+ (if (and (> landmark-m max-height)
+ (not (eq landmark-m landmark-saved-board-height))
;; Use EQ because SAVED-BOARD-HEIGHT may be nil
- (not (y-or-n-p (format "Do you really want %d rows? " lm-m))))
- (setq lm-m max-height)))
- (if lm-one-moment-please
+ (not (y-or-n-p (format "Do you really want %d rows? " landmark-m))))
+ (setq landmark-m max-height)))
+ (if landmark-one-moment-please
(message "One moment, please..."))
- (lm-start-game lm-n lm-m)
- (eval (cons 'lm-init
+ (landmark-start-game landmark-n landmark-m)
+ (eval (cons 'landmark-init
(cond
((= parg 1) '(t nil))
((= parg 2) '(t t))
diff --git a/lisp/play/life.el b/lisp/play/life.el
index a6b7c783f38..7cdc4136194 100644
--- a/lisp/play/life.el
+++ b/lisp/play/life.el
@@ -1,7 +1,6 @@
;;; life.el --- John Horton Conway's `Life' game for GNU Emacs
-;; Copyright (C) 1988, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1988, 2001-2011 Free Software Foundation, Inc.
;; Author: Kyle Jones <kyleuunet.uu.net>
;; Maintainer: FSF
@@ -163,7 +162,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 +301,4 @@ generations (this defaults to 1)."
(provide 'life)
-;; arch-tag: e9373544-755e-42f5-a9a1-4d4c422bb97a
;;; life.el ends here
diff --git a/lisp/play/meese.el b/lisp/play/meese.el
index 115befa6c35..d811dacb9bc 100644
--- a/lisp/play/meese.el
+++ b/lisp/play/meese.el
@@ -34,5 +34,4 @@
(add-hook 'find-file-hook 'protect-innocence-hook)
(provide 'meese)
-;; arch-tag: 47af12d2-6a7d-4e2e-a1ea-eae75a77e3f0
;;; meese.el ends here
diff --git a/lisp/play/morse.el b/lisp/play/morse.el
index 75fe4a95527..fa0887c0ac5 100644
--- a/lisp/play/morse.el
+++ b/lisp/play/morse.el
@@ -1,7 +1,6 @@
;;; morse.el --- convert text to morse code and back -*- coding: utf-8 -*-
-;; Copyright (C) 1995, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 2001-2011 Free Software Foundation, Inc.
;; Author: Rick Farnbach <rick_farnbach@MENTORG.COM>
;; Keywords: games
@@ -26,6 +25,9 @@
;; Converts text to Morse code and back with M-x morse-region and
;; M-x unmorse-region (though Morse code is no longer official :-().
+;; Converts text to NATO phonetic alphabet and back with M-x
+;; nato-region and M-x denato-region.
+
;;; Code:
(defvar morse-code '(("a" . ".-")
@@ -92,10 +94,64 @@
("@" . ".--.-."))
"Morse code character set.")
+(defvar nato-alphabet '(("a" . "Alfa")
+ ("b" . "Bravo")
+ ("c" . "Charlie")
+ ("d" . "Delta")
+ ("e" . "Echo")
+ ("f" . "Foxtrot")
+ ("g" . "Golf")
+ ("h" . "Hotel")
+ ("i" . "India")
+ ("j" . "Juliett")
+ ("k" . "Kilo")
+ ("l" . "Lima")
+ ("m" . "Mike")
+ ("n" . "November")
+ ("o" . "Oscar")
+ ("p" . "Papa")
+ ("q" . "Quebec")
+ ("r" . "Romeo")
+ ("s" . "Sierra")
+ ("t" . "Tango")
+ ("u" . "Uniform")
+ ("v" . "Victor")
+ ("w" . "Whiskey")
+ ("x" . "Xray")
+ ("y" . "Yankee")
+ ("z" . "Zulu")
+ ;; Numbers
+ ("0" . "Zero")
+ ("1" . "One")
+ ("2" . "Two")
+ ("3" . "Three")
+ ("4" . "Four")
+ ("5" . "Five")
+ ("6" . "Six")
+ ("7" . "Seven")
+ ("8" . "Eight")
+ ("9" . "Niner")
+ ;; Punctuation is not part of standard
+ ("=" . "Equals")
+ ("?" . "Query")
+ ("/" . "Slash")
+ ("," . "Comma")
+ ("." . "Stop")
+ (":" . "Colon")
+ ("'" . "Apostrophe")
+ ("-" . "Dash")
+ ("(" . "Open")
+ (")" . "Close")
+ ("@" . "At"))
+ "NATO phonetic alphabet.
+See ''International Code of Signals'' (INTERCO), United States
+Edition, 1969 Edition (Revised 2003) available from National
+Geospatial-Intelligence Agency at http://www.nga.mil/")
+
;;;###autoload
(defun morse-region (beg end)
"Convert all text in a given region to morse code."
- (interactive "r")
+ (interactive "*r")
(if (integerp end)
(setq end (copy-marker end)))
(save-excursion
@@ -118,7 +174,7 @@
;;;###autoload
(defun unmorse-region (beg end)
"Convert morse coded text in region to ordinary ASCII text."
- (interactive "r")
+ (interactive "*r")
(if (integerp end)
(setq end (copy-marker end)))
(save-excursion
@@ -137,7 +193,53 @@
(if (looking-at "/")
(delete-char 1))))))))
+;;;###autoload
+(defun nato-region (beg end)
+ "Convert all text in a given region to NATO phonetic alphabet."
+ ;; Copied from morse-region. -- ashawley 2009-02-10
+ (interactive "*r")
+ (if (integerp end)
+ (setq end (copy-marker end)))
+ (save-excursion
+ (let ((sep "")
+ str nato)
+ (goto-char beg)
+ (while (< (point) end)
+ (setq str (downcase (buffer-substring (point) (1+ (point)))))
+ (cond ((looking-at "\\s-+")
+ (goto-char (match-end 0))
+ (setq sep ""))
+ ((setq nato (assoc str nato-alphabet))
+ (delete-char 1)
+ (insert sep (cdr nato))
+ (setq sep "-"))
+ (t
+ (forward-char 1)
+ (setq sep "")))))))
+
+;;;###autoload
+(defun denato-region (beg end)
+ "Convert NATO phonetic alphabet in region to ordinary ASCII text."
+ ;; Copied from unmorse-region. -- ashawley 2009-02-10
+ (interactive "*r")
+ (if (integerp end)
+ (setq end (copy-marker end)))
+ (save-excursion
+ (let (str paren nato)
+ (goto-char beg)
+ (while (< (point) end)
+ (if (null (looking-at "[a-z]+"))
+ (forward-char 1)
+ (setq str (buffer-substring (match-beginning 0) (match-end 0)))
+ (if (null (setq nato (rassoc (capitalize str) nato-alphabet)))
+ (goto-char (match-end 0))
+ (replace-match
+ (if (string-equal "(" (car nato))
+ (if (setq paren (null paren)) "(" ")")
+ (car nato)) t)
+ (if (looking-at "-")
+ (delete-char 1))))))))
+
(provide 'morse)
-;; arch-tag: 3331e6c1-9a9e-453f-abfd-163a9c3f93a6
;;; morse.el ends here
diff --git a/lisp/play/mpuz.el b/lisp/play/mpuz.el
index 4c6d66b27ae..3e1659628f4 100644
--- a/lisp/play/mpuz.el
+++ b/lisp/play/mpuz.el
@@ -1,7 +1,6 @@
;;; mpuz.el --- multiplication puzzle for GNU Emacs
-;; Copyright (C) 1990, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990, 2001-2011 Free Software Foundation, Inc.
;; Author: Philippe Schnoebelen <phs@lsv.ens-cachan.fr>
;; Overhauled: Daniel Pfeiffer <occitan@esperanto.org>
@@ -406,7 +405,7 @@ You may abort a game by typing \\<mpuz-mode-map>\\[mpuz-offer-abort]."
"Propose a digit for a letter in puzzle."
(interactive)
(if mpuz-in-progress
- (let (letter-char digit digit-char message)
+ (let (letter-char digit digit-char)
(setq letter-char (upcase last-command-event)
digit (mpuz-to-digit (- letter-char ?A)))
(cond ((mpuz-digit-solved-p digit)
@@ -435,8 +434,7 @@ You may abort a game by typing \\<mpuz-mode-map>\\[mpuz-offer-abort]."
"Propose LETTER-CHAR as code for DIGIT-CHAR."
(let* ((letter (- letter-char ?A))
(digit (- digit-char ?0))
- (correct-digit (mpuz-to-digit letter))
- (game mpuz-nb-completed-games))
+ (correct-digit (mpuz-to-digit letter)))
(cond ((mpuz-digit-solved-p correct-digit)
(message "%c has already been found." (+ correct-digit ?0)))
((mpuz-digit-solved-p digit)
@@ -499,5 +497,4 @@ You may abort a game by typing \\<mpuz-mode-map>\\[mpuz-offer-abort]."
(provide 'mpuz)
-;; arch-tag: 2781d6ba-89e7-43b5-85c7-5d3a2e73feb1
;;; mpuz.el ends here
diff --git a/lisp/play/pong.el b/lisp/play/pong.el
index a697e27ae7d..e993e769756 100644
--- a/lisp/play/pong.el
+++ b/lisp/play/pong.el
@@ -1,7 +1,6 @@
;;; pong.el --- classical implementation of pong
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Benjamin Drieu <bdrieu@april.org>
;; Keywords: games
@@ -191,21 +190,23 @@
;;; Initialize maps
(defvar pong-mode-map
- (make-sparse-keymap 'pong-mode-map) "Modemap for pong-mode.")
+ (let ((map (make-sparse-keymap 'pong-mode-map)))
+ (define-key map [left] 'pong-move-left)
+ (define-key map [right] 'pong-move-right)
+ (define-key map [up] 'pong-move-up)
+ (define-key map [down] 'pong-move-down)
+ (define-key map pong-left-key 'pong-move-left)
+ (define-key map pong-right-key 'pong-move-right)
+ (define-key map pong-up-key 'pong-move-up)
+ (define-key map pong-down-key 'pong-move-down)
+ (define-key map pong-quit-key 'pong-quit)
+ (define-key map pong-pause-key 'pong-pause)
+ map)
+ "Modemap for pong-mode.")
(defvar pong-null-map
(make-sparse-keymap 'pong-null-map) "Null map for pong-mode.")
-(define-key pong-mode-map [left] 'pong-move-left)
-(define-key pong-mode-map [right] 'pong-move-right)
-(define-key pong-mode-map [up] 'pong-move-up)
-(define-key pong-mode-map [down] 'pong-move-down)
-(define-key pong-mode-map pong-left-key 'pong-move-left)
-(define-key pong-mode-map pong-right-key 'pong-move-right)
-(define-key pong-mode-map pong-up-key 'pong-move-up)
-(define-key pong-mode-map pong-down-key 'pong-move-down)
-(define-key pong-mode-map pong-quit-key 'pong-quit)
-(define-key pong-mode-map pong-pause-key 'pong-pause)
;;; Fun stuff -- The code
@@ -458,5 +459,4 @@ pong-mode keybindings:\\<pong-mode-map>
(provide 'pong)
-;; arch-tag: 1fdf0fc5-13e2-4de4-aae4-09bdd5af99f3
;;; pong.el ends here
diff --git a/lisp/play/snake.el b/lisp/play/snake.el
index 7716ab6bb77..418c898e825 100644
--- a/lisp/play/snake.el
+++ b/lisp/play/snake.el
@@ -1,7 +1,6 @@
;;; snake.el --- implementation of Snake for Emacs
-;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Glynn Clements <glynn@sensei.co.uk>
;; Created: 1997-09-10
@@ -175,21 +174,22 @@ and then start moving it leftwards.")
;; ;;;;;;;;;;;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar snake-mode-map
- (make-sparse-keymap 'snake-mode-map))
+ (let ((map (make-sparse-keymap 'snake-mode-map)))
-(define-key snake-mode-map "n" 'snake-start-game)
-(define-key snake-mode-map "q" 'snake-end-game)
-(define-key snake-mode-map "p" 'snake-pause-game)
+ (define-key map "n" 'snake-start-game)
+ (define-key map "q" 'snake-end-game)
+ (define-key map "p" 'snake-pause-game)
-(define-key snake-mode-map [left] 'snake-move-left)
-(define-key snake-mode-map [right] 'snake-move-right)
-(define-key snake-mode-map [up] 'snake-move-up)
-(define-key snake-mode-map [down] 'snake-move-down)
+ (define-key map [left] 'snake-move-left)
+ (define-key map [right] 'snake-move-right)
+ (define-key map [up] 'snake-move-up)
+ (define-key map [down] 'snake-move-down)
+ map))
(defvar snake-null-map
- (make-sparse-keymap 'snake-null-map))
-
-(define-key snake-null-map "n" 'snake-start-game)
+ (let ((map (make-sparse-keymap 'snake-null-map)))
+ (define-key map "n" 'snake-start-game)
+ map))
;; ;;;;;;;;;;;;;;;; game functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -412,5 +412,4 @@ Snake mode keybindings:
(provide 'snake)
-;; arch-tag: 512ffc92-cfac-4287-9a4e-92890701a5c8
;;; snake.el ends here
diff --git a/lisp/play/solitaire.el b/lisp/play/solitaire.el
index 51d32740ca3..722c3b43033 100644
--- a/lisp/play/solitaire.el
+++ b/lisp/play/solitaire.el
@@ -1,7 +1,6 @@
;;; solitaire.el --- game of solitaire in Emacs Lisp
-;; Copyright (C) 1994, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 2001-2011 Free Software Foundation, Inc.
;; Author: Jan Schormann <Jan.Schormann@rechen-gilde.de>
;; Created: Fri afternoon, Jun 3, 1994
@@ -44,7 +43,7 @@
(defvar solitaire-mode-map
(let ((map (make-sparse-keymap)))
- (suppress-keymap map t)
+ (set-keymap-parent map special-mode-map)
(define-key map "\C-f" 'solitaire-right)
(define-key map "\C-b" 'solitaire-left)
@@ -53,7 +52,6 @@
(define-key map "\r" 'solitaire-move)
(define-key map [remap undo] 'solitaire-undo)
(define-key map " " 'solitaire-do-check)
- (define-key map "q" 'quit-window)
(define-key map [right] 'solitaire-right)
(define-key map [left] 'solitaire-left)
@@ -89,7 +87,7 @@
;; Solitaire mode is suitable only for specially formatted data.
(put 'solitaire-mode 'mode-class 'special)
-(define-derived-mode solitaire-mode nil "Solitaire"
+(define-derived-mode solitaire-mode special-mode "Solitaire"
"Major mode for playing Solitaire.
To learn how to play Solitaire, see the documentation for function
`solitaire'.
@@ -128,7 +126,7 @@ the game is over, or off, if you are working on a slow machine."
'(solitaire-left solitaire-right solitaire-up solitaire-down))
;;;###autoload
-(defun solitaire (arg)
+(defun solitaire (_arg)
"Play Solitaire.
To play Solitaire, type \\[solitaire].
@@ -198,15 +196,15 @@ Pick your favourite shortcuts:
(interactive "P")
(switch-to-buffer "*Solitaire*")
- (solitaire-mode)
- (setq buffer-read-only t)
- (setq solitaire-stones 32)
- (solitaire-insert-board)
- (solitaire-build-modeline)
- (goto-char (point-max))
- (setq solitaire-center (search-backward "."))
- (setq buffer-undo-list (list (point)))
- (set-buffer-modified-p nil))
+ (let ((inhibit-read-only t))
+ (solitaire-mode)
+ (setq buffer-read-only t)
+ (setq solitaire-stones 32)
+ (solitaire-insert-board)
+ (solitaire-build-modeline)
+ (goto-char (point-max))
+ (setq solitaire-center (search-backward "."))
+ (setq buffer-undo-list (list (point)))))
(defun solitaire-build-modeline ()
(setq mode-line-format
@@ -395,7 +393,7 @@ which a stone will be taken away) and target."
solitaire-valid-directions)))
count))))
-(defun solitaire-do-check (&optional arg)
+(defun solitaire-do-check (&optional _arg)
"Check for any possible moves in Solitaire."
(interactive "P")
(let ((moves (solitaire-check)))
@@ -447,5 +445,4 @@ Seen in info on text lines."
(provide 'solitaire)
-;; arch-tag: 1b18ee1c-1e79-4a5b-8658-9560b82e63dd
;;; solitaire.el ends here
diff --git a/lisp/play/spook.el b/lisp/play/spook.el
index d96e6159cbf..6cab994a9cc 100644
--- a/lisp/play/spook.el
+++ b/lisp/play/spook.el
@@ -1,7 +1,6 @@
;;; spook.el --- spook phrase utility for overloading the NSA line eater
-;; Copyright (C) 1988, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1988, 1993, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: games
@@ -76,5 +75,4 @@
(provide 'spook)
-;; arch-tag: c682b61f-92b6-4492-9c0d-2367e562449c
;;; spook.el ends here
diff --git a/lisp/play/studly.el b/lisp/play/studly.el
index b9bd173d5f1..d28304df1e5 100644
--- a/lisp/play/studly.el
+++ b/lisp/play/studly.el
@@ -68,5 +68,4 @@
(provide 'studly)
-;; arch-tag: 0dbf5a60-d2e6-48c2-86ae-77fc8575ac67
;;; studly.el ends here
diff --git a/lisp/play/tetris.el b/lisp/play/tetris.el
index ae7ad02cb7e..053b07adfc7 100644
--- a/lisp/play/tetris.el
+++ b/lisp/play/tetris.el
@@ -1,7 +1,6 @@
;;; tetris.el --- implementation of Tetris for Emacs
-;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Glynn Clements <glynn@sensei.co.uk>
;; Version: 2.01
@@ -35,7 +34,7 @@
;; ;;;;;;;;;;;;; customization variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgroup tetris nil
- "Play a game of tetris."
+ "Play a game of Tetris."
:prefix "tetris-"
:group 'games)
@@ -61,10 +60,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 +75,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 +94,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,57 +193,50 @@ 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)
(defconst tetris-space 9)
-(defun tetris-default-update-speed-function (shapes rows)
+(defun tetris-default-update-speed-function (_shapes rows)
(/ 20.0 (+ 50.0 rows)))
;; ;;;;;;;;;;;;; variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -274,22 +264,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 +289,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 +310,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 +351,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 +500,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 +533,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 +573,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 +583,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 +601,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 +629,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)
@@ -654,5 +640,4 @@ tetris-mode keybindings:
(provide 'tetris)
-;; arch-tag: fb780d53-3ff0-49f0-8e19-f7f13cf2d49e
;;; tetris.el ends here
diff --git a/lisp/play/yow.el b/lisp/play/yow.el
index 6d5be50cbf6..d75e04eb74f 100644
--- a/lisp/play/yow.el
+++ b/lisp/play/yow.el
@@ -1,7 +1,6 @@
;;; yow.el --- quote random zippyisms
-;; Copyright (C) 1993, 1994, 1995, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1995, 2000-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Author: Richard Mlynarik
@@ -128,5 +127,4 @@ If called interactively, display a list of matches."
(provide 'yow)
-;; arch-tag: d13db89b-84f1-4141-a5ce-261d1733a65c
;;; yow.el ends here
diff --git a/lisp/play/zone.el b/lisp/play/zone.el
index 27c715b7ceb..d194a8af919 100644
--- a/lisp/play/zone.el
+++ b/lisp/play/zone.el
@@ -1,7 +1,6 @@
;;; zone.el --- idle display hacks
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Author: Victor Zandy <zandy@cs.wisc.edu>
;; Maintainer: Thien-Thi Nguyen <ttn@gnu.org>
@@ -40,10 +39,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 +205,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 +344,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 +354,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 +394,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 +438,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 +464,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 +579,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)"))
@@ -635,6 +626,8 @@ If the element is a function or a list of a function and a number,
"*Seconds to wait between successive `life' generations.
If nil, `zone-pgm-random-life' chooses a value from 0-3 (inclusive).")
+(defvar life-patterns) ; from life.el
+
(defun zone-pgm-random-life ()
(require 'life)
(zone-fill-out-screen (1- (window-width)) (1- (window-height)))
@@ -673,7 +666,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))
@@ -691,5 +685,4 @@ If nil, `zone-pgm-random-life' chooses a value from 0-3 (inclusive).")
;;;;;;;;;;;;;;;
(provide 'zone)
-;; arch-tag: 7092503d-74a9-4325-a55c-a026ede58cea
;;; zone.el ends here
diff --git a/lisp/printing.el b/lisp/printing.el
index 60e93308e59..e66cca25933 100644
--- a/lisp/printing.el
+++ b/lisp/printing.el
@@ -1,7 +1,6 @@
;;; printing.el --- printing utilities
-;; Copyright (C) 2000, 2001, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
-;; 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2001, 2003-2011 Free Software Foundation, Inc.
;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
@@ -1387,20 +1386,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 +1407,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
@@ -5723,8 +5707,8 @@ If menu binding was not done, calls `pr-menu-bind'."
(let* ((dir-name (file-name-directory (or (buffer-file-name)
default-directory)))
(fmt-prompt (concat "%s[" mess "] Directory to print: "))
- (dir (read-file-name (format fmt-prompt "")
- "" dir-name nil dir-name))
+ (dir (read-directory-name (format fmt-prompt "")
+ "" dir-name nil dir-name))
prompt)
(while (cond ((not (file-directory-p dir))
(ding)
@@ -5734,8 +5718,8 @@ If menu binding was not done, calls `pr-menu-bind'."
(setq prompt "Directory is unreadable! "))
(t nil))
(setq dir-name (file-name-directory dir)
- dir (read-file-name (format fmt-prompt prompt)
- "" dir-name nil dir-name)))
+ dir (read-directory-name (format fmt-prompt prompt)
+ "" dir-name nil dir-name)))
(file-name-as-directory dir)))
diff --git a/lisp/proced.el b/lisp/proced.el
index 8ed30a79681..ddc4ed1db14 100644
--- a/lisp/proced.el
+++ b/lisp/proced.el
@@ -1,6 +1,6 @@
;;; proced.el --- operate on system processes like dired
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Roland Winkler <winkler@gnu.org>
;; Keywords: Processes, Unix
@@ -1676,7 +1676,7 @@ After updating a displayed Proced buffer run the normal hook
(message (if revert "Updating process information...done."
"Updating process display...done.")))))
-(defun proced-revert (&rest args)
+(defun proced-revert (&rest _args)
"Reevaluate the process listing based on the currently running processes.
Preserves point and marks."
(proced-update t))
@@ -1770,7 +1770,7 @@ After sending the signal, this command runs the normal hook
(number-to-string signal) signal))))
(dolist (process process-alist)
(with-temp-buffer
- (condition-case err
+ (condition-case nil
(if (zerop (call-process
proced-signal-function nil t nil
signal (number-to-string (car process))))
@@ -1880,5 +1880,4 @@ Killed processes cannot be recovered by Emacs."))
(provide 'proced)
-;; arch-tag: a6e312ad-9032-45aa-972d-31a8cfc545af
;;; proced.el ends here
diff --git a/lisp/progmodes/ada-mode.el b/lisp/progmodes/ada-mode.el
index 1e27e7be457..89a37307506 100644
--- a/lisp/progmodes/ada-mode.el
+++ b/lisp/progmodes/ada-mode.el
@@ -1,7 +1,6 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1995, 1997-2011 Free Software Foundation, Inc.
;; Author: Rolf Ebert <ebert@inf.enst.fr>
;; Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de>
@@ -460,6 +459,7 @@ The extensions should include a `.' if needed.")
(defvar ada-mode-abbrev-table nil
"Local abbrev table for Ada mode.")
+(define-abbrev-table 'ada-mode-abbrev-table ())
(defvar ada-mode-syntax-table nil
"Syntax table to be used for editing Ada source code.")
@@ -834,10 +834,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 +934,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, #...#
@@ -963,7 +966,7 @@ are treated as numbers instead of gnatprep comments."
(unless modified
(restore-buffer-modified-p nil))))
-(defun ada-after-change-function (beg end old-len)
+(defun ada-after-change-function (beg end _old-len)
"Called when the region between BEG and END was changed in the buffer.
OLD-LEN indicates what the length of the replaced text was."
(save-excursion
@@ -991,6 +994,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,21 +1117,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 ()
+(define-derived-mode ada-mode prog-mode "Ada"
"Ada mode is the major mode for editing Ada code."
- (interactive)
- (kill-all-local-variables)
-
- (set-syntax-table ada-mode-syntax-table)
-
- (set (make-local-variable 'require-final-newline) mode-require-final-newline)
-
;; Set the paragraph delimiters so that one can select a whole block
;; simply with M-h
(set (make-local-variable 'paragraph-start) "[ \t\n\f]*$")
@@ -1161,9 +1159,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 +1184,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)
@@ -1291,62 +1294,54 @@ the file name."
(define-key ada-mode-map ada-popup-key 'ada-popup-menu))
;; Support for Abbreviations (the user still need to "M-x abbrev-mode"
- (define-abbrev-table 'ada-mode-abbrev-table ())
(setq local-abbrev-table ada-mode-abbrev-table)
;; Support for which-function mode
- (make-local-variable 'which-func-functions)
- (setq which-func-functions '(ada-which-function))
+ (set (make-local-variable 'which-func-functions) '(ada-which-function))
;; Support for indent-new-comment-line (Especially for XEmacs)
(set (make-local-variable 'comment-multi-line) nil)
;; Support for add-log
- (set (make-local-variable 'add-log-current-defun-function) 'ada-which-function)
-
- (setq major-mode 'ada-mode
- mode-name "Ada")
-
- (use-local-map ada-mode-map)
+ (set (make-local-variable 'add-log-current-defun-function)
+ 'ada-which-function)
(easy-menu-add ada-mode-menu ada-mode-map)
- (set-syntax-table ada-mode-syntax-table)
-
(set (make-local-variable 'skeleton-further-elements)
'((< '(backward-delete-char-untabify
(min ada-indent (current-column))))))
(add-hook 'skeleton-end-hook 'ada-adjust-case-skeleton nil t)
- (run-mode-hooks 'ada-mode-hook)
-
;; 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 "-- "))
-
- ;; Run this after the hook to give the users a chance to activate
- ;; font-lock-mode
-
- (unless (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
-
- (cond ((eq ada-language-version 'ada83)
- (setq ada-keywords ada-83-keywords))
- ((eq ada-language-version 'ada95)
- (setq ada-keywords ada-95-keywords))
- ((eq ada-language-version 'ada2005)
- (setq ada-keywords ada-2005-keywords)))
-
- (if ada-auto-case
- (ada-activate-keys-for-case)))
+ (add-hook 'hack-local-variables-hook
+ (lambda ()
+ (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 (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))
+
+ ;; FIXME: ada-language-version might be set in the mode
+ ;; hook or it might even be set later on via file-local
+ ;; vars, so ada-keywords should be set lazily.
+ (cond ((eq ada-language-version 'ada83)
+ (setq ada-keywords ada-83-keywords))
+ ((eq ada-language-version 'ada95)
+ (setq ada-keywords ada-95-keywords))
+ ((eq ada-language-version 'ada2005)
+ (setq ada-keywords ada-2005-keywords)))
+
+ (if ada-auto-case
+ (ada-activate-keys-for-case)))
+ nil 'local))
(defun ada-adjust-case-skeleton ()
"Adjust the case of the text inserted by a skeleton."
@@ -1397,25 +1392,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 +1416,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 +1453,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 +1622,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 +1654,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
@@ -1693,7 +1675,7 @@ ARG is the prefix the user entered with \\[universal-argument]."
'( ?` ?_ ?# ?% ?& ?* ?( ?) ?- ?= ?+
?| ?\; ?: ?' ?\" ?< ?, ?. ?> ?/ ?\n 32 ?\r )))
-(defun ada-loose-case-word (&optional arg)
+(defun ada-loose-case-word (&optional _arg)
"Upcase first letter and letters following `_' in the following word.
No other letter is modified.
ARG is ignored, and is there for compatibility with `capitalize-word' only."
@@ -1709,7 +1691,7 @@ ARG is ignored, and is there for compatibility with `capitalize-word' only."
(insert-char (upcase (following-char)) 1)
(delete-char 1)))))
-(defun ada-no-auto-case (&optional arg)
+(defun ada-no-auto-case (&optional _arg)
"Do nothing. ARG is ignored.
This function can be used for the auto-casing variables in Ada mode, to
adapt to unusal auto-casing schemes. Since it does nothing, you can for
@@ -1718,7 +1700,7 @@ auto-casing for identifiers, whereas keywords have to be lower-cased.
See also `ada-auto-case' to disable auto casing altogether."
nil)
-(defun ada-capitalize-word (&optional arg)
+(defun ada-capitalize-word (&optional _arg)
"Upcase first letter and letters following '_', lower case other letters.
ARG is ignored, and is there for compatibility with `capitalize-word' only."
(interactive)
@@ -1735,44 +1717,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 +1782,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 +2158,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 +2173,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 +2212,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 +2453,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 +2477,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 +2498,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 +2560,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 +2579,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 +4008,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 +4018,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)
@@ -4264,7 +4219,7 @@ of the region. Otherwise, operate only on the current line."
((eq ada-tab-policy 'always-tab) (error "Not implemented"))
))
-(defun ada-untab (arg)
+(defun ada-untab (_arg)
"Delete leading indenting according to `ada-tab-policy'."
;; FIXME: ARG is ignored
(interactive "P")
@@ -4290,16 +4245,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 +4349,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)
- )
+ decl-start)
+ (with-syntax-table ada-mode-symbol-syntax-table
- ;; 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))
+ (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."
@@ -4675,7 +4613,7 @@ Moves to 'begin' if in a declarative part."
["Gdb Documentation" (info "gdb")
(eq ada-which-compiler 'gnat)]
["Ada95 Reference Manual" (info "arm95") t])
- ("Options" :included (eq major-mode 'ada-mode)
+ ("Options" :included (derived-mode-p 'ada-mode)
["Auto Casing" (setq ada-auto-case (not ada-auto-case))
:style toggle :selected ada-auto-case]
["Auto Indent After Return"
@@ -4712,7 +4650,7 @@ Moves to 'begin' if in a declarative part."
["Load..." ada-set-default-project-file t]
["New..." ada-prj-new t]
["Edit..." ada-prj-edit t])
- ("Goto" :included (eq major-mode 'ada-mode)
+ ("Goto" :included (derived-mode-p 'ada-mode)
["Goto Declaration/Body" ada-goto-declaration
(eq ada-which-compiler 'gnat)]
["Goto Body" ada-goto-body
@@ -4741,7 +4679,7 @@ Moves to 'begin' if in a declarative part."
["-" nil nil]
["Other File" ff-find-other-file t]
["Other File Other Window" ada-ff-other-window t])
- ("Edit" :included (eq major-mode 'ada-mode)
+ ("Edit" :included (derived-mode-p 'ada-mode)
["Search File On Source Path" ada-find-file t]
["------" nil nil]
["Complete Identifier" ada-complete-identifier t]
@@ -4773,7 +4711,7 @@ Moves to 'begin' if in a declarative part."
["-----" nil nil]
["Narrow to subprogram" ada-narrow-to-defun t])
("Templates"
- :included (eq major-mode 'ada-mode)
+ :included (derived-mode-p 'ada-mode)
["Header" ada-header t]
["-" nil nil]
["Package Body" ada-package-body t]
@@ -4818,7 +4756,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 +4978,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)))
@@ -5312,7 +5250,7 @@ Return nil if no body was found."
;; Support for narrow-to-region
;; ---------------------------------------------------------
-(defun ada-narrow-to-defun (&optional arg)
+(defun ada-narrow-to-defun (&optional _arg)
"Make text outside current subprogram invisible.
The subprogram visible is the one that contains or follow point.
Optional ARG is ignored.
@@ -5324,11 +5262,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 +5504,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 1bae7b4a15e..a32e22828fc 100644
--- a/lisp/progmodes/ada-prj.el
+++ b/lisp/progmodes/ada-prj.el
@@ -1,11 +1,11 @@
;;; ada-prj.el --- GUI editing of project files for the ada-mode
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; 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.
@@ -92,7 +92,7 @@ If there is none, opens a new project file."
(ada-customize)
(ada-prj-new)))
-(defun ada-prj-initialize-values (symbol ada-buffer filename)
+(defun ada-prj-initialize-values (symbol _ada-buffer filename)
"Set SYMBOL to the property list of the project file FILENAME.
If FILENAME is null, read the file associated with ADA-BUFFER.
If no project file is found, return the default values."
@@ -195,21 +195,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."
@@ -231,7 +227,7 @@ If FILE-NAME is nil, ask the user for the name."
;; the user to select a directory
(let ((use-dialog-box nil))
(unless file-name
- (set 'file-name (read-file-name "Root directory: " nil nil t))))
+ (set 'file-name (read-directory-name "Root directory: " nil nil t))))
(set 'ada-prj-current-values
(plist-put ada-prj-current-values
@@ -261,19 +257,19 @@ The current buffer must be the project editing buffer."
(widget-insert "\n Project configuration.\n
___________ ____________ ____________ ____________ ____________\n / ")
(widget-create 'push-button :notify
- (lambda (&rest dummy) (ada-prj-display-page 1)) "General")
+ (lambda (&rest _dummy) (ada-prj-display-page 1)) "General")
(widget-insert " \\ / ")
(widget-create 'push-button :notify
- (lambda (&rest dummy) (ada-prj-display-page 2)) "Paths")
+ (lambda (&rest _dummy) (ada-prj-display-page 2)) "Paths")
(widget-insert " \\ / ")
(widget-create 'push-button :notify
- (lambda (&rest dummy) (ada-prj-display-page 3)) "Switches")
+ (lambda (&rest _dummy) (ada-prj-display-page 3)) "Switches")
(widget-insert " \\ / ")
(widget-create 'push-button :notify
- (lambda (&rest dummy) (ada-prj-display-page 4)) "Ada Menu")
+ (lambda (&rest _dummy) (ada-prj-display-page 4)) "Ada Menu")
(widget-insert " \\ / ")
(widget-create 'push-button :notify
- (lambda (&rest dummy) (ada-prj-display-page 5)) "Debugger")
+ (lambda (&rest _dummy) (ada-prj-display-page 5)) "Debugger")
(widget-insert " \\\n")
;; Display the currently selected page
@@ -462,15 +458,15 @@ connect to the target when working with cross-environments" t)
(widget-insert "______________________________________________________________________\n\n ")
(widget-create 'push-button
- :notify (lambda (&rest ignore)
+ :notify (lambda (&rest _ignore)
(setq ada-prj-current-values (ada-default-prj-properties))
(ada-prj-display-page 1))
"Reset to Default Values")
(widget-insert " ")
- (widget-create 'push-button :notify (lambda (&rest ignore) (kill-buffer nil))
+ (widget-create 'push-button :notify (lambda (&rest _ignore) (kill-buffer nil))
"Cancel")
(widget-insert " ")
- (widget-create 'push-button :notify (lambda (&rest ignore) (ada-prj-save))
+ (widget-create 'push-button :notify (lambda (&rest _ignore) (ada-prj-save))
"Save")
(widget-insert "\n\n")
@@ -517,11 +513,18 @@ If FILENAME is given, edit that file."
(set (make-local-variable 'ada-prj-ada-buffer) ada-buffer)
- (use-local-map (copy-keymap custom-mode-map))
- (local-set-key "\C-x\C-s" 'ada-prj-save)
+ (use-local-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map custom-mode-map)
+ (define-key map "\C-x\C-s" 'ada-prj-save)
+ map))
- (make-local-variable 'widget-keymap)
- (define-key widget-keymap "\C-x\C-s" 'ada-prj-save)
+ ;; FIXME: Not sure if this works!!
+ (set (make-local-variable 'widget-keymap)
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map widget-keymap)
+ (define-key map "\C-x\C-s" 'ada-prj-save)
+ map))
(set (make-local-variable 'ada-old-cross-prefix)
(ada-xref-get-project-field 'cross-prefix))
@@ -543,7 +546,7 @@ converted to a directory name."
ada-list "\n"))
-(defun ada-prj-field-modified (widget &rest dummy)
+(defun ada-prj-field-modified (widget &rest _dummy)
"Callback for modification of WIDGET.
Remaining args DUMMY are ignored.
Save the change in `ada-prj-current-values' so that selecting
@@ -553,7 +556,7 @@ another page and coming back keeps the new value."
(widget-get widget ':prj-field)
(widget-value widget))))
-(defun ada-prj-display-help (widget widget-modified event)
+(defun ada-prj-display-help (widget _widget-modified event)
"Callback for help button in WIDGET.
Parameters WIDGET-MODIFIED, EVENT match :notify for the widget."
(let ((text (widget-get widget 'prj-help)))
@@ -567,10 +570,9 @@ 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)
+(defun ada-prj-show-value (widget _widget-modified event)
"Show the current field value in WIDGET.
Parameters WIDGET-MODIFIED, EVENT match :notify for the widget."
(let* ((field (widget-get widget ':prj-field))
@@ -680,5 +682,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 64088a2980e..e48055c9f50 100644
--- a/lisp/progmodes/ada-stmt.el
+++ b/lisp/progmodes/ada-stmt.el
@@ -1,14 +1,13 @@
;;; ada-stmt.el --- an extension to Ada mode for inserting statement templates
-;; Copyright (C) 1987, 1993, 1994, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1987, 1993-1994, 1996-2011 Free Software Foundation, Inc.
;; Authors: Daniel Pfeiffer
;; Markus Heritsch
;; 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.
@@ -483,5 +482,4 @@ Invoke right after `ada-function-spec' or `ada-procedure-spec'."
(provide 'ada-stmt)
-;; arch-tag: 94f51555-cc0e-44e5-8865-8788aae8ecd3
;;; ada-stmt.el ends here
diff --git a/lisp/progmodes/ada-xref.el b/lisp/progmodes/ada-xref.el
index ad1e32ab49a..7751f3e98fc 100644
--- a/lisp/progmodes/ada-xref.el
+++ b/lisp/progmodes/ada-xref.el
@@ -1,13 +1,13 @@
;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-2011 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 +108,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 +165,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 +220,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 +323,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 +337,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 +380,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 +394,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 +766,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 +780,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 +1014,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))
@@ -1044,7 +1043,7 @@ existing buffer `*gnatfind*', if there is one."
(setq old-contents (buffer-string))))
(let ((compilation-error "reference"))
- (compilation-start command 'compilation-mode (lambda (mode) ada-gnatfind-buffer-name)))
+ (compilation-start command 'compilation-mode (lambda (_mode) ada-gnatfind-buffer-name)))
;; Hide the "Compilation" menu
(with-current-buffer ada-gnatfind-buffer-name
@@ -1385,7 +1384,7 @@ project file."
;; Do not add -fullname, since we can have a 'rsh' command in front.
;; FIXME: This is evil but luckily a nop under Emacs-21.3.50 ! -stef
- (fset 'gud-gdb-massage-args (lambda (file args) args))
+ (fset 'gud-gdb-massage-args (lambda (_file args) args))
(set 'pre-cmd (mapconcat 'identity pre-cmd ada-command-separator))
(if (not (equal pre-cmd ""))
@@ -1817,7 +1816,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 +2378,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 848c476fd3a..d1ff1aead10 100644
--- a/lisp/progmodes/antlr-mode.el
+++ b/lisp/progmodes/antlr-mode.el
@@ -1,11 +1,10 @@
;;; antlr-mode.el --- major mode for ANTLR grammar files
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; 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.
@@ -83,17 +82,18 @@
;;; Code:
-(eval-when-compile
+(eval-when-compile
(require 'cl))
(require 'easymenu)
+(require 'cc-mode)
;; Just to get the rid of the byte compiler warning. The code for
;; this function and its friends are too complex for their own good.
(declare-function cond-emacs-xemacs-macfn "antlr-mode" (args &optional msg))
;; General Emacs/XEmacs-compatibility compile-time macros
-(eval-when-compile
+(eval-when-compile
(defmacro cond-emacs-xemacs (&rest args)
(cond-emacs-xemacs-macfn
args "`cond-emacs-xemacs' must return exactly one element"))
@@ -1004,12 +1004,21 @@ The SYNTAX-ALIST element is also used to initialize
(defvar antlr-mode-hook nil
"Hook called by `antlr-mode'.")
-(defvar antlr-mode-syntax-table nil
+(defvar antlr-mode-syntax-table
+ (let ((st (make-syntax-table)))
+ (c-populate-syntax-table st)
+ st)
"Syntax table used in `antlr-mode' buffers.
If non-nil, it will be initialized in `antlr-mode'.")
;; used for "in Java/C++ code" = syntactic-depth>0
-(defvar antlr-action-syntax-table nil
+(defvar antlr-action-syntax-table
+ (let ((st (copy-syntax-table antlr-mode-syntax-table))
+ (slist (nth 3 antlr-font-lock-defaults)))
+ (while slist
+ (modify-syntax-entry (caar slist) (cdar slist) st)
+ (setq slist (cdr slist)))
+ st)
"Syntax table used for ANTLR action parsing.
Initialized by `antlr-mode-syntax-table', changed by SYNTAX-ALIST in
`antlr-font-lock-defaults'. This table should be selected if you use
@@ -1064,7 +1073,7 @@ Used for `antlr-slow-syntactic-context'.")
(read-from-minibuffer prompt initial-input nil nil
(or history 'shell-command-history)))
-(defunx antlr-with-displaying-help-buffer (thunk &optional name)
+(defunx antlr-with-displaying-help-buffer (thunk &optional _name)
:xemacs-and-try with-displaying-help-buffer
"Make a help buffer and call `thunk' there."
(with-output-to-temp-buffer "*Help*"
@@ -1083,7 +1092,7 @@ Used for `antlr-slow-syntactic-context'.")
;;;(defvar antlr-statistics-cache 0)
;;;(defvar antlr-statistics-inval 0)
-(defunx antlr-invalidate-context-cache (&rest dummies)
+(defunx antlr-invalidate-context-cache (&rest _dummies)
;; checkdoc-params: (dummies)
"Invalidate context cache for syntactical context information."
:XEMACS ; XEmacs bug workaround
@@ -1661,7 +1670,7 @@ Return \(LEVEL OPTION LOCATION)."
table)))
(list level input (cdr kind))))))
-(defun antlr-options-menu-filter (level menu-items)
+(defun antlr-options-menu-filter (level _menu-items)
"Return items for options submenu of level LEVEL."
;; checkdoc-params: (menu-items)
(let ((active (if buffer-read-only
@@ -2063,7 +2072,7 @@ Used inside `antlr-options-alists'."
nil
table '(("false") ("true"))))
-(defun antlr-language-option-extra (phase &rest dummies)
+(defun antlr-language-option-extra (phase &rest _dummies)
;; checkdoc-params: (dummies)
"Change language according to the new value of the \"language\" option.
Call `antlr-mode' if the new language would be different from the value
@@ -2079,7 +2088,7 @@ Called in PHASE `after-insertion', see `antlr-options-alists'."
(antlr-mode)
(and font-lock (null font-lock-mode) (font-lock-mode 1)))))))
-(defun antlr-c++-mode-extra (phase option &rest dummies)
+(defun antlr-c++-mode-extra (phase option &rest _dummies)
;; checkdoc-params: (option dummies)
"Warn if C++ option is used with the wrong language.
Ask user \(\"y or n\"), if a C++ only option is going to be inserted but
@@ -2172,36 +2181,32 @@ grammar file in which CLASS is defined and EVOCAB is the name of the
export vocabulary specified in that file."
(let ((grammar (directory-files dirname t "\\.g\\'")))
(when grammar
- (let ((temp-buffer (get-buffer-create
- (generate-new-buffer-name " *temp*")))
- (antlr-imenu-name nil) ; dynamic-let: no imenu
- (expanded-regexp (concat (format (regexp-quote
- (cadr antlr-special-file-formats))
- ".+")
- "\\'"))
+ (let ((antlr-imenu-name nil) ; dynamic-let: no imenu
+ (expanded-regexp
+ (concat (format (regexp-quote
+ (cadr antlr-special-file-formats))
+ ".+")
+ "\\'"))
classes dependencies)
- (unwind-protect
- (with-current-buffer temp-buffer
- (widen) ; just in case...
- (dolist (file grammar)
- (when (and (file-regular-p file)
- (null (string-match expanded-regexp file)))
- (insert-file-contents file t nil nil t)
- (normal-mode t) ; necessary for major-mode, syntax
+ (with-temp-buffer
+ (dolist (file grammar)
+ (when (and (file-regular-p file)
+ (null (string-match expanded-regexp file)))
+ (insert-file-contents file t nil nil t)
+ (normal-mode t) ; necessary for major-mode, syntax
; table and `antlr-language'
- (when (eq major-mode 'antlr-mode)
- (let* ((file-deps (antlr-file-dependencies))
- (file (car file-deps)))
- (when file-deps
- (dolist (class-def (caadr file-deps))
- (let ((file-evocab (cons file (cdr class-def)))
- (class-spec (assoc (car class-def) classes)))
- (if class-spec
- (nconc (cdr class-spec) (list file-evocab))
- (push (list (car class-def) file-evocab)
- classes))))
- (push file-deps dependencies)))))))
- (kill-buffer temp-buffer))
+ (when (derived-mode-p 'antlr-mode)
+ (let* ((file-deps (antlr-file-dependencies))
+ (file (car file-deps)))
+ (when file-deps
+ (dolist (class-def (caadr file-deps))
+ (let ((file-evocab (cons file (cdr class-def)))
+ (class-spec (assoc (car class-def) classes)))
+ (if class-spec
+ (nconc (cdr class-spec) (list file-evocab))
+ (push (list (car class-def) file-evocab)
+ classes))))
+ (push file-deps dependencies)))))))
(cons (nreverse classes) (nreverse dependencies))))))
@@ -2255,7 +2260,7 @@ called interactively, the buffers are always saved, see also variable
(or saved (save-some-buffers (not antlr-ask-about-save)))
(let ((default-directory (file-name-directory file)))
(compilation-start (concat command " " (file-name-nondirectory file))
- nil #'(lambda (mode-name) "*Antlr-Run*"))))
+ nil (lambda (_mode-name) "*Antlr-Run*"))))
(defun antlr-run-tool-interactive ()
;; code in `interactive' is not compiled
@@ -2373,7 +2378,7 @@ are used according to variable `antlr-unknown-file-formats' and a
commentary with value `antlr-help-unknown-file-text' is added. The
*Help* buffer always starts with the text in `antlr-help-rules-intro'."
(interactive)
- (if (null (eq major-mode 'makefile-mode))
+ (if (null (derived-mode-p 'makefile-mode))
(antlr-with-displaying-help-buffer 'antlr-insert-makefile-rules)
(push-mark)
(antlr-insert-makefile-rules t)))
@@ -2563,13 +2568,15 @@ ANTLR's syntax and influences the auto indentation, see
"Find language in `antlr-language-alist' for language option.
If SEARCH is non-nil, find element for language option. Otherwise, find
the default language."
- (let ((value (and search
- (save-excursion
- (goto-char (point-min))
- (re-search-forward (cdr antlr-language-limit-n-regexp)
- (car antlr-language-limit-n-regexp)
- t))
- (match-string 1)))
+ (let ((value
+ (and search
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward (cdr antlr-language-limit-n-regexp)
+ (+ (point)
+ (car antlr-language-limit-n-regexp))
+ t))
+ (match-string 1)))
(seq antlr-language-alist)
r)
;; Like (find VALUE antlr-language-alist :key 'cddr :test 'member)
@@ -2581,35 +2588,20 @@ the default language."
(car r)))
;;;###autoload
-(defun antlr-mode ()
- "Major mode for editing ANTLR grammar files.
-\\{antlr-mode-map}"
- (interactive)
- (kill-all-local-variables)
+(define-derived-mode antlr-mode prog-mode
+ ;; FIXME: Since it uses cc-mode, it bumps into c-update-modeline's
+ ;; limitation to mode-name being a string.
+ ;; '("Antlr." (:eval (cadr (assq antlr-language antlr-language-alist))))
+ "Antlr"
+ "Major mode for editing ANTLR grammar files."
+ :abbrev-table antlr-mode-abbrev-table
(c-initialize-cc-mode) ; cc-mode is required
(unless (fboundp 'c-forward-sws) ; see above
(fset 'antlr-c-forward-sws 'c-forward-syntactic-ws))
;; ANTLR specific ----------------------------------------------------------
- (setq major-mode 'antlr-mode
- mode-name "Antlr")
- (setq local-abbrev-table antlr-mode-abbrev-table)
- (unless antlr-mode-syntax-table
- (setq antlr-mode-syntax-table (make-syntax-table))
- (c-populate-syntax-table antlr-mode-syntax-table))
- (set-syntax-table antlr-mode-syntax-table)
- (unless antlr-action-syntax-table
- (let ((slist (nth 3 antlr-font-lock-defaults)))
- (setq antlr-action-syntax-table
- (copy-syntax-table antlr-mode-syntax-table))
- (while slist
- (modify-syntax-entry (caar slist) (cdar slist)
- antlr-action-syntax-table)
- (setq slist (cdr slist)))))
- (use-local-map antlr-mode-map)
- (make-local-variable 'antlr-language)
(unless antlr-language
- (setq antlr-language
- (or (antlr-language-option t) (antlr-language-option nil))))
+ (set (make-local-variable 'antlr-language)
+ (or (antlr-language-option t) (antlr-language-option nil))))
(if (stringp (cadr (assq antlr-language antlr-language-alist)))
(setq mode-name
(concat "Antlr."
@@ -2627,33 +2619,24 @@ the default language."
(t ; cc-mode upto 5.28
(antlr-c-init-language-vars))) ; do it myself
(c-basic-common-init antlr-language (or antlr-indent-style "gnu"))
- (make-local-variable 'outline-regexp)
- (make-local-variable 'outline-level)
- (make-local-variable 'require-final-newline)
- (make-local-variable 'indent-line-function)
- (make-local-variable 'indent-region-function)
- (setq outline-regexp "[^#\n\^M]"
- outline-level 'c-outline-level) ; TODO: define own
- (setq require-final-newline mode-require-final-newline)
- (setq indent-line-function 'antlr-indent-line
- indent-region-function nil) ; too lazy
+ (set (make-local-variable 'outline-regexp) "[^#\n\^M]")
+ (set (make-local-variable 'outline-level) 'c-outline-level) ;TODO: define own
+ (set (make-local-variable 'indent-line-function) 'antlr-indent-line)
+ (set (make-local-variable 'indent-region-function) nil) ; too lazy
(setq comment-start "// "
comment-end ""
comment-start-skip "/\\*+ *\\|// *")
;; various -----------------------------------------------------------------
- (make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults antlr-font-lock-defaults)
+ (set (make-local-variable 'font-lock-defaults) antlr-font-lock-defaults)
(easy-menu-add antlr-mode-menu)
- (make-local-variable 'imenu-create-index-function)
- (setq imenu-create-index-function 'antlr-imenu-create-index-function)
- (make-local-variable 'imenu-generic-expression)
- (setq imenu-generic-expression t) ; fool stupid test
+ (set (make-local-variable 'imenu-create-index-function)
+ 'antlr-imenu-create-index-function)
+ (set (make-local-variable 'imenu-generic-expression) t) ; fool stupid test
(and antlr-imenu-name ; there should be a global variable...
(fboundp 'imenu-add-to-menubar)
(imenu-add-to-menubar
(if (stringp antlr-imenu-name) antlr-imenu-name "Index")))
- (antlr-set-tabs)
- (run-mode-hooks 'antlr-mode-hook))
+ (antlr-set-tabs))
;; A smarter version of `group-buffers-menu-by-mode-then-alphabetically' (in
;; XEmacs) could use the following property. The header of the submenu would
@@ -2679,5 +2662,4 @@ Used in `antlr-mode'. Also a useful function in `java-mode-hook'."
;;; Local IspellPersDict: .ispell_antlr
-;; arch-tag: 5de2be79-3d13-4560-8fbc-f7d0234dcb5c
;;; antlr-mode.el ends here
diff --git a/lisp/progmodes/asm-mode.el b/lisp/progmodes/asm-mode.el
index 8482e99f40c..3ac8b119fe1 100644
--- a/lisp/progmodes/asm-mode.el
+++ b/lisp/progmodes/asm-mode.el
@@ -1,7 +1,6 @@
;;; asm-mode.el --- mode for editing assembler code
-;; Copyright (C) 1991, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1991, 2001-2011 Free Software Foundation, Inc.
;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
;; Maintainer: FSF
@@ -77,22 +76,21 @@
(define-key map "\C-c;" 'comment-region)
(define-key map "\C-j" 'newline-and-indent)
(define-key map "\C-m" 'newline-and-indent)
- (define-key map [menu-bar] (make-sparse-keymap))
- (define-key map [menu-bar asm-mode] (cons "Asm" map))
- (define-key map [comment-region]
+ (define-key map [menu-bar asm-mode] (cons "Asm" (make-sparse-keymap)))
+ (define-key map [menu-bar asm-mode comment-region]
'(menu-item "Comment Region" comment-region
:help "Comment or uncomment each line in the region"))
- (define-key map [newline-and-indent]
+ (define-key map [menu-bar asm-mode newline-and-indent]
'(menu-item "Insert Newline and Indent" newline-and-indent
:help "Insert a newline, then indent according to major mode"))
- (define-key map [asm-colon]
+ (define-key map [menu-bar asm-mode asm-colon]
'(menu-item "Insert Colon" asm-colon
:help "Insert a colon; if it follows a label, delete the label's indentation"))
map)
"Keymap for Asm mode.")
(defconst asm-font-lock-keywords
- (append
+ (append
'(("^\\(\\(\\sw\\|\\s_\\)+\\)\\>:?[ \t]*\\(\\sw+\\(\\.\\sw+\\)*\\)?"
(1 font-lock-function-name-face) (3 font-lock-keyword-face nil t))
;; label started from ".".
@@ -109,7 +107,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 +126,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)
@@ -147,18 +140,13 @@ Special commands:
(set-syntax-table (make-syntax-table asm-mode-syntax-table))
(modify-syntax-entry asm-comment-char "< b")
- (make-local-variable 'comment-start)
- (setq comment-start (string asm-comment-char))
- (make-local-variable 'comment-add)
- (setq comment-add 1)
- (make-local-variable 'comment-start-skip)
- (setq comment-start-skip "\\(?:\\s<+\\|/[/*]+\\)[ \t]*")
- (make-local-variable 'comment-end-skip)
- (setq comment-end-skip "[ \t]*\\(\\s>\\|\\*+/\\)")
- (make-local-variable 'comment-end)
- (setq comment-end "")
- (setq fill-prefix "\t")
- (run-mode-hooks 'asm-mode-hook))
+ (set (make-local-variable 'comment-start) (string asm-comment-char))
+ (set (make-local-variable 'comment-add) 1)
+ (set (make-local-variable 'comment-start-skip)
+ "\\(?:\\s<+\\|/[/*]+\\)[ \t]*")
+ (set (make-local-variable 'comment-end-skip) "[ \t]*\\(\\s>\\|\\*+/\\)")
+ (set (make-local-variable 'comment-end) "")
+ (setq fill-prefix "\t"))
(defun asm-indent-line ()
"Auto-indent the current line."
@@ -254,5 +242,4 @@ repeatedly until you are satisfied with the kind of comment."
(provide 'asm-mode)
-;; arch-tag: 210e695f-f338-4376-8913-a4c5c72ac848
;;; asm-mode.el ends here
diff --git a/lisp/progmodes/autoconf.el b/lisp/progmodes/autoconf.el
index 281c65cd788..3aa9a6cfb87 100644
--- a/lisp/progmodes/autoconf.el
+++ b/lisp/progmodes/autoconf.el
@@ -1,7 +1,6 @@
;;; autoconf.el --- mode for editing Autoconf configure.in files
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Author: Dave Love <fx@gnu.org>
;; Keywords: languages
@@ -43,9 +42,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+\\)\\]*")
@@ -81,21 +77,15 @@ searching backwards at another AC_... command."
(match-string-no-properties 3)))))
;;;###autoload
-(defun autoconf-mode ()
+(define-derived-mode autoconf-mode prog-mode "Autoconf"
"Major mode for editing Autoconf configure.in files."
- (interactive)
- (kill-all-local-variables)
- (use-local-map autoconf-mode-map)
- (setq major-mode 'autoconf-mode)
- (setq mode-name "Autoconf")
- (set-syntax-table autoconf-mode-syntax-table)
(set (make-local-variable 'parens-require-spaces) nil) ; for M4 arg lists
(set (make-local-variable 'defun-prompt-regexp)
"^[ \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)
@@ -103,11 +93,9 @@ searching backwards at another AC_... command."
(set (make-local-variable 'imenu-syntax-alist) '(("_" . "w")))
(set (make-local-variable 'indent-line-function) #'indent-relative)
(set (make-local-variable 'add-log-current-defun-function)
- #'autoconf-current-defun-function)
- (run-mode-hooks 'autoconf-mode-hook))
+ #'autoconf-current-defun-function))
(provide 'autoconf-mode)
(provide 'autoconf)
-;; arch-tag: 4f44778f-2ab3-49a1-a103-f0acb9df2de4
;;; autoconf.el ends here
diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el
index 5f20ea63573..8ec379afab2 100644
--- a/lisp/progmodes/bug-reference.el
+++ b/lisp/progmodes/bug-reference.el
@@ -1,6 +1,6 @@
;; bug-reference.el --- buttonize bug references
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Tom Tromey <tromey@redhat.com>
;; Created: 21 Mar 2007
@@ -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,12 +102,14 @@ 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)
+(defun bug-reference-push-button (&optional pos _use-mouse-action)
"Open URL corresponding to the bug reference at POS."
(interactive
(list (if (integerp last-command-event) (point) last-command-event)))
@@ -134,5 +151,4 @@ There is no default setting for this, it must be set per file.")
(widen)
(bug-reference-unfontify (point-min) (point-max)))))
-;; arch-tag: b138abce-e5c3-475e-bd58-7afba40387ea
;;; bug-reference.el ends here
diff --git a/lisp/progmodes/cap-words.el b/lisp/progmodes/cap-words.el
index 48b1d19e013..0ce84ae33a7 100644
--- a/lisp/progmodes/cap-words.el
+++ b/lisp/progmodes/cap-words.el
@@ -1,7 +1,6 @@
;;; cap-words.el --- minor mode for motion in CapitalizedWordIdentifiers
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Dave Love <fx@gnu.org>
;; Keywords: languages
@@ -92,5 +91,4 @@ Obsoletes `c-forward-into-nomenclature'."
(provide 'cap-words)
-;; arch-tag: 46513b64-fe5a-4c0b-902c-ed235c22975f
;;; cap-words.el ends here
diff --git a/lisp/progmodes/cc-align.el b/lisp/progmodes/cc-align.el
index 61ccd83d43e..81045d63abf 100644
--- a/lisp/progmodes/cc-align.el
+++ b/lisp/progmodes/cc-align.el
@@ -1,8 +1,6 @@
;;; cc-align.el --- custom indentation functions 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, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1987, 1992-2011 Free Software Foundation, Inc.
;; Authors: 2004- Alan Mackenzie
;; 1998- Martin Stjernholm
@@ -12,8 +10,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.
@@ -1333,5 +1331,4 @@ For other semicolon contexts, no determination is made."
(cc-provide 'cc-align)
-;; arch-tag: 4d71ed28-bf51-4509-a148-f39669669a2e
;;; cc-align.el ends here
diff --git a/lisp/progmodes/cc-awk.el b/lisp/progmodes/cc-awk.el
index fbe054a666b..d19ba47aa3f 100644
--- a/lisp/progmodes/cc-awk.el
+++ b/lisp/progmodes/cc-awk.el
@@ -1,11 +1,11 @@
;;; cc-awk.el --- AWK specific code within cc-mode.
-;; Copyright (C) 1988, 1994, 1996, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1988, 1994, 1996, 2000-2011 Free Software Foundation, Inc.
;; 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 +244,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 +503,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 +519,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)?
@@ -1095,5 +1095,4 @@ comment at the start of cc-engine.el for more info."
(cc-provide 'cc-awk) ; Changed from 'awk-mode, ACM 2002/5/21
-;; arch-tag: c4836289-3aa4-4a59-9934-9ccc2bacccf3
;;; awk-mode.el ends here
diff --git a/lisp/progmodes/cc-bytecomp.el b/lisp/progmodes/cc-bytecomp.el
index 57722158dd4..823430f2d38 100644
--- a/lisp/progmodes/cc-bytecomp.el
+++ b/lisp/progmodes/cc-bytecomp.el
@@ -1,13 +1,12 @@
;;; cc-bytecomp.el --- compile time setup for proper compilation
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; 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.
@@ -434,5 +433,4 @@ exclude any functions that have been bound during compilation with
(provide 'cc-bytecomp)
-;; arch-tag: 2d71b3ad-57b0-4b13-abd3-ab836e08f975
;;; cc-bytecomp.el ends here
diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el
index bd047e89435..0f873e678c3 100644
--- a/lisp/progmodes/cc-cmds.el
+++ b/lisp/progmodes/cc-cmds.el
@@ -1,8 +1,6 @@
;;; cc-cmds.el --- user level commands 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, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1987, 1992-2011 Free Software Foundation, Inc.
;; Authors: 2003- Alan Mackenzie
;; 1998- Martin Stjernholm
@@ -12,8 +10,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.
@@ -266,8 +264,10 @@ With universal argument, inserts the analysis as a comment on that line."
(symbol-value 'subword-mode))
"w"
"")))
+ ;; FIXME: Derived modes might want to use something else
+ ;; than a string for `mode-name'.
(bare-mode-name (if (string-match "\\(^[^/]*\\)/" mode-name)
- (substring mode-name (match-beginning 1) (match-end 1))
+ (match-string 1 mode-name)
mode-name)))
;; (setq c-submode-indicators
;; (if (> (length fmt) 1)
@@ -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))
@@ -3999,16 +3981,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
@@ -4025,6 +4010,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
@@ -4067,7 +4060,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)
@@ -4277,8 +4272,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.
@@ -4581,5 +4579,4 @@ normally bound to C-o. See `c-context-line-break' for the details."
(cc-provide 'cc-cmds)
-;; arch-tag: bf0611dc-d1f4-449e-9e45-4ec7c6936677
;;; cc-cmds.el ends here
diff --git a/lisp/progmodes/cc-compat.el b/lisp/progmodes/cc-compat.el
index 42ab5e8f032..01f7379b1b0 100644
--- a/lisp/progmodes/cc-compat.el
+++ b/lisp/progmodes/cc-compat.el
@@ -1,15 +1,13 @@
;;; cc-compat.el --- cc-mode compatibility with c-mode.el confusion
-;; Copyright (C) 1985, 1987, 1992, 1993, 1994, 1995, 1996, 1997, 1998,
-;; 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1987, 1992-2011 Free Software Foundation, Inc.
;; Authors: 1998- Martin Stjernholm
;; 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.
@@ -163,5 +161,4 @@ This is in addition to c-continued-statement-offset.")
(cc-provide 'cc-compat)
-;; arch-tag: 564dab2f-e6ad-499c-a4a3-fedec3ecc192
;;; cc-compat.el ends here
diff --git a/lisp/progmodes/cc-defs.el b/lisp/progmodes/cc-defs.el
index 77b73a0a46f..ce38cf8850b 100644
--- a/lisp/progmodes/cc-defs.el
+++ b/lisp/progmodes/cc-defs.el
@@ -1,8 +1,6 @@
;;; cc-defs.el --- compile time definitions 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, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1987, 1992-2011 Free Software Foundation, Inc.
;; Authors: 2003- Alan Mackenzie
;; 1998- Martin Stjernholm
@@ -12,8 +10,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 +1027,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 +1080,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 +1181,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.
@@ -2127,5 +2257,4 @@ quoted."
(cc-provide 'cc-defs)
-;; arch-tag: 3bb2629d-dd84-4ff0-ad39-584be0fe3cda
;;; cc-defs.el ends here
diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el
index a53dd61c81e..0eec54fab6f 100644
--- a/lisp/progmodes/cc-engine.el
+++ b/lisp/progmodes/cc-engine.el
@@ -1,8 +1,6 @@
;;; 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, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1987, 1992-2011 Free Software Foundation, Inc.
;; Authors: 2001- Alan Mackenzie
;; 1998- Martin Stjernholm
@@ -12,8 +10,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 +77,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 +258,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 +1970,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 +1990,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 +2003,1108 @@ 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 or a cpp
+;; construct. 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.
+ ;;
+ ;; NOTE: This function manipulates `c-state-nonlit-pos-cache'. This cache
+ ;; MAY NOT contain any positions within macros, since macros are frequently
+ ;; turned into comments by use of the `c-cpp-delimiter' category properties.
+ ;; We cannot rely on this mechanism whilst determining a cache pos since
+ ;; this function is also called from outwith `c-parse-state'.
+ (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.
+ (goto-char pos)
+ (when (and (c-beginning-of-macro) (/= (point) pos))
+ (c-syntactic-end-of-macro)
+ (or (eobp) (forward-char))
+ (setq pos (point)))
+ (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
+;; 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))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Debugging routines to dump `c-state-cache' in a "replayable" form.
+;; (defmacro c-sc-de (elt) ; "c-state-cache-dump-element"
+;; `(format ,(concat "(setq " (symbol-name elt) " %s) ") ,elt))
+;; (defmacro c-sc-qde (elt) ; "c-state-cache-quote-dump-element"
+;; `(format ,(concat "(setq " (symbol-name elt) " '%s) ") ,elt))
+;; (defun c-state-dump ()
+;; ;; For debugging.
+;; ;(message
+;; (concat
+;; (c-sc-qde c-state-cache)
+;; (c-sc-de c-state-cache-good-pos)
+;; (c-sc-qde c-state-nonlit-pos-cache)
+;; (c-sc-de c-state-nonlit-pos-cache-limit)
+;; (c-sc-qde c-state-brace-pair-desert)
+;; (c-sc-de c-state-point-min)
+;; (c-sc-de c-state-point-min-lit-type)
+;; (c-sc-de c-state-point-min-lit-start)
+;; (c-sc-de c-state-min-scan-pos)
+;; (c-sc-de c-state-old-cpp-beg)
+;; (c-sc-de c-state-old-cpp-end)))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(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 +3116,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 +3131,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 +4931,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 +5136,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 +5151,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,7 +5402,8 @@ comment at the start of cc-engine.el for more info."
(goto-char safe-pos)
t)))
-(defvar c-forward-<>-arglist-recur-depth)
+;; 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
@@ -4420,8 +5430,7 @@ comment at the start of cc-engine.el for more info."
;; If `c-record-type-identifiers' is set then activate
;; recording of any found types that constitute an argument in
;; the arglist.
- (c-record-found-types (if c-record-type-identifiers t))
- (c-forward-<>-arglist-recur--depth 0))
+ (c-record-found-types (if c-record-type-identifiers t)))
(if (catch 'angle-bracket-arglist-escape
(setq c-record-found-types
(c-forward-<>-arglist-recur all-types)))
@@ -4431,20 +5440,13 @@ 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)
nil)))
(defun c-forward-<>-arglist-recur (all-types)
-
- ;; Temporary workaround for Bug#7722.
- (when (boundp 'c-forward-<>-arglist-recur--depth)
- (if (> c-forward-<>-arglist-recur--depth 200)
- (error "Max recursion depth reached in <> arglist")
- (setq c-forward-<>-arglist-recur--depth
- (1+ c-forward-<>-arglist-recur--depth))))
-
;; Recursive part of `c-forward-<>-arglist'.
;;
;; This function might do hidden buffer changes.
@@ -4458,7 +5460,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)
@@ -4469,7 +5470,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
@@ -4478,68 +5478,49 @@ comment at the start of cc-engine.el for more info."
(goto-char start)
nil))
- (forward-char)
+ (forward-char) ; Forward over the opening '<'.
+
(unless (looking-at c-<-op-cont-regexp)
+ ;; go forward one non-alphanumeric character (group) per iteration of
+ ;; this loop.
(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)
- (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))))))
+ (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)))
+ (when (or (looking-at "extends")
+ (looking-at "super"))
+ (forward-word)
+ (c-forward-syntactic-ws)
+ (let ((c-promote-possible-types t)
+ (c-record-found-types t))
+ (c-forward-type)
+ (c-forward-syntactic-ws))))))
+
+ (setq pos (point)) ; e.g. first token inside the '<'
+
+ ;; 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) ?>)
@@ -4564,40 +5545,37 @@ 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)
- (setq tmp (match-end 0))
- (setq tmp pos)
- (backward-char)
- (not
- (and
-
- (save-excursion
- ;; There's always an identifier before an angle
- ;; bracket arglist, or a keyword in
- ;; `c-<>-type-kwds' or `c-<>-arglist-kwds'.
- (c-backward-syntactic-ws)
- (setq id-end (point))
- (c-simple-skip-symbol-backward)
- (when (or (setq keyword-match
- (looking-at c-opt-<>-sexp-key))
- (not (looking-at c-keywords-regexp)))
- (setq id-start (point))))
-
- (setq subres
- (let ((c-record-type-identifiers nil)
- (c-record-found-types nil))
- (c-forward-<>-arglist-recur
- (and keyword-match
- (c-keyword-member
- (c-keyword-sym (match-string 1))
- 'c-<>-type-kwds)))))
- )))
-
- ;; It was not an angle bracket arglist.
- (goto-char tmp)
+ (cond
+ ;; The '<' begins a multi-char operator.
+ ((looking-at c-<-op-cont-regexp)
+ (setq tmp (match-end 0))
+ (goto-char (match-end 0)))
+ ;; We're at a nested <.....>
+ ((progn
+ (setq tmp pos)
+ (backward-char) ; to the '<'
+ (and
+ (save-excursion
+ ;; There's always an identifier before an angle
+ ;; bracket arglist, or a keyword in `c-<>-type-kwds'
+ ;; or `c-<>-arglist-kwds'.
+ (c-backward-syntactic-ws)
+ (setq id-end (point))
+ (c-simple-skip-symbol-backward)
+ (when (or (setq keyword-match
+ (looking-at c-opt-<>-sexp-key))
+ (not (looking-at c-keywords-regexp)))
+ (setq id-start (point))))
+ (setq subres
+ (let ((c-promote-possible-types t)
+ (c-record-found-types t))
+ (c-forward-<>-arglist-recur
+ (and keyword-match
+ (c-keyword-member
+ (c-keyword-sym (match-string 1))
+ 'c-<>-type-kwds)))))))
;; It was an angle bracket arglist.
(setq c-record-found-types subres)
@@ -4612,12 +5590,19 @@ comment at the start of cc-engine.el for more info."
(c-forward-syntactic-ws)
(looking-at c-opt-identifier-concat-key)))
(c-record-ref-id (cons id-start id-end))
- (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
+ (c-record-type-id (cons id-start id-end)))))
+
+ ;; At a "less than" operator.
+ (t
+ (forward-char)
+ )))
+ t) ; carry on looping.
+
+ ((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)))
@@ -4628,7 +5613,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)))))
@@ -4699,17 +5683,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
@@ -4831,9 +5821,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))
@@ -4862,16 +5851,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.
@@ -4882,37 +5883,48 @@ 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 (and c-recognize-<>-arglists
+ (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)
@@ -5002,14 +6014,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
@@ -5019,7 +6030,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
@@ -5081,6 +6092,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.
@@ -5158,11 +6181,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
@@ -5220,9 +6247,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
@@ -5250,6 +6279,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
@@ -5259,12 +6291,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
@@ -5329,6 +6363,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))
@@ -5583,13 +6619,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)))
@@ -5927,7 +6964,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.
@@ -7550,7 +8589,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")
@@ -7657,6 +8696,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)
@@ -7670,1454 +8725,1465 @@ comment at the start of cc-engine.el for more info."
(defun c-guess-basic-syntax ()
"Return the syntactic context of the current line."
(save-excursion
- (beginning-of-line)
- (c-save-buffer-state
- ((indent-point (point))
- (case-fold-search nil)
- ;; A whole ugly bunch of various temporary variables. Have
- ;; to declare them here since it's not possible to declare
- ;; a variable with only the scope of a cond test and the
- ;; following result clauses, and most of this function is a
- ;; single gigantic cond. :P
- literal char-before-ip before-ws-ip char-after-ip macro-start
- in-macro-expr c-syntactic-context placeholder c-in-literal-cache
- step-type tmpsymbol keyword injava-inher special-brace-list tmp-pos
- containing-<
- ;; The following record some positions for the containing
- ;; declaration block if we're directly within one:
- ;; `containing-decl-open' is the position of the open
- ;; brace. `containing-decl-start' is the start of the
- ;; declaration. `containing-decl-kwd' is the keyword
- ;; symbol of the keyword that tells what kind of block it
- ;; is.
- containing-decl-open
- containing-decl-start
- containing-decl-kwd
- ;; The open paren of the closest surrounding sexp or nil if
- ;; there is none.
- containing-sexp
- ;; The position after the closest preceding brace sexp
- ;; (nested sexps are ignored), or the position after
- ;; `containing-sexp' if there is none, or (point-min) if
- ;; `containing-sexp' is nil.
- lim
- ;; The paren state outside `containing-sexp', or at
- ;; `indent-point' if `containing-sexp' is nil.
- (paren-state (c-parse-state))
- ;; There's always at most one syntactic element which got
- ;; an anchor pos. It's stored in syntactic-relpos.
- syntactic-relpos
- (c-stmt-delim-chars c-stmt-delim-chars))
-
- ;; Check if we're directly inside an enclosing declaration
- ;; level block.
- (when (and (setq containing-sexp
- (c-most-enclosing-brace paren-state))
- (progn
- (goto-char containing-sexp)
- (eq (char-after) ?{))
- (setq placeholder
- (c-looking-at-decl-block
- (c-most-enclosing-brace paren-state
- containing-sexp)
- t)))
- (setq containing-decl-open containing-sexp
- containing-decl-start (point)
- containing-sexp nil)
- (goto-char placeholder)
- (setq containing-decl-kwd (and (looking-at c-keywords-regexp)
- (c-keyword-sym (match-string 1)))))
-
- ;; Init some position variables.
- (if c-state-cache
- (progn
- (setq containing-sexp (car paren-state)
- paren-state (cdr paren-state))
- (if (consp containing-sexp)
- (progn
- (setq lim (cdr containing-sexp))
- (if (cdr c-state-cache)
- ;; Ignore balanced paren. The next entry
- ;; can't be another one.
- (setq containing-sexp (car (cdr c-state-cache))
- paren-state (cdr paren-state))
- ;; If there is no surrounding open paren then
- ;; put the last balanced pair back on paren-state.
- (setq paren-state (cons containing-sexp paren-state)
- containing-sexp nil)))
- (setq lim (1+ containing-sexp))))
- (setq lim (point-min)))
-
- ;; If we're in a parenthesis list then ',' delimits the
- ;; "statements" rather than being an operator (with the
- ;; exception of the "for" clause). This difference is
- ;; typically only noticeable when statements are used in macro
- ;; arglists.
- (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)
- (c-backward-syntactic-ws lim)
- (setq before-ws-ip (point)
- char-before-ip (char-before))
- (goto-char indent-point)
- (skip-chars-forward " \t")
- (setq char-after-ip (char-after))
-
- ;; are we in a literal?
- (setq literal (c-in-literal lim))
-
- ;; now figure out syntactic qualities of the current line
- (cond
+ (beginning-of-line)
+ (c-save-buffer-state
+ ((indent-point (point))
+ (case-fold-search nil)
+ ;; A whole ugly bunch of various temporary variables. Have
+ ;; to declare them here since it's not possible to declare
+ ;; a variable with only the scope of a cond test and the
+ ;; following result clauses, and most of this function is a
+ ;; single gigantic cond. :P
+ literal char-before-ip before-ws-ip char-after-ip macro-start
+ in-macro-expr c-syntactic-context placeholder c-in-literal-cache
+ step-type tmpsymbol keyword injava-inher special-brace-list tmp-pos
+ containing-<
+ ;; The following record some positions for the containing
+ ;; declaration block if we're directly within one:
+ ;; `containing-decl-open' is the position of the open
+ ;; brace. `containing-decl-start' is the start of the
+ ;; declaration. `containing-decl-kwd' is the keyword
+ ;; symbol of the keyword that tells what kind of block it
+ ;; is.
+ containing-decl-open
+ containing-decl-start
+ containing-decl-kwd
+ ;; The open paren of the closest surrounding sexp or nil if
+ ;; there is none.
+ containing-sexp
+ ;; The position after the closest preceding brace sexp
+ ;; (nested sexps are ignored), or the position after
+ ;; `containing-sexp' if there is none, or (point-min) if
+ ;; `containing-sexp' is nil.
+ lim
+ ;; The paren state outside `containing-sexp', or at
+ ;; `indent-point' if `containing-sexp' is nil.
+ (paren-state (c-parse-state))
+ ;; There's always at most one syntactic element which got
+ ;; an anchor pos. It's stored in syntactic-relpos.
+ syntactic-relpos
+ (c-stmt-delim-chars c-stmt-delim-chars))
+
+ ;; Check if we're directly inside an enclosing declaration
+ ;; level block.
+ (when (and (setq containing-sexp
+ (c-most-enclosing-brace paren-state))
+ (progn
+ (goto-char containing-sexp)
+ (eq (char-after) ?{))
+ (setq placeholder
+ (c-looking-at-decl-block
+ (c-most-enclosing-brace paren-state
+ containing-sexp)
+ t)))
+ (setq containing-decl-open containing-sexp
+ containing-decl-start (point)
+ containing-sexp nil)
+ (goto-char placeholder)
+ (setq containing-decl-kwd (and (looking-at c-keywords-regexp)
+ (c-keyword-sym (match-string 1)))))
+
+ ;; Init some position variables.
+ (if c-state-cache
+ (progn
+ (setq containing-sexp (car paren-state)
+ paren-state (cdr paren-state))
+ (if (consp containing-sexp)
+ (progn
+ (setq lim (cdr containing-sexp))
+ (if (cdr c-state-cache)
+ ;; Ignore balanced paren. The next entry
+ ;; can't be another one.
+ (setq containing-sexp (car (cdr c-state-cache))
+ paren-state (cdr paren-state))
+ ;; If there is no surrounding open paren then
+ ;; put the last balanced pair back on paren-state.
+ (setq paren-state (cons containing-sexp paren-state)
+ containing-sexp nil)))
+ (setq lim (1+ containing-sexp))))
+ (setq lim (point-min)))
+
+ ;; If we're in a parenthesis list then ',' delimits the
+ ;; "statements" rather than being an operator (with the
+ ;; exception of the "for" clause). This difference is
+ ;; typically only noticeable when statements are used in macro
+ ;; arglists.
+ (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)
+ (c-backward-syntactic-ws lim)
+ (setq before-ws-ip (point)
+ char-before-ip (char-before))
+ (goto-char indent-point)
+ (skip-chars-forward " \t")
+ (setq char-after-ip (char-after))
+
+ ;; are we in a literal?
+ (setq literal (c-in-literal lim))
+
+ ;; now figure out syntactic qualities of the current line
+ (cond
- ;; CASE 1: in a string.
- ((eq literal 'string)
- (c-add-syntax 'string (c-point 'bopl)))
-
- ;; CASE 2: in a C or C++ style comment.
- ((and (memq literal '(c c++))
- ;; This is a kludge for XEmacs where we use
- ;; `buffer-syntactic-context', which doesn't correctly
- ;; recognize "\*/" to end a block comment.
- ;; `parse-partial-sexp' which is used by
- ;; `c-literal-limits' will however do that in most
- ;; versions, which results in that we get nil from
- ;; `c-literal-limits' even when `c-in-literal' claims
- ;; we're inside a comment.
- (setq placeholder (c-literal-limits lim)))
- (c-add-syntax literal (car placeholder)))
-
- ;; CASE 3: in a cpp preprocessor macro continuation.
- ((and (save-excursion
- (when (c-beginning-of-macro)
- (setq macro-start (point))))
- (/= macro-start (c-point 'boi))
- (progn
- (setq tmpsymbol 'cpp-macro-cont)
- (or (not c-syntactic-indentation-in-macros)
- (save-excursion
- (goto-char macro-start)
- ;; If at the beginning of the body of a #define
- ;; directive then analyze as cpp-define-intro
- ;; only. Go on with the syntactic analysis
- ;; otherwise. in-macro-expr is set if we're in a
- ;; cpp expression, i.e. before the #define body
- ;; or anywhere in a non-#define directive.
- (if (c-forward-to-cpp-define-body)
- (let ((indent-boi (c-point 'boi indent-point)))
- (setq in-macro-expr (> (point) indent-boi)
- tmpsymbol 'cpp-define-intro)
- (= (point) indent-boi))
- (setq in-macro-expr t)
- nil)))))
- (c-add-syntax tmpsymbol macro-start)
- (setq macro-start nil))
-
- ;; CASE 11: an else clause?
- ((looking-at "else\\>[^_]")
- (c-beginning-of-statement-1 containing-sexp)
- (c-add-stmt-syntax 'else-clause nil t
- containing-sexp paren-state))
+ ;; CASE 1: in a string.
+ ((eq literal 'string)
+ (c-add-syntax 'string (c-point 'bopl)))
+
+ ;; CASE 2: in a C or C++ style comment.
+ ((and (memq literal '(c c++))
+ ;; This is a kludge for XEmacs where we use
+ ;; `buffer-syntactic-context', which doesn't correctly
+ ;; recognize "\*/" to end a block comment.
+ ;; `parse-partial-sexp' which is used by
+ ;; `c-literal-limits' will however do that in most
+ ;; versions, which results in that we get nil from
+ ;; `c-literal-limits' even when `c-in-literal' claims
+ ;; we're inside a comment.
+ (setq placeholder (c-literal-limits lim)))
+ (c-add-syntax literal (car placeholder)))
+
+ ;; CASE 3: in a cpp preprocessor macro continuation.
+ ((and (save-excursion
+ (when (c-beginning-of-macro)
+ (setq macro-start (point))))
+ (/= macro-start (c-point 'boi))
+ (progn
+ (setq tmpsymbol 'cpp-macro-cont)
+ (or (not c-syntactic-indentation-in-macros)
+ (save-excursion
+ (goto-char macro-start)
+ ;; If at the beginning of the body of a #define
+ ;; directive then analyze as cpp-define-intro
+ ;; only. Go on with the syntactic analysis
+ ;; otherwise. in-macro-expr is set if we're in a
+ ;; cpp expression, i.e. before the #define body
+ ;; or anywhere in a non-#define directive.
+ (if (c-forward-to-cpp-define-body)
+ (let ((indent-boi (c-point 'boi indent-point)))
+ (setq in-macro-expr (> (point) indent-boi)
+ tmpsymbol 'cpp-define-intro)
+ (= (point) indent-boi))
+ (setq in-macro-expr t)
+ nil)))))
+ (c-add-syntax tmpsymbol macro-start)
+ (setq macro-start nil))
+
+ ;; CASE 11: an else clause?
+ ((looking-at "else\\>[^_]")
+ (c-beginning-of-statement-1 containing-sexp)
+ (c-add-stmt-syntax 'else-clause nil t
+ containing-sexp paren-state))
- ;; CASE 12: while closure of a do/while construct?
- ((and (looking-at "while\\>[^_]")
- (save-excursion
- (prog1 (eq (c-beginning-of-statement-1 containing-sexp)
- 'beginning)
- (setq placeholder (point)))))
- (goto-char placeholder)
- (c-add-stmt-syntax 'do-while-closure nil t
- containing-sexp paren-state))
+ ;; CASE 12: while closure of a do/while construct?
+ ((and (looking-at "while\\>[^_]")
+ (save-excursion
+ (prog1 (eq (c-beginning-of-statement-1 containing-sexp)
+ 'beginning)
+ (setq placeholder (point)))))
+ (goto-char placeholder)
+ (c-add-stmt-syntax 'do-while-closure nil t
+ containing-sexp paren-state))
- ;; CASE 13: A catch or finally clause? This case is simpler
- ;; than if-else and do-while, because a block is required
- ;; after every try, catch and finally.
- ((save-excursion
- (and (cond ((c-major-mode-is 'c++-mode)
- (looking-at "catch\\>[^_]"))
- ((c-major-mode-is 'java-mode)
- (looking-at "\\(catch\\|finally\\)\\>[^_]")))
- (and (c-safe (c-backward-syntactic-ws)
- (c-backward-sexp)
- t)
- (eq (char-after) ?{)
- (c-safe (c-backward-syntactic-ws)
- (c-backward-sexp)
- t)
- (if (eq (char-after) ?\()
- (c-safe (c-backward-sexp) t)
- t))
- (looking-at "\\(try\\|catch\\)\\>[^_]")
- (setq placeholder (point))))
- (goto-char placeholder)
- (c-add-stmt-syntax 'catch-clause nil t
- containing-sexp paren-state))
+ ;; CASE 13: A catch or finally clause? This case is simpler
+ ;; than if-else and do-while, because a block is required
+ ;; after every try, catch and finally.
+ ((save-excursion
+ (and (cond ((c-major-mode-is 'c++-mode)
+ (looking-at "catch\\>[^_]"))
+ ((c-major-mode-is 'java-mode)
+ (looking-at "\\(catch\\|finally\\)\\>[^_]")))
+ (and (c-safe (c-backward-syntactic-ws)
+ (c-backward-sexp)
+ t)
+ (eq (char-after) ?{)
+ (c-safe (c-backward-syntactic-ws)
+ (c-backward-sexp)
+ t)
+ (if (eq (char-after) ?\()
+ (c-safe (c-backward-sexp) t)
+ t))
+ (looking-at "\\(try\\|catch\\)\\>[^_]")
+ (setq placeholder (point))))
+ (goto-char placeholder)
+ (c-add-stmt-syntax 'catch-clause nil t
+ containing-sexp paren-state))
- ;; CASE 18: A substatement we can recognize by keyword.
- ((save-excursion
- (and c-opt-block-stmt-key
- (not (eq char-before-ip ?\;))
- (not (c-at-vsemi-p before-ws-ip))
- (not (memq char-after-ip '(?\) ?\] ?,)))
- (or (not (eq char-before-ip ?}))
- (c-looking-at-inexpr-block-backward c-state-cache))
- (> (point)
- (progn
- ;; Ought to cache the result from the
- ;; c-beginning-of-statement-1 calls here.
+ ;; CASE 18: A substatement we can recognize by keyword.
+ ((save-excursion
+ (and c-opt-block-stmt-key
+ (not (eq char-before-ip ?\;))
+ (not (c-at-vsemi-p before-ws-ip))
+ (not (memq char-after-ip '(?\) ?\] ?,)))
+ (or (not (eq char-before-ip ?}))
+ (c-looking-at-inexpr-block-backward c-state-cache))
+ (> (point)
+ (progn
+ ;; Ought to cache the result from the
+ ;; c-beginning-of-statement-1 calls here.
+ (setq placeholder (point))
+ (while (eq (setq step-type
+ (c-beginning-of-statement-1 lim))
+ 'label))
+ (if (eq step-type 'previous)
+ (goto-char placeholder)
(setq placeholder (point))
- (while (eq (setq step-type
- (c-beginning-of-statement-1 lim))
- 'label))
- (if (eq step-type 'previous)
- (goto-char placeholder)
- (setq placeholder (point))
- (if (and (eq step-type 'same)
- (not (looking-at c-opt-block-stmt-key)))
- ;; Step up to the containing statement if we
- ;; stayed in the same one.
- (let (step)
- (while (eq
- (setq step
- (c-beginning-of-statement-1 lim))
- 'label))
- (if (eq step 'up)
- (setq placeholder (point))
- ;; There was no containing statement afterall.
- (goto-char placeholder)))))
- placeholder))
- (if (looking-at c-block-stmt-2-key)
- ;; Require a parenthesis after these keywords.
- ;; Necessary to catch e.g. synchronized in Java,
- ;; which can be used both as statement and
- ;; modifier.
- (and (zerop (c-forward-token-2 1 nil))
- (eq (char-after) ?\())
- (looking-at c-opt-block-stmt-key))))
-
- (if (eq step-type 'up)
- ;; CASE 18A: Simple substatement.
- (progn
- (goto-char placeholder)
- (cond
- ((eq char-after-ip ?{)
- (c-add-stmt-syntax 'substatement-open nil nil
- containing-sexp paren-state))
- ((save-excursion
- (goto-char indent-point)
- (back-to-indentation)
- (c-forward-label))
- (c-add-stmt-syntax 'substatement-label nil nil
- containing-sexp paren-state))
- (t
- (c-add-stmt-syntax 'substatement nil nil
- containing-sexp paren-state))))
-
- ;; CASE 18B: Some other substatement. This is shared
- ;; with case 10.
- (c-guess-continued-construct indent-point
- char-after-ip
- placeholder
- lim
- paren-state)))
-
- ;; CASE 14: A case or default label
- ((looking-at c-label-kwds-regexp)
- (if containing-sexp
- (progn
- (goto-char containing-sexp)
- (setq lim (c-most-enclosing-brace c-state-cache
- containing-sexp))
- (c-backward-to-block-anchor lim)
- (c-add-stmt-syntax 'case-label nil t lim paren-state))
- ;; Got a bogus label at the top level. In lack of better
- ;; alternatives, anchor it on (point-min).
- (c-add-syntax 'case-label (point-min))))
-
- ;; CASE 15: any other label
- ((save-excursion
- (back-to-indentation)
- (and (not (looking-at c-syntactic-ws-start))
- (c-forward-label)))
- (cond (containing-decl-open
- (setq placeholder (c-add-class-syntax 'inclass
- containing-decl-open
- containing-decl-start
- containing-decl-kwd
- paren-state))
- ;; Append access-label with the same anchor point as
- ;; inclass gets.
- (c-append-syntax 'access-label placeholder))
-
- (containing-sexp
- (goto-char containing-sexp)
- (setq lim (c-most-enclosing-brace c-state-cache
- containing-sexp))
- (save-excursion
- (setq tmpsymbol
- (if (and (eq (c-beginning-of-statement-1 lim) 'up)
- (looking-at "switch\\>[^_]"))
- ;; If the surrounding statement is a switch then
- ;; let's analyze all labels as switch labels, so
- ;; that they get lined up consistently.
- 'case-label
- 'label)))
- (c-backward-to-block-anchor lim)
- (c-add-stmt-syntax tmpsymbol nil t lim paren-state))
+ (if (and (eq step-type 'same)
+ (not (looking-at c-opt-block-stmt-key)))
+ ;; Step up to the containing statement if we
+ ;; stayed in the same one.
+ (let (step)
+ (while (eq
+ (setq step
+ (c-beginning-of-statement-1 lim))
+ 'label))
+ (if (eq step 'up)
+ (setq placeholder (point))
+ ;; There was no containing statement afterall.
+ (goto-char placeholder)))))
+ placeholder))
+ (if (looking-at c-block-stmt-2-key)
+ ;; Require a parenthesis after these keywords.
+ ;; Necessary to catch e.g. synchronized in Java,
+ ;; which can be used both as statement and
+ ;; modifier.
+ (and (zerop (c-forward-token-2 1 nil))
+ (eq (char-after) ?\())
+ (looking-at c-opt-block-stmt-key))))
+
+ (if (eq step-type 'up)
+ ;; CASE 18A: Simple substatement.
+ (progn
+ (goto-char placeholder)
+ (cond
+ ((eq char-after-ip ?{)
+ (c-add-stmt-syntax 'substatement-open nil nil
+ containing-sexp paren-state))
+ ((save-excursion
+ (goto-char indent-point)
+ (back-to-indentation)
+ (c-forward-label))
+ (c-add-stmt-syntax 'substatement-label nil nil
+ containing-sexp paren-state))
+ (t
+ (c-add-stmt-syntax 'substatement nil nil
+ containing-sexp paren-state))))
+
+ ;; CASE 18B: Some other substatement. This is shared
+ ;; with case 10.
+ (c-guess-continued-construct indent-point
+ char-after-ip
+ placeholder
+ lim
+ paren-state)))
- (t
- ;; A label on the top level. Treat it as a class
- ;; context. (point-min) is the closest we get to the
- ;; class open brace.
- (c-add-syntax 'access-label (point-min)))))
+ ;; CASE 14: A case or default label
+ ((looking-at c-label-kwds-regexp)
+ (if containing-sexp
+ (progn
+ (goto-char containing-sexp)
+ (setq lim (c-most-enclosing-brace c-state-cache
+ containing-sexp))
+ (c-backward-to-block-anchor lim)
+ (c-add-stmt-syntax 'case-label nil t lim paren-state))
+ ;; Got a bogus label at the top level. In lack of better
+ ;; alternatives, anchor it on (point-min).
+ (c-add-syntax 'case-label (point-min))))
- ;; CASE 4: In-expression statement. C.f. cases 7B, 16A and
- ;; 17E.
- ((setq placeholder (c-looking-at-inexpr-block
- (c-safe-position containing-sexp paren-state)
- containing-sexp
- ;; Have to turn on the heuristics after
- ;; the point even though it doesn't work
- ;; very well. C.f. test case class-16.pike.
- t))
- (setq tmpsymbol (assq (car placeholder)
- '((inexpr-class . class-open)
- (inexpr-statement . block-open))))
- (if tmpsymbol
- ;; It's a statement block or an anonymous class.
- (setq tmpsymbol (cdr tmpsymbol))
- ;; It's a Pike lambda. Check whether we are between the
- ;; lambda keyword and the argument list or at the defun
- ;; opener.
- (setq tmpsymbol (if (eq char-after-ip ?{)
- 'inline-open
- 'lambda-intro-cont)))
- (goto-char (cdr placeholder))
+ ;; CASE 15: any other label
+ ((save-excursion
(back-to-indentation)
- (c-add-stmt-syntax tmpsymbol nil t
- (c-most-enclosing-brace c-state-cache (point))
- paren-state)
- (unless (eq (point) (cdr placeholder))
- (c-add-syntax (car placeholder))))
-
- ;; CASE 5: Line is inside a declaration level block or at top level.
- ((or containing-decl-open (null containing-sexp))
- (cond
-
- ;; CASE 5A: we are looking at a defun, brace list, class,
- ;; or inline-inclass method opening brace
- ((setq special-brace-list
- (or (and c-special-brace-lists
- (c-looking-at-special-brace-list))
- (eq char-after-ip ?{)))
- (cond
+ (and (not (looking-at c-syntactic-ws-start))
+ (c-forward-label)))
+ (cond (containing-decl-open
+ (setq placeholder (c-add-class-syntax 'inclass
+ containing-decl-open
+ containing-decl-start
+ containing-decl-kwd
+ paren-state))
+ ;; Append access-label with the same anchor point as
+ ;; inclass gets.
+ (c-append-syntax 'access-label placeholder))
+
+ (containing-sexp
+ (goto-char containing-sexp)
+ (setq lim (c-most-enclosing-brace c-state-cache
+ containing-sexp))
+ (save-excursion
+ (setq tmpsymbol
+ (if (and (eq (c-beginning-of-statement-1 lim) 'up)
+ (looking-at "switch\\>[^_]"))
+ ;; If the surrounding statement is a switch then
+ ;; let's analyze all labels as switch labels, so
+ ;; that they get lined up consistently.
+ 'case-label
+ 'label)))
+ (c-backward-to-block-anchor lim)
+ (c-add-stmt-syntax tmpsymbol nil t lim paren-state))
- ;; CASE 5A.1: Non-class declaration block open.
- ((save-excursion
- (let (tmp)
- (and (eq char-after-ip ?{)
- (setq tmp (c-looking-at-decl-block containing-sexp t))
- (progn
- (setq placeholder (point))
- (goto-char tmp)
- (looking-at c-symbol-key))
- (c-keyword-member
- (c-keyword-sym (setq keyword (match-string 0)))
- 'c-other-block-decl-kwds))))
- (goto-char placeholder)
- (c-add-stmt-syntax
- (if (string-equal keyword "extern")
- ;; Special case for extern-lang-open.
- 'extern-lang-open
- (intern (concat keyword "-open")))
- nil t containing-sexp paren-state))
-
- ;; CASE 5A.2: we are looking at a class opening brace
- ((save-excursion
- (goto-char indent-point)
- (skip-chars-forward " \t")
- (and (eq (char-after) ?{)
- (c-looking-at-decl-block containing-sexp t)
- (setq placeholder (point))))
- (c-add-syntax 'class-open placeholder))
-
- ;; CASE 5A.3: brace list open
- ((save-excursion
- (c-beginning-of-decl-1 lim)
- (while (looking-at c-specifier-key)
- (goto-char (match-end 1))
- (c-forward-syntactic-ws indent-point))
- (setq placeholder (c-point 'boi))
- (or (consp special-brace-list)
- (and (or (save-excursion
- (goto-char indent-point)
- (setq tmpsymbol nil)
- (while (and (> (point) placeholder)
- (zerop (c-backward-token-2 1 t))
- (/= (char-after) ?=))
- (and c-opt-inexpr-brace-list-key
- (not tmpsymbol)
- (looking-at c-opt-inexpr-brace-list-key)
- (setq tmpsymbol 'topmost-intro-cont)))
- (eq (char-after) ?=))
- (looking-at c-brace-list-key))
- (save-excursion
- (while (and (< (point) indent-point)
- (zerop (c-forward-token-2 1 t))
- (not (memq (char-after) '(?\; ?\()))))
- (not (memq (char-after) '(?\; ?\()))
- ))))
- (if (and (not c-auto-newline-analysis)
- (c-major-mode-is 'java-mode)
- (eq tmpsymbol 'topmost-intro-cont))
- ;; We're in Java and have found that the open brace
- ;; belongs to a "new Foo[]" initialization list,
- ;; which means the brace list is part of an
- ;; expression and not a top level definition. We
- ;; therefore treat it as any topmost continuation
- ;; even though the semantically correct symbol still
- ;; is brace-list-open, on the same grounds as in
- ;; case B.2.
- (progn
- (c-beginning-of-statement-1 lim)
- (c-add-syntax 'topmost-intro-cont (c-point 'boi)))
- (c-add-syntax 'brace-list-open placeholder)))
-
- ;; CASE 5A.4: inline defun open
- ((and containing-decl-open
- (not (c-keyword-member containing-decl-kwd
- 'c-other-block-decl-kwds)))
- (c-add-syntax 'inline-open)
- (c-add-class-syntax 'inclass
- containing-decl-open
- containing-decl-start
- containing-decl-kwd
- paren-state))
-
- ;; CASE 5A.5: ordinary defun open
- (t
- (save-excursion
- (c-beginning-of-decl-1 lim)
- (while (looking-at c-specifier-key)
- (goto-char (match-end 1))
- (c-forward-syntactic-ws indent-point))
- (c-add-syntax 'defun-open (c-point 'boi))
- ;; Bogus to use bol here, but it's the legacy. (Resolved,
- ;; 2007-11-09)
- ))))
-
- ;; CASE 5B: After a function header but before the body (or
- ;; the ending semicolon if there's no body).
- ((save-excursion
- (when (setq placeholder (c-just-after-func-arglist-p lim))
- (setq tmp-pos (point))))
- (cond
+ (t
+ ;; A label on the top level. Treat it as a class
+ ;; context. (point-min) is the closest we get to the
+ ;; class open brace.
+ (c-add-syntax 'access-label (point-min)))))
+
+ ;; CASE 4: In-expression statement. C.f. cases 7B, 16A and
+ ;; 17E.
+ ((setq placeholder (c-looking-at-inexpr-block
+ (c-safe-position containing-sexp paren-state)
+ containing-sexp
+ ;; Have to turn on the heuristics after
+ ;; the point even though it doesn't work
+ ;; very well. C.f. test case class-16.pike.
+ t))
+ (setq tmpsymbol (assq (car placeholder)
+ '((inexpr-class . class-open)
+ (inexpr-statement . block-open))))
+ (if tmpsymbol
+ ;; It's a statement block or an anonymous class.
+ (setq tmpsymbol (cdr tmpsymbol))
+ ;; It's a Pike lambda. Check whether we are between the
+ ;; lambda keyword and the argument list or at the defun
+ ;; opener.
+ (setq tmpsymbol (if (eq char-after-ip ?{)
+ 'inline-open
+ 'lambda-intro-cont)))
+ (goto-char (cdr placeholder))
+ (back-to-indentation)
+ (c-add-stmt-syntax tmpsymbol nil t
+ (c-most-enclosing-brace c-state-cache (point))
+ paren-state)
+ (unless (eq (point) (cdr placeholder))
+ (c-add-syntax (car placeholder))))
- ;; CASE 5B.1: Member init list.
- ((eq (char-after tmp-pos) ?:)
- (if (or (> tmp-pos indent-point)
- (= (c-point 'bosws) (1+ tmp-pos)))
- (progn
- ;; There is no preceding member init clause.
- ;; Indent relative to the beginning of indentation
- ;; for the topmost-intro line that contains the
- ;; prototype's open paren.
- (goto-char placeholder)
- (c-add-syntax 'member-init-intro (c-point 'boi)))
- ;; Indent relative to the first member init clause.
- (goto-char (1+ tmp-pos))
- (c-forward-syntactic-ws)
- (c-add-syntax 'member-init-cont (point))))
+ ;; CASE 5: Line is inside a declaration level block or at top level.
+ ((or containing-decl-open (null containing-sexp))
+ (cond
- ;; CASE 5B.2: K&R arg decl intro
- ((and c-recognize-knr-p
- (c-in-knr-argdecl lim))
- (c-beginning-of-statement-1 lim)
- (c-add-syntax 'knr-argdecl-intro (c-point 'boi))
- (if containing-decl-open
- (c-add-class-syntax 'inclass
- containing-decl-open
- containing-decl-start
- containing-decl-kwd
- paren-state)))
-
- ;; CASE 5B.4: Nether region after a C++ or Java func
- ;; decl, which could include a `throws' declaration.
- (t
- (c-beginning-of-statement-1 lim)
- (c-add-syntax 'func-decl-cont (c-point 'boi))
- )))
+ ;; CASE 5A: we are looking at a defun, brace list, class,
+ ;; or inline-inclass method opening brace
+ ((setq special-brace-list
+ (or (and c-special-brace-lists
+ (c-looking-at-special-brace-list))
+ (eq char-after-ip ?{)))
+ (cond
- ;; CASE 5C: inheritance line. could be first inheritance
- ;; line, or continuation of a multiple inheritance
- ((or (and (c-major-mode-is 'c++-mode)
+ ;; CASE 5A.1: Non-class declaration block open.
+ ((save-excursion
+ (let (tmp)
+ (and (eq char-after-ip ?{)
+ (setq tmp (c-looking-at-decl-block containing-sexp t))
(progn
- (when (eq char-after-ip ?,)
- (skip-chars-forward " \t")
- (forward-char))
- (looking-at c-opt-postfix-decl-spec-key)))
- (and (or (eq char-before-ip ?:)
- ;; watch out for scope operator
- (save-excursion
- (and (eq char-after-ip ?:)
- (c-safe (forward-char 1) t)
- (not (eq (char-after) ?:))
- )))
- (save-excursion
- (c-backward-syntactic-ws lim)
- (if (eq char-before-ip ?:)
- (progn
- (forward-char -1)
- (c-backward-syntactic-ws lim)))
- (back-to-indentation)
- (looking-at c-class-key)))
- ;; for Java
- (and (c-major-mode-is 'java-mode)
- (let ((fence (save-excursion
- (c-beginning-of-statement-1 lim)
- (point)))
- cont done)
- (save-excursion
- (while (not done)
- (cond ((looking-at c-opt-postfix-decl-spec-key)
- (setq injava-inher (cons cont (point))
- done t))
- ((or (not (c-safe (c-forward-sexp -1) t))
- (<= (point) fence))
- (setq done t))
- )
- (setq cont t)))
- injava-inher)
- (not (c-crosses-statement-barrier-p (cdr injava-inher)
- (point)))
- ))
- (cond
-
- ;; CASE 5C.1: non-hanging colon on an inher intro
- ((eq char-after-ip ?:)
- (c-beginning-of-statement-1 lim)
- (c-add-syntax 'inher-intro (c-point 'boi))
- ;; don't add inclass symbol since relative point already
- ;; contains any class offset
- )
+ (setq placeholder (point))
+ (goto-char tmp)
+ (looking-at c-symbol-key))
+ (c-keyword-member
+ (c-keyword-sym (setq keyword (match-string 0)))
+ 'c-other-block-decl-kwds))))
+ (goto-char placeholder)
+ (c-add-stmt-syntax
+ (if (string-equal keyword "extern")
+ ;; Special case for extern-lang-open.
+ 'extern-lang-open
+ (intern (concat keyword "-open")))
+ nil t containing-sexp paren-state))
- ;; CASE 5C.2: hanging colon on an inher intro
- ((eq char-before-ip ?:)
- (c-beginning-of-statement-1 lim)
- (c-add-syntax 'inher-intro (c-point 'boi))
- (if containing-decl-open
- (c-add-class-syntax 'inclass
- containing-decl-open
- containing-decl-start
- containing-decl-kwd
- paren-state)))
-
- ;; CASE 5C.3: in a Java implements/extends
- (injava-inher
- (let ((where (cdr injava-inher))
- (cont (car injava-inher)))
- (goto-char where)
- (cond ((looking-at "throws\\>[^_]")
- (c-add-syntax 'func-decl-cont
- (progn (c-beginning-of-statement-1 lim)
- (c-point 'boi))))
- (cont (c-add-syntax 'inher-cont where))
- (t (c-add-syntax 'inher-intro
- (progn (goto-char (cdr injava-inher))
- (c-beginning-of-statement-1 lim)
- (point))))
- )))
-
- ;; CASE 5C.4: a continued inheritance line
- (t
- (c-beginning-of-inheritance-list lim)
- (c-add-syntax 'inher-cont (point))
- ;; don't add inclass symbol since relative point already
- ;; contains any class offset
- )))
-
- ;; CASE 5D: this could be a top-level initialization, a
- ;; member init list continuation, or a template argument
- ;; list continuation.
+ ;; CASE 5A.2: we are looking at a class opening brace
((save-excursion
- ;; Note: We use the fact that lim is always after any
- ;; preceding brace sexp.
- (if c-recognize-<>-arglists
- (while (and
- (progn
- (c-syntactic-skip-backward "^;,=<>" lim t)
- (> (point) lim))
- (or
- (when c-overloadable-operators-regexp
- (when (setq placeholder (c-after-special-operator-id lim))
- (goto-char placeholder)
- t))
- (cond
- ((eq (char-before) ?>)
- (or (c-backward-<>-arglist nil lim)
- (backward-char))
- t)
- ((eq (char-before) ?<)
- (backward-char)
- (if (save-excursion
- (c-forward-<>-arglist nil))
- (progn (forward-char)
- nil)
- t))
- (t nil)))))
- ;; NB: No c-after-special-operator-id stuff in this
- ;; clause - we assume only C++ needs it.
- (c-syntactic-skip-backward "^;,=" lim t))
- (memq (char-before) '(?, ?= ?<)))
- (cond
-
- ;; CASE 5D.3: perhaps a template list continuation?
- ((and (c-major-mode-is 'c++-mode)
- (save-excursion
- (save-restriction
- (c-with-syntax-table c++-template-syntax-table
- (goto-char indent-point)
- (setq placeholder (c-up-list-backward))
- (and placeholder
- (eq (char-after placeholder) ?<))))))
- (c-with-syntax-table c++-template-syntax-table
- (goto-char placeholder)
- (c-beginning-of-statement-1 lim t)
- (if (save-excursion
- (c-backward-syntactic-ws lim)
- (eq (char-before) ?<))
- ;; In a nested template arglist.
- (progn
- (goto-char placeholder)
- (c-syntactic-skip-backward "^,;" lim t)
- (c-forward-syntactic-ws))
- (back-to-indentation)))
- ;; FIXME: Should use c-add-stmt-syntax, but it's not yet
- ;; template aware.
- (c-add-syntax 'template-args-cont (point) placeholder))
-
- ;; CASE 5D.4: perhaps a multiple inheritance line?
- ((and (c-major-mode-is 'c++-mode)
- (save-excursion
- (c-beginning-of-statement-1 lim)
- (setq placeholder (point))
- (if (looking-at "static\\>[^_]")
- (c-forward-token-2 1 nil indent-point))
- (and (looking-at c-class-key)
- (zerop (c-forward-token-2 2 nil indent-point))
- (if (eq (char-after) ?<)
- (c-with-syntax-table c++-template-syntax-table
- (zerop (c-forward-token-2 1 t indent-point)))
- t)
- (eq (char-after) ?:))))
- (goto-char placeholder)
- (c-add-syntax 'inher-cont (c-point 'boi)))
-
- ;; CASE 5D.5: Continuation of the "expression part" of a
- ;; top level construct. Or, perhaps, an unrecognised construct.
- (t
- (while (and (setq placeholder (point))
- (eq (car (c-beginning-of-decl-1 containing-sexp))
- 'same)
- (save-excursion
- (c-backward-syntactic-ws)
- (eq (char-before) ?}))
- (< (point) placeholder)))
- (c-add-stmt-syntax
- (cond
- ((eq (point) placeholder) 'statement) ; unrecognised construct
- ;; A preceding comma at the top level means that a
- ;; new variable declaration starts here. Use
- ;; topmost-intro-cont for it, for consistency with
- ;; the first variable declaration. C.f. case 5N.
- ((eq char-before-ip ?,) 'topmost-intro-cont)
- (t 'statement-cont))
- nil nil containing-sexp paren-state))
- ))
-
- ;; CASE 5F: Close of a non-class declaration level block.
- ((and (eq char-after-ip ?})
- (c-keyword-member containing-decl-kwd
- 'c-other-block-decl-kwds))
- ;; This is inconsistent: Should use `containing-decl-open'
- ;; here if it's at boi, like in case 5J.
- (goto-char containing-decl-start)
- (c-add-stmt-syntax
- (if (string-equal (symbol-name containing-decl-kwd) "extern")
- ;; Special case for compatibility with the
- ;; extern-lang syntactic symbols.
- 'extern-lang-close
- (intern (concat (symbol-name containing-decl-kwd)
- "-close")))
- nil t
- (c-most-enclosing-brace paren-state (point))
- paren-state))
-
- ;; CASE 5G: we are looking at the brace which closes the
- ;; enclosing nested class decl
- ((and containing-sexp
- (eq char-after-ip ?})
- (eq containing-decl-open containing-sexp))
- (c-add-class-syntax 'class-close
+ (goto-char indent-point)
+ (skip-chars-forward " \t")
+ (and (eq (char-after) ?{)
+ (c-looking-at-decl-block containing-sexp t)
+ (setq placeholder (point))))
+ (c-add-syntax 'class-open placeholder))
+
+ ;; CASE 5A.3: brace list open
+ ((save-excursion
+ (c-beginning-of-decl-1 lim)
+ (while (looking-at c-specifier-key)
+ (goto-char (match-end 1))
+ (c-forward-syntactic-ws indent-point))
+ (setq placeholder (c-point 'boi))
+ (or (consp special-brace-list)
+ (and (or (save-excursion
+ (goto-char indent-point)
+ (setq tmpsymbol nil)
+ (while (and (> (point) placeholder)
+ (zerop (c-backward-token-2 1 t))
+ (/= (char-after) ?=))
+ (and c-opt-inexpr-brace-list-key
+ (not tmpsymbol)
+ (looking-at c-opt-inexpr-brace-list-key)
+ (setq tmpsymbol 'topmost-intro-cont)))
+ (eq (char-after) ?=))
+ (looking-at c-brace-list-key))
+ (save-excursion
+ (while (and (< (point) indent-point)
+ (zerop (c-forward-token-2 1 t))
+ (not (memq (char-after) '(?\; ?\()))))
+ (not (memq (char-after) '(?\; ?\()))
+ ))))
+ (if (and (not c-auto-newline-analysis)
+ (c-major-mode-is 'java-mode)
+ (eq tmpsymbol 'topmost-intro-cont))
+ ;; We're in Java and have found that the open brace
+ ;; belongs to a "new Foo[]" initialization list,
+ ;; which means the brace list is part of an
+ ;; expression and not a top level definition. We
+ ;; therefore treat it as any topmost continuation
+ ;; even though the semantically correct symbol still
+ ;; is brace-list-open, on the same grounds as in
+ ;; case B.2.
+ (progn
+ (c-beginning-of-statement-1 lim)
+ (c-add-syntax 'topmost-intro-cont (c-point 'boi)))
+ (c-add-syntax 'brace-list-open placeholder)))
+
+ ;; CASE 5A.4: inline defun open
+ ((and containing-decl-open
+ (not (c-keyword-member containing-decl-kwd
+ 'c-other-block-decl-kwds)))
+ (c-add-syntax 'inline-open)
+ (c-add-class-syntax 'inclass
containing-decl-open
containing-decl-start
containing-decl-kwd
paren-state))
- ;; CASE 5H: we could be looking at subsequent knr-argdecls
+ ;; CASE 5A.5: ordinary defun open
+ (t
+ (save-excursion
+ (c-beginning-of-decl-1 lim)
+ (while (looking-at c-specifier-key)
+ (goto-char (match-end 1))
+ (c-forward-syntactic-ws indent-point))
+ (c-add-syntax 'defun-open (c-point 'boi))
+ ;; Bogus to use bol here, but it's the legacy. (Resolved,
+ ;; 2007-11-09)
+ ))))
+
+ ;; CASE 5B: After a function header but before the body (or
+ ;; the ending semicolon if there's no body).
+ ((save-excursion
+ (when (setq placeholder (c-just-after-func-arglist-p lim))
+ (setq tmp-pos (point))))
+ (cond
+
+ ;; CASE 5B.1: Member init list.
+ ((eq (char-after tmp-pos) ?:)
+ (if (or (> tmp-pos indent-point)
+ (= (c-point 'bosws) (1+ tmp-pos)))
+ (progn
+ ;; There is no preceding member init clause.
+ ;; Indent relative to the beginning of indentation
+ ;; for the topmost-intro line that contains the
+ ;; prototype's open paren.
+ (goto-char placeholder)
+ (c-add-syntax 'member-init-intro (c-point 'boi)))
+ ;; Indent relative to the first member init clause.
+ (goto-char (1+ tmp-pos))
+ (c-forward-syntactic-ws)
+ (c-add-syntax 'member-init-cont (point))))
+
+ ;; CASE 5B.2: K&R arg decl intro
((and c-recognize-knr-p
- (not containing-sexp) ; can't be knr inside braces.
- (not (eq char-before-ip ?}))
- (save-excursion
- (setq placeholder (cdr (c-beginning-of-decl-1 lim)))
- (and placeholder
- ;; Do an extra check to avoid tripping up on
- ;; statements that occur in invalid contexts
- ;; (e.g. in macro bodies where we don't really
- ;; know the context of what we're looking at).
- (not (and c-opt-block-stmt-key
- (looking-at c-opt-block-stmt-key)))))
- (< placeholder indent-point))
- (goto-char placeholder)
- (c-add-syntax 'knr-argdecl (point)))
-
- ;; CASE 5I: ObjC method definition.
- ((and c-opt-method-key
- (looking-at c-opt-method-key))
- (c-beginning-of-statement-1 nil t)
- (if (= (point) indent-point)
- ;; Handle the case when it's the first (non-comment)
- ;; thing in the buffer. Can't look for a 'same return
- ;; value from cbos1 since ObjC directives currently
- ;; aren't recognized fully, so that we get 'same
- ;; instead of 'previous if it moved over a preceding
- ;; directive.
- (goto-char (point-min)))
- (c-add-syntax 'objc-method-intro (c-point 'boi)))
-
- ;; CASE 5P: AWK pattern or function or continuation
- ;; thereof.
- ((c-major-mode-is 'awk-mode)
- (setq placeholder (point))
- (c-add-stmt-syntax
- (if (and (eq (c-beginning-of-statement-1) 'same)
- (/= (point) placeholder))
- 'topmost-intro-cont
- 'topmost-intro)
- nil nil
- containing-sexp paren-state))
-
- ;; CASE 5N: At a variable declaration that follows a class
- ;; definition or some other block declaration that doesn't
- ;; end at the closing '}'. C.f. case 5D.5.
- ((progn
- (c-backward-syntactic-ws lim)
- (and (eq (char-before) ?})
+ (c-in-knr-argdecl lim))
+ (c-beginning-of-statement-1 lim)
+ (c-add-syntax 'knr-argdecl-intro (c-point 'boi))
+ (if containing-decl-open
+ (c-add-class-syntax 'inclass
+ containing-decl-open
+ containing-decl-start
+ containing-decl-kwd
+ paren-state)))
+
+ ;; CASE 5B.4: Nether region after a C++ or Java func
+ ;; decl, which could include a `throws' declaration.
+ (t
+ (c-beginning-of-statement-1 lim)
+ (c-add-syntax 'func-decl-cont (c-point 'boi))
+ )))
+
+ ;; CASE 5C: inheritance line. could be first inheritance
+ ;; line, or continuation of a multiple inheritance
+ ((or (and (c-major-mode-is 'c++-mode)
+ (progn
+ (when (eq char-after-ip ?,)
+ (skip-chars-forward " \t")
+ (forward-char))
+ (looking-at c-opt-postfix-decl-spec-key)))
+ (and (or (eq char-before-ip ?:)
+ ;; watch out for scope operator
+ (save-excursion
+ (and (eq char-after-ip ?:)
+ (c-safe (forward-char 1) t)
+ (not (eq (char-after) ?:))
+ )))
(save-excursion
- (let ((start (point)))
- (if (and c-state-cache
- (consp (car c-state-cache))
- (eq (cdar c-state-cache) (point)))
- ;; Speed up the backward search a bit.
- (goto-char (caar c-state-cache)))
- (c-beginning-of-decl-1 containing-sexp)
- (setq placeholder (point))
- (if (= start (point))
- ;; The '}' is unbalanced.
- nil
- (c-end-of-decl-1)
- (>= (point) indent-point))))))
- (goto-char placeholder)
- (c-add-stmt-syntax 'topmost-intro-cont nil nil
- containing-sexp paren-state))
+ (c-backward-syntactic-ws lim)
+ (if (eq char-before-ip ?:)
+ (progn
+ (forward-char -1)
+ (c-backward-syntactic-ws lim)))
+ (back-to-indentation)
+ (looking-at c-class-key)))
+ ;; for Java
+ (and (c-major-mode-is 'java-mode)
+ (let ((fence (save-excursion
+ (c-beginning-of-statement-1 lim)
+ (point)))
+ cont done)
+ (save-excursion
+ (while (not done)
+ (cond ((looking-at c-opt-postfix-decl-spec-key)
+ (setq injava-inher (cons cont (point))
+ done t))
+ ((or (not (c-safe (c-forward-sexp -1) t))
+ (<= (point) fence))
+ (setq done t))
+ )
+ (setq cont t)))
+ injava-inher)
+ (not (c-crosses-statement-barrier-p (cdr injava-inher)
+ (point)))
+ ))
+ (cond
- ;; NOTE: The point is at the end of the previous token here.
+ ;; CASE 5C.1: non-hanging colon on an inher intro
+ ((eq char-after-ip ?:)
+ (c-beginning-of-statement-1 lim)
+ (c-add-syntax 'inher-intro (c-point 'boi))
+ ;; don't add inclass symbol since relative point already
+ ;; contains any class offset
+ )
- ;; CASE 5J: we are at the topmost level, make
- ;; sure we skip back past any access specifiers
- ((and
- ;; A macro continuation line is never at top level.
- (not (and macro-start
- (> indent-point macro-start)))
- (save-excursion
- (setq placeholder (point))
- (or (memq char-before-ip '(?\; ?{ ?} nil))
- (c-at-vsemi-p before-ws-ip)
- (when (and (eq char-before-ip ?:)
- (eq (c-beginning-of-statement-1 lim)
- 'label))
- (c-backward-syntactic-ws lim)
- (setq placeholder (point)))
- (and (c-major-mode-is 'objc-mode)
- (catch 'not-in-directive
- (c-beginning-of-statement-1 lim)
- (setq placeholder (point))
- (while (and (c-forward-objc-directive)
- (< (point) indent-point))
- (c-forward-syntactic-ws)
- (if (>= (point) indent-point)
- (throw 'not-in-directive t))
- (setq placeholder (point)))
- nil)))))
- ;; For historic reasons we anchor at bol of the last
- ;; line of the previous declaration. That's clearly
- ;; highly bogus and useless, and it makes our lives hard
- ;; to remain compatible. :P
- (goto-char placeholder)
- (c-add-syntax 'topmost-intro (c-point 'bol))
+ ;; CASE 5C.2: hanging colon on an inher intro
+ ((eq char-before-ip ?:)
+ (c-beginning-of-statement-1 lim)
+ (c-add-syntax 'inher-intro (c-point 'boi))
(if containing-decl-open
- (if (c-keyword-member containing-decl-kwd
- 'c-other-block-decl-kwds)
- (progn
- (goto-char (c-brace-anchor-point containing-decl-open))
- (c-add-stmt-syntax
- (if (string-equal (symbol-name containing-decl-kwd)
- "extern")
- ;; Special case for compatibility with the
- ;; extern-lang syntactic symbols.
- 'inextern-lang
- (intern (concat "in"
- (symbol-name containing-decl-kwd))))
- nil t
- (c-most-enclosing-brace paren-state (point))
- paren-state))
- (c-add-class-syntax 'inclass
- containing-decl-open
- containing-decl-start
- containing-decl-kwd
- paren-state)))
- (when (and c-syntactic-indentation-in-macros
- macro-start
- (/= macro-start (c-point 'boi indent-point)))
- (c-add-syntax 'cpp-define-intro)
- (setq macro-start nil)))
-
- ;; CASE 5K: we are at an ObjC method definition
- ;; continuation line.
- ((and c-opt-method-key
+ (c-add-class-syntax 'inclass
+ containing-decl-open
+ containing-decl-start
+ containing-decl-kwd
+ paren-state)))
+
+ ;; CASE 5C.3: in a Java implements/extends
+ (injava-inher
+ (let ((where (cdr injava-inher))
+ (cont (car injava-inher)))
+ (goto-char where)
+ (cond ((looking-at "throws\\>[^_]")
+ (c-add-syntax 'func-decl-cont
+ (progn (c-beginning-of-statement-1 lim)
+ (c-point 'boi))))
+ (cont (c-add-syntax 'inher-cont where))
+ (t (c-add-syntax 'inher-intro
+ (progn (goto-char (cdr injava-inher))
+ (c-beginning-of-statement-1 lim)
+ (point))))
+ )))
+
+ ;; CASE 5C.4: a continued inheritance line
+ (t
+ (c-beginning-of-inheritance-list lim)
+ (c-add-syntax 'inher-cont (point))
+ ;; don't add inclass symbol since relative point already
+ ;; contains any class offset
+ )))
+
+ ;; CASE 5D: this could be a top-level initialization, a
+ ;; member init list continuation, or a template argument
+ ;; list continuation.
+ ((save-excursion
+ ;; Note: We use the fact that lim is always after any
+ ;; preceding brace sexp.
+ (if c-recognize-<>-arglists
+ (while (and
+ (progn
+ (c-syntactic-skip-backward "^;,=<>" lim t)
+ (> (point) lim))
+ (or
+ (when c-overloadable-operators-regexp
+ (when (setq placeholder (c-after-special-operator-id lim))
+ (goto-char placeholder)
+ t))
+ (cond
+ ((eq (char-before) ?>)
+ (or (c-backward-<>-arglist nil lim)
+ (backward-char))
+ t)
+ ((eq (char-before) ?<)
+ (backward-char)
+ (if (save-excursion
+ (c-forward-<>-arglist nil))
+ (progn (forward-char)
+ nil)
+ t))
+ (t nil)))))
+ ;; NB: No c-after-special-operator-id stuff in this
+ ;; clause - we assume only C++ needs it.
+ (c-syntactic-skip-backward "^;,=" lim t))
+ (memq (char-before) '(?, ?= ?<)))
+ (cond
+
+ ;; CASE 5D.3: perhaps a template list continuation?
+ ((and (c-major-mode-is 'c++-mode)
+ (save-excursion
+ (save-restriction
+ (c-with-syntax-table c++-template-syntax-table
+ (goto-char indent-point)
+ (setq placeholder (c-up-list-backward))
+ (and placeholder
+ (eq (char-after placeholder) ?<))))))
+ (c-with-syntax-table c++-template-syntax-table
+ (goto-char placeholder)
+ (c-beginning-of-statement-1 lim t)
+ (if (save-excursion
+ (c-backward-syntactic-ws lim)
+ (eq (char-before) ?<))
+ ;; In a nested template arglist.
+ (progn
+ (goto-char placeholder)
+ (c-syntactic-skip-backward "^,;" lim t)
+ (c-forward-syntactic-ws))
+ (back-to-indentation)))
+ ;; FIXME: Should use c-add-stmt-syntax, but it's not yet
+ ;; template aware.
+ (c-add-syntax 'template-args-cont (point) placeholder))
+
+ ;; CASE 5D.4: perhaps a multiple inheritance line?
+ ((and (c-major-mode-is 'c++-mode)
(save-excursion
(c-beginning-of-statement-1 lim)
- (beginning-of-line)
- (when (looking-at c-opt-method-key)
- (setq placeholder (point)))))
- (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
+ (setq placeholder (point))
+ (if (looking-at "static\\>[^_]")
+ (c-forward-token-2 1 nil indent-point))
+ (and (looking-at c-class-key)
+ (zerop (c-forward-token-2 2 nil indent-point))
+ (if (eq (char-after) ?<)
+ (c-with-syntax-table c++-template-syntax-table
+ (zerop (c-forward-token-2 1 t indent-point)))
+ t)
+ (eq (char-after) ?:))))
+ (goto-char placeholder)
+ (c-add-syntax 'inher-cont (c-point 'boi)))
+
+ ;; CASE 5D.5: Continuation of the "expression part" of a
+ ;; top level construct. Or, perhaps, an unrecognised construct.
(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)
- (< (point) indent-point))
- (c-forward-syntactic-ws)
- (setq placeholder (point)))
- (goto-char placeholder))
- (c-add-syntax 'topmost-intro-cont (c-point 'boi)))
+ (while (and (setq placeholder (point))
+ (eq (car (c-beginning-of-decl-1 containing-sexp))
+ 'same)
+ (save-excursion
+ (c-backward-syntactic-ws)
+ (eq (char-before) ?}))
+ (< (point) placeholder)))
+ (c-add-stmt-syntax
+ (cond
+ ((eq (point) placeholder) 'statement) ; unrecognised construct
+ ;; A preceding comma at the top level means that a
+ ;; new variable declaration starts here. Use
+ ;; topmost-intro-cont for it, for consistency with
+ ;; the first variable declaration. C.f. case 5N.
+ ((eq char-before-ip ?,) 'topmost-intro-cont)
+ (t 'statement-cont))
+ nil nil containing-sexp paren-state))
))
- ;; (CASE 6 has been removed.)
+ ;; CASE 5F: Close of a non-class declaration level block.
+ ((and (eq char-after-ip ?})
+ (c-keyword-member containing-decl-kwd
+ 'c-other-block-decl-kwds))
+ ;; This is inconsistent: Should use `containing-decl-open'
+ ;; here if it's at boi, like in case 5J.
+ (goto-char containing-decl-start)
+ (c-add-stmt-syntax
+ (if (string-equal (symbol-name containing-decl-kwd) "extern")
+ ;; Special case for compatibility with the
+ ;; extern-lang syntactic symbols.
+ 'extern-lang-close
+ (intern (concat (symbol-name containing-decl-kwd)
+ "-close")))
+ nil t
+ (c-most-enclosing-brace paren-state (point))
+ paren-state))
+
+ ;; CASE 5G: we are looking at the brace which closes the
+ ;; enclosing nested class decl
+ ((and containing-sexp
+ (eq char-after-ip ?})
+ (eq containing-decl-open containing-sexp))
+ (c-add-class-syntax 'class-close
+ containing-decl-open
+ containing-decl-start
+ containing-decl-kwd
+ paren-state))
+
+ ;; CASE 5H: we could be looking at subsequent knr-argdecls
+ ((and c-recognize-knr-p
+ (not containing-sexp) ; can't be knr inside braces.
+ (not (eq char-before-ip ?}))
+ (save-excursion
+ (setq placeholder (cdr (c-beginning-of-decl-1 lim)))
+ (and placeholder
+ ;; Do an extra check to avoid tripping up on
+ ;; statements that occur in invalid contexts
+ ;; (e.g. in macro bodies where we don't really
+ ;; know the context of what we're looking at).
+ (not (and c-opt-block-stmt-key
+ (looking-at c-opt-block-stmt-key)))))
+ (< placeholder indent-point))
+ (goto-char placeholder)
+ (c-add-syntax 'knr-argdecl (point)))
+
+ ;; CASE 5I: ObjC method definition.
+ ((and c-opt-method-key
+ (looking-at c-opt-method-key))
+ (c-beginning-of-statement-1 nil t)
+ (if (= (point) indent-point)
+ ;; Handle the case when it's the first (non-comment)
+ ;; thing in the buffer. Can't look for a 'same return
+ ;; value from cbos1 since ObjC directives currently
+ ;; aren't recognized fully, so that we get 'same
+ ;; instead of 'previous if it moved over a preceding
+ ;; directive.
+ (goto-char (point-min)))
+ (c-add-syntax 'objc-method-intro (c-point 'boi)))
+
+ ;; CASE 5P: AWK pattern or function or continuation
+ ;; thereof.
+ ((c-major-mode-is 'awk-mode)
+ (setq placeholder (point))
+ (c-add-stmt-syntax
+ (if (and (eq (c-beginning-of-statement-1) 'same)
+ (/= (point) placeholder))
+ 'topmost-intro-cont
+ 'topmost-intro)
+ nil nil
+ containing-sexp paren-state))
+
+ ;; CASE 5N: At a variable declaration that follows a class
+ ;; definition or some other block declaration that doesn't
+ ;; end at the closing '}'. C.f. case 5D.5.
+ ((progn
+ (c-backward-syntactic-ws lim)
+ (and (eq (char-before) ?})
+ (save-excursion
+ (let ((start (point)))
+ (if (and c-state-cache
+ (consp (car c-state-cache))
+ (eq (cdar c-state-cache) (point)))
+ ;; Speed up the backward search a bit.
+ (goto-char (caar c-state-cache)))
+ (c-beginning-of-decl-1 containing-sexp)
+ (setq placeholder (point))
+ (if (= start (point))
+ ;; The '}' is unbalanced.
+ nil
+ (c-end-of-decl-1)
+ (>= (point) indent-point))))))
+ (goto-char placeholder)
+ (c-add-stmt-syntax 'topmost-intro-cont nil nil
+ containing-sexp paren-state))
+
+ ;; NOTE: The point is at the end of the previous token here.
- ;; 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).
+ ;; CASE 5J: we are at the topmost level, make
+ ;; sure we skip back past any access specifiers
+ ((and
+ ;; A macro continuation line is never at top level.
+ (not (and macro-start
+ (> indent-point macro-start)))
+ (save-excursion
+ (setq placeholder (point))
+ (or (memq char-before-ip '(?\; ?{ ?} nil))
+ (c-at-vsemi-p before-ws-ip)
+ (when (and (eq char-before-ip ?:)
+ (eq (c-beginning-of-statement-1 lim)
+ 'label))
+ (c-backward-syntactic-ws lim)
+ (setq placeholder (point)))
+ (and (c-major-mode-is 'objc-mode)
+ (catch 'not-in-directive
+ (c-beginning-of-statement-1 lim)
+ (setq placeholder (point))
+ (while (and (c-forward-objc-directive)
+ (< (point) indent-point))
+ (c-forward-syntactic-ws)
+ (if (>= (point) indent-point)
+ (throw 'not-in-directive t))
+ (setq placeholder (point)))
+ nil)))))
+ ;; For historic reasons we anchor at bol of the last
+ ;; line of the previous declaration. That's clearly
+ ;; highly bogus and useless, and it makes our lives hard
+ ;; to remain compatible. :P
+ (goto-char placeholder)
+ (c-add-syntax 'topmost-intro (c-point 'bol))
+ (if containing-decl-open
+ (if (c-keyword-member containing-decl-kwd
+ 'c-other-block-decl-kwds)
+ (progn
+ (goto-char (c-brace-anchor-point containing-decl-open))
+ (c-add-stmt-syntax
+ (if (string-equal (symbol-name containing-decl-kwd)
+ "extern")
+ ;; Special case for compatibility with the
+ ;; extern-lang syntactic symbols.
+ 'inextern-lang
+ (intern (concat "in"
+ (symbol-name containing-decl-kwd))))
+ nil t
+ (c-most-enclosing-brace paren-state (point))
+ paren-state))
+ (c-add-class-syntax 'inclass
+ containing-decl-open
+ containing-decl-start
+ containing-decl-kwd
+ paren-state)))
+ (when (and c-syntactic-indentation-in-macros
+ macro-start
+ (/= macro-start (c-point 'boi indent-point)))
+ (c-add-syntax 'cpp-define-intro)
+ (setq macro-start nil)))
+
+ ;; CASE 5K: we are at an ObjC method definition
+ ;; continuation line.
+ ((and c-opt-method-key
+ (save-excursion
+ (c-beginning-of-statement-1 lim)
+ (beginning-of-line)
+ (when (looking-at c-opt-method-key)
+ (setq placeholder (point)))))
+ (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
- (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)
+ (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)
+ (< (point) indent-point))
+ (c-forward-syntactic-ws)
+ (setq placeholder (point)))
+ (goto-char placeholder))
+ (c-add-syntax 'topmost-intro-cont (c-point 'boi)))
+ ))
+
+
+ ;; (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
+ ((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.
+ ;; C.f. case 7F.
+ ((memq char-after-ip '(?\) ?\]))
+ (goto-char containing-sexp)
+ (setq placeholder (c-point 'boi))
+ (if (and (c-safe (backward-up-list 1) t)
+ (>= (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))
+ (c-add-stmt-syntax 'arglist-close (list containing-sexp) t
+ (c-most-enclosing-brace paren-state (point))
paren-state))
-
- ;; 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 7A: we are looking at the arglist closing paren.
- ;; C.f. case 7F.
- ((memq char-after-ip '(?\) ?\]))
- (goto-char containing-sexp)
- (setq placeholder (c-point 'boi))
- (if (and (c-safe (backward-up-list 1) t)
- (>= (point) placeholder))
- (progn
- (forward-char)
- (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))
+ ;; 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)
+ paren-state))
+ (if placeholder
+ (setq tmpsymbol '(brace-list-open . inexpr-class))
+ (setq tmpsymbol '(block-open . inexpr-statement)
+ placeholder
+ (cdr-safe (c-looking-at-inexpr-block
+ (c-safe-position containing-sexp
+ paren-state)
+ containing-sexp)))
+ ;; placeholder is nil if it's a block directly in
+ ;; a function arglist. That makes us skip out of
+ ;; this case.
+ )))
+ (goto-char placeholder)
+ (back-to-indentation)
+ (c-add-stmt-syntax (car tmpsymbol) nil t
+ (c-most-enclosing-brace paren-state (point))
+ paren-state)
+ (if (/= (point) placeholder)
+ (c-add-syntax (cdr tmpsymbol))))
- ;; 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)
- paren-state))
- (if placeholder
- (setq tmpsymbol '(brace-list-open . inexpr-class))
- (setq tmpsymbol '(block-open . inexpr-statement)
- placeholder
- (cdr-safe (c-looking-at-inexpr-block
- (c-safe-position containing-sexp
- paren-state)
- containing-sexp)))
- ;; placeholder is nil if it's a block directly in
- ;; a function arglist. That makes us skip out of
- ;; this case.
- )))
- (goto-char placeholder)
- (back-to-indentation)
- (c-add-stmt-syntax (car tmpsymbol) nil t
- (c-most-enclosing-brace paren-state (point))
- paren-state)
- (if (/= (point) placeholder)
- (c-add-syntax (cdr tmpsymbol))))
+ ;; CASE 7C: we are looking at the first argument in an empty
+ ;; argument list. Use arglist-close if we're actually
+ ;; looking at a close paren or bracket.
+ ((memq char-before-ip '(?\( ?\[))
+ (goto-char containing-sexp)
+ (setq placeholder (c-point 'boi))
+ (if (and (c-safe (backward-up-list 1) t)
+ (>= (point) placeholder))
+ (progn
+ (forward-char)
+ (skip-chars-forward " \t"))
+ (goto-char placeholder))
+ (c-add-stmt-syntax 'arglist-intro (list containing-sexp) t
+ (c-most-enclosing-brace paren-state (point))
+ paren-state))
- ;; CASE 7C: we are looking at the first argument in an empty
- ;; argument list. Use arglist-close if we're actually
- ;; looking at a close paren or bracket.
- ((memq char-before-ip '(?\( ?\[))
+ ;; CASE 7D: we are inside a conditional test clause. treat
+ ;; these things as statements
+ ((progn
(goto-char containing-sexp)
- (setq placeholder (c-point 'boi))
- (if (and (c-safe (backward-up-list 1) t)
- (>= (point) placeholder))
- (progn
- (forward-char)
- (skip-chars-forward " \t"))
- (goto-char placeholder))
- (c-add-stmt-syntax 'arglist-intro (list containing-sexp) t
- (c-most-enclosing-brace paren-state (point))
- paren-state))
+ (and (c-safe (c-forward-sexp -1) t)
+ (looking-at "\\<for\\>[^_]")))
+ (goto-char (1+ containing-sexp))
+ (c-forward-syntactic-ws indent-point)
+ (if (eq char-before-ip ?\;)
+ (c-add-syntax 'statement (point))
+ (c-add-syntax 'statement-cont (point))
+ ))
+
+ ;; CASE 7E: maybe a continued ObjC method call. This is the
+ ;; case when we are inside a [] bracketed exp, and what
+ ;; precede the opening bracket is not an identifier.
+ ((and c-opt-method-key
+ (eq (char-after containing-sexp) ?\[)
+ (progn
+ (goto-char (1- containing-sexp))
+ (c-backward-syntactic-ws (c-point 'bod))
+ (if (not (looking-at c-symbol-key))
+ (c-add-syntax 'objc-method-call-cont containing-sexp))
+ )))
- ;; CASE 7D: we are inside a conditional test clause. treat
- ;; these things as statements
- ((progn
- (goto-char containing-sexp)
- (and (c-safe (c-forward-sexp -1) t)
- (looking-at "\\<for\\>[^_]")))
+ ;; CASE 7F: we are looking at an arglist continuation line,
+ ;; but the preceding argument is on the same line as the
+ ;; opening paren. This case includes multi-line
+ ;; mathematical paren groupings, but we could be on a
+ ;; for-list continuation line. C.f. case 7A.
+ ((progn
(goto-char (1+ containing-sexp))
- (c-forward-syntactic-ws indent-point)
- (if (eq char-before-ip ?\;)
- (c-add-syntax 'statement (point))
- (c-add-syntax 'statement-cont (point))
- ))
-
- ;; CASE 7E: maybe a continued ObjC method call. This is the
- ;; case when we are inside a [] bracketed exp, and what
- ;; precede the opening bracket is not an identifier.
- ((and c-opt-method-key
- (eq (char-after containing-sexp) ?\[)
- (progn
- (goto-char (1- containing-sexp))
- (c-backward-syntactic-ws (c-point 'bod))
- (if (not (looking-at c-symbol-key))
- (c-add-syntax 'objc-method-call-cont containing-sexp))
- )))
+ (< (save-excursion
+ (c-forward-syntactic-ws)
+ (point))
+ (c-point 'bonl)))
+ (goto-char containing-sexp) ; paren opening the arglist
+ (setq placeholder (c-point 'boi))
+ (if (and (c-safe (backward-up-list 1) t)
+ (>= (point) placeholder))
+ (progn
+ (forward-char)
+ (skip-chars-forward " \t"))
+ (goto-char placeholder))
+ (c-add-stmt-syntax 'arglist-cont-nonempty (list containing-sexp) t
+ (c-most-enclosing-brace c-state-cache (point))
+ paren-state))
- ;; CASE 7F: we are looking at an arglist continuation line,
- ;; but the preceding argument is on the same line as the
- ;; opening paren. This case includes multi-line
- ;; mathematical paren groupings, but we could be on a
- ;; for-list continuation line. C.f. case 7A.
- ((progn
- (goto-char (1+ containing-sexp))
- (< (save-excursion
- (c-forward-syntactic-ws)
- (point))
- (c-point 'bonl)))
- (goto-char containing-sexp) ; paren opening the arglist
- (setq placeholder (c-point 'boi))
- (if (and (c-safe (backward-up-list 1) t)
- (>= (point) placeholder))
- (progn
- (forward-char)
- (skip-chars-forward " \t"))
- (goto-char placeholder))
- (c-add-stmt-syntax 'arglist-cont-nonempty (list containing-sexp) t
- (c-most-enclosing-brace c-state-cache (point))
- paren-state))
+ ;; CASE 7G: we are looking at just a normal arglist
+ ;; continuation line
+ (t (c-forward-syntactic-ws indent-point)
+ (c-add-syntax 'arglist-cont (c-point 'boi)))
+ ))
- ;; CASE 7G: we are looking at just a normal arglist
- ;; continuation line
- (t (c-forward-syntactic-ws indent-point)
- (c-add-syntax 'arglist-cont (c-point 'boi)))
- ))
+ ;; CASE 8: func-local multi-inheritance line
+ ((and (c-major-mode-is 'c++-mode)
+ (save-excursion
+ (goto-char indent-point)
+ (skip-chars-forward " \t")
+ (looking-at c-opt-postfix-decl-spec-key)))
+ (goto-char indent-point)
+ (skip-chars-forward " \t")
+ (cond
- ;; CASE 8: func-local multi-inheritance line
- ((and (c-major-mode-is 'c++-mode)
- (save-excursion
- (goto-char indent-point)
- (skip-chars-forward " \t")
- (looking-at c-opt-postfix-decl-spec-key)))
- (goto-char indent-point)
- (skip-chars-forward " \t")
- (cond
+ ;; CASE 8A: non-hanging colon on an inher intro
+ ((eq char-after-ip ?:)
+ (c-backward-syntactic-ws lim)
+ (c-add-syntax 'inher-intro (c-point 'boi)))
- ;; CASE 8A: non-hanging colon on an inher intro
- ((eq char-after-ip ?:)
- (c-backward-syntactic-ws lim)
- (c-add-syntax 'inher-intro (c-point 'boi)))
+ ;; CASE 8B: hanging colon on an inher intro
+ ((eq char-before-ip ?:)
+ (c-add-syntax 'inher-intro (c-point 'boi)))
- ;; CASE 8B: hanging colon on an inher intro
- ((eq char-before-ip ?:)
- (c-add-syntax 'inher-intro (c-point 'boi)))
+ ;; CASE 8C: a continued inheritance line
+ (t
+ (c-beginning-of-inheritance-list lim)
+ (c-add-syntax 'inher-cont (point))
+ )))
+
+ ;; CASE 9: we are inside a brace-list
+ ((and (not (c-major-mode-is 'awk-mode)) ; Maybe this isn't needed (ACM, 2002/3/29)
+ (setq special-brace-list
+ (or (and c-special-brace-lists ;;;; ALWAYS NIL FOR AWK!!
+ (save-excursion
+ (goto-char containing-sexp)
+ (c-looking-at-special-brace-list)))
+ (c-inside-bracelist-p containing-sexp paren-state))))
+ (cond
- ;; CASE 8C: a continued inheritance line
- (t
- (c-beginning-of-inheritance-list lim)
- (c-add-syntax 'inher-cont (point))
- )))
+ ;; CASE 9A: In the middle of a special brace list opener.
+ ((and (consp special-brace-list)
+ (save-excursion
+ (goto-char containing-sexp)
+ (eq (char-after) ?\())
+ (eq char-after-ip (car (cdr special-brace-list))))
+ (goto-char (car (car special-brace-list)))
+ (skip-chars-backward " \t")
+ (if (and (bolp)
+ (assoc 'statement-cont
+ (setq placeholder (c-guess-basic-syntax))))
+ (setq c-syntactic-context placeholder)
+ (c-beginning-of-statement-1
+ (c-safe-position (1- containing-sexp) paren-state))
+ (c-forward-token-2 0)
+ (while (looking-at c-specifier-key)
+ (goto-char (match-end 1))
+ (c-forward-syntactic-ws))
+ (c-add-syntax 'brace-list-open (c-point 'boi))))
+
+ ;; CASE 9B: brace-list-close brace
+ ((if (consp special-brace-list)
+ ;; Check special brace list closer.
+ (progn
+ (goto-char (car (car special-brace-list)))
+ (save-excursion
+ (goto-char indent-point)
+ (back-to-indentation)
+ (or
+ ;; We were between the special close char and the `)'.
+ (and (eq (char-after) ?\))
+ (eq (1+ (point)) (cdr (car special-brace-list))))
+ ;; We were before the special close char.
+ (and (eq (char-after) (cdr (cdr special-brace-list)))
+ (zerop (c-forward-token-2))
+ (eq (1+ (point)) (cdr (car special-brace-list)))))))
+ ;; Normal brace list check.
+ (and (eq char-after-ip ?})
+ (c-safe (goto-char (c-up-list-backward (point))) t)
+ (= (point) containing-sexp)))
+ (if (eq (point) (c-point 'boi))
+ (c-add-syntax 'brace-list-close (point))
+ (setq lim (c-most-enclosing-brace c-state-cache (point)))
+ (c-beginning-of-statement-1 lim)
+ (c-add-stmt-syntax 'brace-list-close nil t lim paren-state)))
- ;; CASE 9: we are inside a brace-list
- ((and (not (c-major-mode-is 'awk-mode)) ; Maybe this isn't needed (ACM, 2002/3/29)
- (setq special-brace-list
- (or (and c-special-brace-lists ;;;; ALWAYS NIL FOR AWK!!
- (save-excursion
- (goto-char containing-sexp)
- (c-looking-at-special-brace-list)))
- (c-inside-bracelist-p containing-sexp paren-state))))
+ (t
+ ;; Prepare for the rest of the cases below by going to the
+ ;; token following the opening brace
+ (if (consp special-brace-list)
+ (progn
+ (goto-char (car (car special-brace-list)))
+ (c-forward-token-2 1 nil indent-point))
+ (goto-char containing-sexp))
+ (forward-char)
+ (let ((start (point)))
+ (c-forward-syntactic-ws indent-point)
+ (goto-char (max start (c-point 'bol))))
+ (c-skip-ws-forward indent-point)
(cond
- ;; CASE 9A: In the middle of a special brace list opener.
- ((and (consp special-brace-list)
- (save-excursion
- (goto-char containing-sexp)
- (eq (char-after) ?\())
- (eq char-after-ip (car (cdr special-brace-list))))
- (goto-char (car (car special-brace-list)))
- (skip-chars-backward " \t")
- (if (and (bolp)
- (assoc 'statement-cont
- (setq placeholder (c-guess-basic-syntax))))
- (setq c-syntactic-context placeholder)
- (c-beginning-of-statement-1
- (c-safe-position (1- containing-sexp) paren-state))
- (c-forward-token-2 0)
- (while (looking-at c-specifier-key)
- (goto-char (match-end 1))
- (c-forward-syntactic-ws))
- (c-add-syntax 'brace-list-open (c-point 'boi))))
-
- ;; CASE 9B: brace-list-close brace
- ((if (consp special-brace-list)
- ;; Check special brace list closer.
- (progn
- (goto-char (car (car special-brace-list)))
- (save-excursion
- (goto-char indent-point)
- (back-to-indentation)
- (or
- ;; We were between the special close char and the `)'.
- (and (eq (char-after) ?\))
- (eq (1+ (point)) (cdr (car special-brace-list))))
- ;; We were before the special close char.
- (and (eq (char-after) (cdr (cdr special-brace-list)))
- (zerop (c-forward-token-2))
- (eq (1+ (point)) (cdr (car special-brace-list)))))))
- ;; Normal brace list check.
- (and (eq char-after-ip ?})
- (c-safe (goto-char (c-up-list-backward (point))) t)
- (= (point) containing-sexp)))
+ ;; CASE 9C: we're looking at the first line in a brace-list
+ ((= (point) indent-point)
+ (if (consp special-brace-list)
+ (goto-char (car (car special-brace-list)))
+ (goto-char containing-sexp))
(if (eq (point) (c-point 'boi))
- (c-add-syntax 'brace-list-close (point))
+ (c-add-syntax 'brace-list-intro (point))
(setq lim (c-most-enclosing-brace c-state-cache (point)))
(c-beginning-of-statement-1 lim)
- (c-add-stmt-syntax 'brace-list-close nil t lim paren-state)))
+ (c-add-stmt-syntax 'brace-list-intro nil t lim paren-state)))
- (t
- ;; Prepare for the rest of the cases below by going to the
- ;; token following the opening brace
- (if (consp special-brace-list)
- (progn
- (goto-char (car (car special-brace-list)))
- (c-forward-token-2 1 nil indent-point))
- (goto-char containing-sexp))
- (forward-char)
- (let ((start (point)))
- (c-forward-syntactic-ws indent-point)
- (goto-char (max start (c-point 'bol))))
- (c-skip-ws-forward indent-point)
- (cond
+ ;; CASE 9D: this is just a later brace-list-entry or
+ ;; brace-entry-open
+ (t (if (or (eq char-after-ip ?{)
+ (and c-special-brace-lists
+ (save-excursion
+ (goto-char indent-point)
+ (c-forward-syntactic-ws (c-point 'eol))
+ (c-looking-at-special-brace-list (point)))))
+ (c-add-syntax 'brace-entry-open (point))
+ (c-add-syntax 'brace-list-entry (point))
+ ))
+ ))))
+
+ ;; CASE 10: A continued statement or top level construct.
+ ((and (not (memq char-before-ip '(?\; ?:)))
+ (not (c-at-vsemi-p before-ws-ip))
+ (or (not (eq char-before-ip ?}))
+ (c-looking-at-inexpr-block-backward c-state-cache))
+ (> (point)
+ (save-excursion
+ (c-beginning-of-statement-1 containing-sexp)
+ (setq placeholder (point))))
+ (/= placeholder containing-sexp))
+ ;; This is shared with case 18.
+ (c-guess-continued-construct indent-point
+ char-after-ip
+ placeholder
+ containing-sexp
+ paren-state))
+
+ ;; CASE 16: block close brace, possibly closing the defun or
+ ;; the class
+ ((eq char-after-ip ?})
+ ;; From here on we have the next containing sexp in lim.
+ (setq lim (c-most-enclosing-brace paren-state))
+ (goto-char containing-sexp)
+ (cond
- ;; CASE 9C: we're looking at the first line in a brace-list
- ((= (point) indent-point)
- (if (consp special-brace-list)
- (goto-char (car (car special-brace-list)))
- (goto-char containing-sexp))
- (if (eq (point) (c-point 'boi))
- (c-add-syntax 'brace-list-intro (point))
- (setq lim (c-most-enclosing-brace c-state-cache (point)))
- (c-beginning-of-statement-1 lim)
- (c-add-stmt-syntax 'brace-list-intro nil t lim paren-state)))
-
- ;; CASE 9D: this is just a later brace-list-entry or
- ;; brace-entry-open
- (t (if (or (eq char-after-ip ?{)
- (and c-special-brace-lists
- (save-excursion
- (goto-char indent-point)
- (c-forward-syntactic-ws (c-point 'eol))
- (c-looking-at-special-brace-list (point)))))
- (c-add-syntax 'brace-entry-open (point))
- (c-add-syntax 'brace-list-entry (point))
- ))
- ))))
-
- ;; CASE 10: A continued statement or top level construct.
- ((and (not (memq char-before-ip '(?\; ?:)))
- (not (c-at-vsemi-p before-ws-ip))
- (or (not (eq char-before-ip ?}))
- (c-looking-at-inexpr-block-backward c-state-cache))
- (> (point)
- (save-excursion
- (c-beginning-of-statement-1 containing-sexp)
- (setq placeholder (point))))
- (/= placeholder containing-sexp))
- ;; This is shared with case 18.
- (c-guess-continued-construct indent-point
- char-after-ip
- placeholder
- containing-sexp
- paren-state))
-
- ;; CASE 16: block close brace, possibly closing the defun or
- ;; the class
- ((eq char-after-ip ?})
- ;; From here on we have the next containing sexp in lim.
- (setq lim (c-most-enclosing-brace paren-state))
+ ;; CASE 16E: Closing a statement block? This catches
+ ;; cases where it's preceded by a statement keyword,
+ ;; which works even when used in an "invalid" context,
+ ;; e.g. a macro argument.
+ ((c-after-conditional)
+ (c-backward-to-block-anchor lim)
+ (c-add-stmt-syntax 'block-close nil t lim paren-state))
+
+ ;; CASE 16A: closing a lambda defun or an in-expression
+ ;; block? C.f. cases 4, 7B and 17E.
+ ((setq placeholder (c-looking-at-inexpr-block
+ (c-safe-position containing-sexp paren-state)
+ nil))
+ (setq tmpsymbol (if (eq (car placeholder) 'inlambda)
+ 'inline-close
+ 'block-close))
(goto-char containing-sexp)
- (cond
+ (back-to-indentation)
+ (if (= containing-sexp (point))
+ (c-add-syntax tmpsymbol (point))
+ (goto-char (cdr placeholder))
+ (back-to-indentation)
+ (c-add-stmt-syntax tmpsymbol nil t
+ (c-most-enclosing-brace paren-state (point))
+ paren-state)
+ (if (/= (point) (cdr placeholder))
+ (c-add-syntax (car placeholder)))))
- ;; CASE 16E: Closing a statement block? This catches
- ;; cases where it's preceded by a statement keyword,
- ;; which works even when used in an "invalid" context,
- ;; e.g. a macro argument.
- ((c-after-conditional)
- (c-backward-to-block-anchor lim)
- (c-add-stmt-syntax 'block-close nil t lim paren-state))
-
- ;; CASE 16A: closing a lambda defun or an in-expression
- ;; block? C.f. cases 4, 7B and 17E.
- ((setq placeholder (c-looking-at-inexpr-block
- (c-safe-position containing-sexp paren-state)
- nil))
- (setq tmpsymbol (if (eq (car placeholder) 'inlambda)
- 'inline-close
- 'block-close))
- (goto-char containing-sexp)
- (back-to-indentation)
- (if (= containing-sexp (point))
- (c-add-syntax tmpsymbol (point))
- (goto-char (cdr placeholder))
- (back-to-indentation)
- (c-add-stmt-syntax tmpsymbol nil t
- (c-most-enclosing-brace paren-state (point))
- paren-state)
- (if (/= (point) (cdr placeholder))
- (c-add-syntax (car placeholder)))))
-
- ;; CASE 16B: does this close an inline or a function in
- ;; a non-class declaration level block?
- ((save-excursion
- (and lim
- (progn
- (goto-char lim)
- (c-looking-at-decl-block
- (c-most-enclosing-brace paren-state lim)
- nil))
- (setq placeholder (point))))
- (c-backward-to-decl-anchor lim)
- (back-to-indentation)
- (if (save-excursion
- (goto-char placeholder)
- (looking-at c-other-decl-block-key))
- (c-add-syntax 'defun-close (point))
- (c-add-syntax 'inline-close (point))))
-
- ;; CASE 16F: Can be a defun-close of a function declared
- ;; in a statement block, e.g. in Pike or when using gcc
- ;; extensions, but watch out for macros followed by
- ;; blocks. Let it through to be handled below.
- ;; C.f. cases B.3 and 17G.
- ((save-excursion
- (and (not (c-at-statement-start-p))
- (eq (c-beginning-of-statement-1 lim nil nil t) 'same)
- (setq placeholder (point))
- (let ((c-recognize-typeless-decls nil))
- ;; Turn off recognition of constructs that
- ;; lacks a type in this case, since that's more
- ;; likely to be a macro followed by a block.
- (c-forward-decl-or-cast-1 (c-point 'bosws) nil nil))))
- (back-to-indentation)
- (if (/= (point) containing-sexp)
- (goto-char placeholder))
- (c-add-stmt-syntax 'defun-close nil t lim paren-state))
-
- ;; CASE 16C: If there is an enclosing brace then this is
- ;; a block close since defun closes inside declaration
- ;; level blocks have been handled above.
- (lim
- ;; If the block is preceded by a case/switch label on
- ;; the same line, we anchor at the first preceding label
- ;; at boi. The default handling in c-add-stmt-syntax
- ;; really fixes it better, but we do like this to keep
- ;; the indentation compatible with version 5.28 and
- ;; earlier. C.f. case 17H.
- (while (and (/= (setq placeholder (point)) (c-point 'boi))
- (eq (c-beginning-of-statement-1 lim) 'label)))
- (goto-char placeholder)
- (if (looking-at c-label-kwds-regexp)
- (c-add-syntax 'block-close (point))
- (goto-char containing-sexp)
- ;; c-backward-to-block-anchor not necessary here; those
- ;; situations are handled in case 16E above.
- (c-add-stmt-syntax 'block-close nil t lim paren-state)))
-
- ;; CASE 16D: Only top level defun close left.
- (t
- (goto-char containing-sexp)
- (c-backward-to-decl-anchor lim)
- (c-add-stmt-syntax 'defun-close nil nil
- (c-most-enclosing-brace paren-state)
- paren-state))
- ))
+ ;; CASE 16B: does this close an inline or a function in
+ ;; a non-class declaration level block?
+ ((save-excursion
+ (and lim
+ (progn
+ (goto-char lim)
+ (c-looking-at-decl-block
+ (c-most-enclosing-brace paren-state lim)
+ nil))
+ (setq placeholder (point))))
+ (c-backward-to-decl-anchor lim)
+ (back-to-indentation)
+ (if (save-excursion
+ (goto-char placeholder)
+ (looking-at c-other-decl-block-key))
+ (c-add-syntax 'defun-close (point))
+ (c-add-syntax 'inline-close (point))))
+
+ ;; CASE 16F: Can be a defun-close of a function declared
+ ;; in a statement block, e.g. in Pike or when using gcc
+ ;; extensions, but watch out for macros followed by
+ ;; blocks. Let it through to be handled below.
+ ;; C.f. cases B.3 and 17G.
+ ((save-excursion
+ (and (not (c-at-statement-start-p))
+ (eq (c-beginning-of-statement-1 lim nil nil t) 'same)
+ (setq placeholder (point))
+ (let ((c-recognize-typeless-decls nil))
+ ;; Turn off recognition of constructs that
+ ;; lacks a type in this case, since that's more
+ ;; likely to be a macro followed by a block.
+ (c-forward-decl-or-cast-1 (c-point 'bosws) nil nil))))
+ (back-to-indentation)
+ (if (/= (point) containing-sexp)
+ (goto-char placeholder))
+ (c-add-stmt-syntax 'defun-close nil t lim paren-state))
+
+ ;; CASE 16C: If there is an enclosing brace then this is
+ ;; a block close since defun closes inside declaration
+ ;; level blocks have been handled above.
+ (lim
+ ;; If the block is preceded by a case/switch label on
+ ;; the same line, we anchor at the first preceding label
+ ;; at boi. The default handling in c-add-stmt-syntax
+ ;; really fixes it better, but we do like this to keep
+ ;; the indentation compatible with version 5.28 and
+ ;; earlier. C.f. case 17H.
+ (while (and (/= (setq placeholder (point)) (c-point 'boi))
+ (eq (c-beginning-of-statement-1 lim) 'label)))
+ (goto-char placeholder)
+ (if (looking-at c-label-kwds-regexp)
+ (c-add-syntax 'block-close (point))
+ (goto-char containing-sexp)
+ ;; c-backward-to-block-anchor not necessary here; those
+ ;; situations are handled in case 16E above.
+ (c-add-stmt-syntax 'block-close nil t lim paren-state)))
- ;; CASE 17: Statement or defun catchall.
+ ;; CASE 16D: Only top level defun close left.
(t
- (goto-char indent-point)
- ;; Back up statements until we find one that starts at boi.
- (while (let* ((prev-point (point))
- (last-step-type (c-beginning-of-statement-1
- containing-sexp)))
- (if (= (point) prev-point)
- (progn
- (setq step-type (or step-type last-step-type))
- nil)
- (setq step-type last-step-type)
- (/= (point) (c-point 'boi)))))
- (cond
+ (goto-char containing-sexp)
+ (c-backward-to-decl-anchor lim)
+ (c-add-stmt-syntax 'defun-close nil nil
+ (c-most-enclosing-brace paren-state)
+ paren-state))
+ ))
+
+ ;; 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 17: Statement or defun catchall.
+ (t
+ (goto-char indent-point)
+ ;; Back up statements until we find one that starts at boi.
+ (while (let* ((prev-point (point))
+ (last-step-type (c-beginning-of-statement-1
+ containing-sexp)))
+ (if (= (point) prev-point)
+ (progn
+ (setq step-type (or step-type last-step-type))
+ nil)
+ (setq step-type last-step-type)
+ (/= (point) (c-point 'boi)))))
+ (cond
- ;; CASE 17B: continued statement
- ((and (eq step-type 'same)
- (/= (point) indent-point))
- (c-add-stmt-syntax 'statement-cont nil nil
- containing-sexp paren-state))
-
- ;; CASE 17A: After a case/default label?
- ((progn
- (while (and (eq step-type 'label)
- (not (looking-at c-label-kwds-regexp)))
- (setq step-type
- (c-beginning-of-statement-1 containing-sexp)))
- (eq step-type 'label))
- (c-add-stmt-syntax (if (eq char-after-ip ?{)
- 'statement-case-open
- 'statement-case-intro)
- nil t containing-sexp paren-state))
-
- ;; CASE 17D: any old statement
- ((progn
- (while (eq step-type 'label)
- (setq step-type
- (c-beginning-of-statement-1 containing-sexp)))
- (eq step-type 'previous))
- (c-add-stmt-syntax 'statement nil t
- containing-sexp paren-state)
- (if (eq char-after-ip ?{)
- (c-add-syntax 'block-open)))
-
- ;; CASE 17I: Inside a substatement block.
- ((progn
- ;; The following tests are all based on containing-sexp.
- (goto-char containing-sexp)
- ;; From here on we have the next containing sexp in lim.
- (setq lim (c-most-enclosing-brace paren-state containing-sexp))
- (c-after-conditional))
- (c-backward-to-block-anchor lim)
- (c-add-stmt-syntax 'statement-block-intro nil t
- lim paren-state)
- (if (eq char-after-ip ?{)
- (c-add-syntax 'block-open)))
-
- ;; CASE 17E: first statement in an in-expression block.
- ;; C.f. cases 4, 7B and 16A.
- ((setq placeholder (c-looking-at-inexpr-block
- (c-safe-position containing-sexp paren-state)
- nil))
- (setq tmpsymbol (if (eq (car placeholder) 'inlambda)
- 'defun-block-intro
- 'statement-block-intro))
- (back-to-indentation)
- (if (= containing-sexp (point))
- (c-add-syntax tmpsymbol (point))
- (goto-char (cdr placeholder))
- (back-to-indentation)
- (c-add-stmt-syntax tmpsymbol nil t
- (c-most-enclosing-brace c-state-cache (point))
- paren-state)
- (if (/= (point) (cdr placeholder))
- (c-add-syntax (car placeholder))))
- (if (eq char-after-ip ?{)
- (c-add-syntax 'block-open)))
-
- ;; CASE 17F: first statement in an inline, or first
- ;; statement in a top-level defun. we can tell this is it
- ;; if there are no enclosing braces that haven't been
- ;; narrowed out by a class (i.e. don't use bod here).
- ((save-excursion
- (or (not (setq placeholder (c-most-enclosing-brace
- paren-state)))
- (and (progn
- (goto-char placeholder)
- (eq (char-after) ?{))
- (c-looking-at-decl-block (c-most-enclosing-brace
- paren-state (point))
- nil))))
- (c-backward-to-decl-anchor lim)
- (back-to-indentation)
- (c-add-syntax 'defun-block-intro (point)))
+ ;; CASE 17B: continued statement
+ ((and (eq step-type 'same)
+ (/= (point) indent-point))
+ (c-add-stmt-syntax 'statement-cont nil nil
+ containing-sexp paren-state))
- ;; CASE 17G: First statement in a function declared inside
- ;; a normal block. This can occur in Pike and with
- ;; e.g. the gcc extensions, but watch out for macros
- ;; followed by blocks. C.f. cases B.3 and 16F.
- ((save-excursion
- (and (not (c-at-statement-start-p))
- (eq (c-beginning-of-statement-1 lim nil nil t) 'same)
- (setq placeholder (point))
- (let ((c-recognize-typeless-decls nil))
- ;; Turn off recognition of constructs that lacks
- ;; a type in this case, since that's more likely
- ;; to be a macro followed by a block.
- (c-forward-decl-or-cast-1 (c-point 'bosws) nil nil))))
+ ;; CASE 17A: After a case/default label?
+ ((progn
+ (while (and (eq step-type 'label)
+ (not (looking-at c-label-kwds-regexp)))
+ (setq step-type
+ (c-beginning-of-statement-1 containing-sexp)))
+ (eq step-type 'label))
+ (c-add-stmt-syntax (if (eq char-after-ip ?{)
+ 'statement-case-open
+ 'statement-case-intro)
+ nil t containing-sexp paren-state))
+
+ ;; CASE 17D: any old statement
+ ((progn
+ (while (eq step-type 'label)
+ (setq step-type
+ (c-beginning-of-statement-1 containing-sexp)))
+ (eq step-type 'previous))
+ (c-add-stmt-syntax 'statement nil t
+ containing-sexp paren-state)
+ (if (eq char-after-ip ?{)
+ (c-add-syntax 'block-open)))
+
+ ;; CASE 17I: Inside a substatement block.
+ ((progn
+ ;; The following tests are all based on containing-sexp.
+ (goto-char containing-sexp)
+ ;; From here on we have the next containing sexp in lim.
+ (setq lim (c-most-enclosing-brace paren-state containing-sexp))
+ (c-after-conditional))
+ (c-backward-to-block-anchor lim)
+ (c-add-stmt-syntax 'statement-block-intro nil t
+ lim paren-state)
+ (if (eq char-after-ip ?{)
+ (c-add-syntax 'block-open)))
+
+ ;; CASE 17E: first statement in an in-expression block.
+ ;; C.f. cases 4, 7B and 16A.
+ ((setq placeholder (c-looking-at-inexpr-block
+ (c-safe-position containing-sexp paren-state)
+ nil))
+ (setq tmpsymbol (if (eq (car placeholder) 'inlambda)
+ 'defun-block-intro
+ 'statement-block-intro))
+ (back-to-indentation)
+ (if (= containing-sexp (point))
+ (c-add-syntax tmpsymbol (point))
+ (goto-char (cdr placeholder))
(back-to-indentation)
- (if (/= (point) containing-sexp)
- (goto-char placeholder))
- (c-add-stmt-syntax 'defun-block-intro nil t
- lim paren-state))
+ (c-add-stmt-syntax tmpsymbol nil t
+ (c-most-enclosing-brace c-state-cache (point))
+ paren-state)
+ (if (/= (point) (cdr placeholder))
+ (c-add-syntax (car placeholder))))
+ (if (eq char-after-ip ?{)
+ (c-add-syntax 'block-open)))
+
+ ;; CASE 17F: first statement in an inline, or first
+ ;; statement in a top-level defun. we can tell this is it
+ ;; if there are no enclosing braces that haven't been
+ ;; narrowed out by a class (i.e. don't use bod here).
+ ((save-excursion
+ (or (not (setq placeholder (c-most-enclosing-brace
+ paren-state)))
+ (and (progn
+ (goto-char placeholder)
+ (eq (char-after) ?{))
+ (c-looking-at-decl-block (c-most-enclosing-brace
+ paren-state (point))
+ nil))))
+ (c-backward-to-decl-anchor lim)
+ (back-to-indentation)
+ (c-add-syntax 'defun-block-intro (point)))
- ;; CASE 17H: First statement in a block.
- (t
- ;; If the block is preceded by a case/switch label on the
- ;; same line, we anchor at the first preceding label at
- ;; boi. The default handling in c-add-stmt-syntax is
- ;; really fixes it better, but we do like this to keep the
- ;; indentation compatible with version 5.28 and earlier.
- ;; C.f. case 16C.
- (while (and (/= (setq placeholder (point)) (c-point 'boi))
- (eq (c-beginning-of-statement-1 lim) 'label)))
- (goto-char placeholder)
- (if (looking-at c-label-kwds-regexp)
- (c-add-syntax 'statement-block-intro (point))
- (goto-char containing-sexp)
- ;; c-backward-to-block-anchor not necessary here; those
- ;; situations are handled in case 17I above.
- (c-add-stmt-syntax 'statement-block-intro nil t
- lim paren-state))
- (if (eq char-after-ip ?{)
- (c-add-syntax 'block-open)))
- ))
- )
+ ;; CASE 17G: First statement in a function declared inside
+ ;; a normal block. This can occur in Pike and with
+ ;; e.g. the gcc extensions, but watch out for macros
+ ;; followed by blocks. C.f. cases B.3 and 16F.
+ ((save-excursion
+ (and (not (c-at-statement-start-p))
+ (eq (c-beginning-of-statement-1 lim nil nil t) 'same)
+ (setq placeholder (point))
+ (let ((c-recognize-typeless-decls nil))
+ ;; Turn off recognition of constructs that lacks
+ ;; a type in this case, since that's more likely
+ ;; to be a macro followed by a block.
+ (c-forward-decl-or-cast-1 (c-point 'bosws) nil nil))))
+ (back-to-indentation)
+ (if (/= (point) containing-sexp)
+ (goto-char placeholder))
+ (c-add-stmt-syntax 'defun-block-intro nil t
+ lim paren-state))
- ;; now we need to look at any modifiers
- (goto-char indent-point)
- (skip-chars-forward " \t")
+ ;; CASE 17H: First statement in a block.
+ (t
+ ;; If the block is preceded by a case/switch label on the
+ ;; same line, we anchor at the first preceding label at
+ ;; boi. The default handling in c-add-stmt-syntax is
+ ;; really fixes it better, but we do like this to keep the
+ ;; indentation compatible with version 5.28 and earlier.
+ ;; C.f. case 16C.
+ (while (and (/= (setq placeholder (point)) (c-point 'boi))
+ (eq (c-beginning-of-statement-1 lim) 'label)))
+ (goto-char placeholder)
+ (if (looking-at c-label-kwds-regexp)
+ (c-add-syntax 'statement-block-intro (point))
+ (goto-char containing-sexp)
+ ;; c-backward-to-block-anchor not necessary here; those
+ ;; situations are handled in case 17I above.
+ (c-add-stmt-syntax 'statement-block-intro nil t
+ lim paren-state))
+ (if (eq char-after-ip ?{)
+ (c-add-syntax 'block-open)))
+ ))
+ )
+
+ ;; now we need to look at any modifiers
+ (goto-char indent-point)
+ (skip-chars-forward " \t")
+
+ ;; are we looking at a comment only line?
+ (when (and (looking-at c-comment-start-regexp)
+ (/= (c-forward-token-2 0 nil (c-point 'eol)) 0))
+ (c-append-syntax 'comment-intro))
+
+ ;; we might want to give additional offset to friends (in C++).
+ (when (and c-opt-friend-key
+ (looking-at c-opt-friend-key))
+ (c-append-syntax 'friend))
+
+ ;; Set syntactic-relpos.
+ (let ((p c-syntactic-context))
+ (while (and p
+ (if (integerp (c-langelem-pos (car p)))
+ (progn
+ (setq syntactic-relpos (c-langelem-pos (car p)))
+ nil)
+ t))
+ (setq p (cdr p))))
- ;; are we looking at a comment only line?
- (when (and (looking-at c-comment-start-regexp)
- (/= (c-forward-token-2 0 nil (c-point 'eol)) 0))
- (c-append-syntax 'comment-intro))
-
- ;; we might want to give additional offset to friends (in C++).
- (when (and c-opt-friend-key
- (looking-at c-opt-friend-key))
- (c-append-syntax 'friend))
-
- ;; Set syntactic-relpos.
- (let ((p c-syntactic-context))
- (while (and p
- (if (integerp (c-langelem-pos (car p)))
- (progn
- (setq syntactic-relpos (c-langelem-pos (car p)))
- nil)
- t))
- (setq p (cdr p))))
-
- ;; Start of or a continuation of a preprocessor directive?
- (if (and macro-start
- (eq macro-start (c-point 'boi))
- (not (and (c-major-mode-is 'pike-mode)
- (eq (char-after (1+ macro-start)) ?\"))))
- (c-append-syntax 'cpp-macro)
- (when (and c-syntactic-indentation-in-macros macro-start)
- (if in-macro-expr
- (when (or
- (< syntactic-relpos macro-start)
- (not (or
- (assq 'arglist-intro c-syntactic-context)
- (assq 'arglist-cont c-syntactic-context)
- (assq 'arglist-cont-nonempty c-syntactic-context)
- (assq 'arglist-close c-syntactic-context))))
- ;; If inside a cpp expression, i.e. anywhere in a
- ;; cpp directive except a #define body, we only let
- ;; through the syntactic analysis that is internal
- ;; in the expression. That means the arglist
- ;; elements, if they are anchored inside the cpp
- ;; expression.
- (setq c-syntactic-context nil)
- (c-add-syntax 'cpp-macro-cont macro-start))
- (when (and (eq macro-start syntactic-relpos)
- (not (assq 'cpp-define-intro c-syntactic-context))
- (save-excursion
- (goto-char macro-start)
- (or (not (c-forward-to-cpp-define-body))
- (<= (point) (c-point 'boi indent-point)))))
- ;; Inside a #define body and the syntactic analysis is
- ;; anchored on the start of the #define. In this case
- ;; we add cpp-define-intro to get the extra
- ;; indentation of the #define body.
- (c-add-syntax 'cpp-define-intro)))))
-
- ;; return the syntax
- c-syntactic-context)))
+ ;; Start of or a continuation of a preprocessor directive?
+ (if (and macro-start
+ (eq macro-start (c-point 'boi))
+ (not (and (c-major-mode-is 'pike-mode)
+ (eq (char-after (1+ macro-start)) ?\"))))
+ (c-append-syntax 'cpp-macro)
+ (when (and c-syntactic-indentation-in-macros macro-start)
+ (if in-macro-expr
+ (when (or
+ (< syntactic-relpos macro-start)
+ (not (or
+ (assq 'arglist-intro c-syntactic-context)
+ (assq 'arglist-cont c-syntactic-context)
+ (assq 'arglist-cont-nonempty c-syntactic-context)
+ (assq 'arglist-close c-syntactic-context))))
+ ;; If inside a cpp expression, i.e. anywhere in a
+ ;; cpp directive except a #define body, we only let
+ ;; through the syntactic analysis that is internal
+ ;; in the expression. That means the arglist
+ ;; elements, if they are anchored inside the cpp
+ ;; expression.
+ (setq c-syntactic-context nil)
+ (c-add-syntax 'cpp-macro-cont macro-start))
+ (when (and (eq macro-start syntactic-relpos)
+ (not (assq 'cpp-define-intro c-syntactic-context))
+ (save-excursion
+ (goto-char macro-start)
+ (or (not (c-forward-to-cpp-define-body))
+ (<= (point) (c-point 'boi indent-point)))))
+ ;; Inside a #define body and the syntactic analysis is
+ ;; anchored on the start of the #define. In this case
+ ;; we add cpp-define-intro to get the extra
+ ;; indentation of the #define body.
+ (c-add-syntax 'cpp-define-intro)))))
+
+ ;; return the syntax
+ c-syntactic-context)))
;; Indentation calculation.
@@ -9308,5 +10374,4 @@ Cannot combine absolute offsets %S and %S in `add' method"
(cc-provide 'cc-engine)
-;; arch-tag: 149add18-4673-4da5-ac47-6805e4eae089
;;; cc-engine.el ends here
diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el
index 9f28bfa97b5..c7bb93f73e7 100644
--- a/lisp/progmodes/cc-fonts.el
+++ b/lisp/progmodes/cc-fonts.el
@@ -1,13 +1,13 @@
;;; cc-fonts.el --- font lock support for CC Mode
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Authors: 2003- Alan Mackenzie
;; 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
@@ -1035,7 +1082,7 @@ casts and declarations are fontified. Used on level 2 and higher."
(boundp 'parse-sexp-lookup-properties))))
;; Below we fontify a whole declaration even when it crosses the limit,
- ;; to avoid gaps when lazy-lock fontifies the file a screenful at a
+ ;; to avoid gaps when jit/lazy-lock fontifies the file a block at a
;; time. That is however annoying during editing, e.g. the following is
;; a common situation while the first line is being written:
;;
@@ -1047,9 +1094,9 @@ casts and declarations are fontified. Used on level 2 and higher."
;; "some_other_variable" as an identifier, and the latter will not
;; correct itself until the second line is changed. To avoid that we
;; narrow to the limit if the region to fontify is a single line.
- (narrow-to-region
- (point-min)
- (if (<= limit (c-point 'bonl))
+ (if (<= limit (c-point 'bonl))
+ (narrow-to-region
+ (point-min)
(save-excursion
;; Narrow after any operator chars following the limit though,
;; since those characters can be useful in recognizing a
@@ -1057,8 +1104,7 @@ casts and declarations are fontified. Used on level 2 and higher."
;; after the header).
(goto-char limit)
(skip-chars-forward c-nonsymbol-chars)
- (point))
- limit))
+ (point))))
(c-find-decl-spots
limit
@@ -1077,57 +1123,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 +1320,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 +1429,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 +1481,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 +1529,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 +1618,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 +1680,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 +1798,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.
@@ -2309,5 +2459,4 @@ need for `pike-font-lock-extra-types'.")
;; 2006-07-10: awk-font-lock-keywords has been moved back to cc-awk.el.
(cc-provide 'cc-fonts)
-;; arch-tag: 2f65f405-735f-4da5-8d4b-b957844c5203
;;; cc-fonts.el ends here
diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el
index 2acb7109678..86a963bcf55 100644
--- a/lisp/progmodes/cc-langs.el
+++ b/lisp/progmodes/cc-langs.el
@@ -1,8 +1,6 @@
;;; cc-langs.el --- language specific settings 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, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1987, 1992-2011 Free Software Foundation, Inc.
;; Authors: 2002- Alan Mackenzie
;; 1998- Martin Stjernholm
@@ -12,8 +10,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 +357,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 +380,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 +389,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 +423,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 +442,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 +490,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 +500,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 +858,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 +1117,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 +1127,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 +1563,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 +1645,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 +1668,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 +1740,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 +1793,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 +1879,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 +1975,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 +2524,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 +2674,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 +2784,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
@@ -3079,5 +3135,4 @@ evaluated and should not be quoted."
(cc-provide 'cc-langs)
-;; arch-tag: 1ab57482-cfc2-4c5b-b628-3539c3098822
;;; cc-langs.el ends here
diff --git a/lisp/progmodes/cc-menus.el b/lisp/progmodes/cc-menus.el
index d060da32699..f53a7da5186 100644
--- a/lisp/progmodes/cc-menus.el
+++ b/lisp/progmodes/cc-menus.el
@@ -1,8 +1,6 @@
;;; cc-menus.el --- imenu support 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, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1987, 1992-2011 Free Software Foundation, Inc.
;; Authors: 1998- Martin Stjernholm
;; 1992-1999 Barry A. Warsaw
@@ -11,8 +9,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.
@@ -442,5 +440,4 @@ Example:
(cc-provide 'cc-menus)
-;; arch-tag: f6b60933-91f0-4145-ab44-70ca6d1b919b
;;; cc-menus.el ends here
diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el
index 798d78c8987..1a2e0027ea7 100644
--- a/lisp/progmodes/cc-mode.el
+++ b/lisp/progmodes/cc-mode.el
@@ -1,8 +1,6 @@
;;; 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, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1987, 1992-2011 Free Software Foundation, Inc.
;; Authors: 2003- Alan Mackenzie
;; 1998- Martin Stjernholm
@@ -12,7 +10,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 +98,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 +407,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 +448,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").
;;
@@ -488,15 +485,10 @@ that requires a literal mode spec at compile time."
;; these variables should always be buffer local; they do not affect
;; indentation style.
- (make-local-variable 'parse-sexp-ignore-comments)
- (make-local-variable 'indent-line-function)
- (make-local-variable 'indent-region-function)
- (make-local-variable 'normal-auto-fill-function)
(make-local-variable 'comment-start)
(make-local-variable 'comment-end)
(make-local-variable 'comment-start-skip)
- (make-local-variable 'comment-multi-line)
- (make-local-variable 'comment-line-break-function)
+
(make-local-variable 'paragraph-start)
(make-local-variable 'paragraph-separate)
(make-local-variable 'paragraph-ignore-fill-prefix)
@@ -504,22 +496,25 @@ that requires a literal mode spec at compile time."
(make-local-variable 'adaptive-fill-regexp)
;; now set their values
- (setq parse-sexp-ignore-comments t
- indent-line-function 'c-indent-line
- indent-region-function 'c-indent-region
- normal-auto-fill-function 'c-do-auto-fill
- comment-multi-line t
- comment-line-break-function 'c-indent-new-comment-line)
+ (set (make-local-variable 'parse-sexp-ignore-comments) t)
+ (set (make-local-variable 'indent-line-function) 'c-indent-line)
+ (set (make-local-variable 'indent-region-function) 'c-indent-region)
+ (set (make-local-variable 'normal-auto-fill-function) 'c-do-auto-fill)
+ (set (make-local-variable 'comment-multi-line) t)
+ (set (make-local-variable 'comment-line-break-function)
+ 'c-indent-new-comment-line)
;; Install `c-fill-paragraph' on `fill-paragraph-function' so that a
;; direct call to `fill-paragraph' behaves better. This still
;; doesn't work with filladapt but it's better than nothing.
- (make-local-variable 'fill-paragraph-function)
- (setq fill-paragraph-function 'c-fill-paragraph)
+ (set (make-local-variable '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.
@@ -530,22 +525,19 @@ that requires a literal mode spec at compile time."
;; Emacs.
(when (boundp 'parse-sexp-lookup-properties)
- (make-local-variable 'parse-sexp-lookup-properties)
- (setq parse-sexp-lookup-properties t))
+ (set (make-local-variable 'parse-sexp-lookup-properties) t))
;; Same as above for XEmacs.
(when (boundp 'lookup-syntax-properties)
- (make-local-variable 'lookup-syntax-properties)
- (setq lookup-syntax-properties t)))
+ (set (make-local-variable 'lookup-syntax-properties) t)))
;; Use this in Emacs 21+ to avoid meddling with the rear-nonsticky
;; property on each character.
(when (boundp 'text-property-default-nonsticky)
- (make-local-variable 'text-property-default-nonsticky)
(mapc (lambda (tprop)
(unless (assq tprop text-property-default-nonsticky)
- (setq text-property-default-nonsticky
- (cons `(,tprop . t) text-property-default-nonsticky))))
+ (set (make-local-variable 'text-property-default-nonsticky)
+ (cons `(,tprop . t) text-property-default-nonsticky))))
'(syntax-table category c-type)))
;; In Emacs 21 and later it's possible to turn off the ad-hoc
@@ -585,8 +577,7 @@ that requires a literal mode spec at compile time."
(setq c-offsets-alist (copy-alist c-offsets-alist))
;; setup the comment indent variable in a Emacs version portable way
- (make-local-variable 'comment-indent-function)
- (setq comment-indent-function 'c-comment-indent)
+ (set (make-local-variable 'comment-indent-function) 'c-comment-indent)
;; ;; Put submode indicators onto minor-mode-alist, but only once.
;; (or (assq 'c-submode-indicators minor-mode-alist)
@@ -597,9 +588,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 +605,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,24 +638,37 @@ 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))))))
- (make-local-variable 'outline-regexp)
- (make-local-variable 'outline-level)
- (setq outline-regexp "[^#\n\^M]"
- outline-level 'c-outline-level)
+ (set (make-local-variable 'outline-regexp) "[^#\n\^M]")
+ (set (make-local-variable 'outline-level) 'c-outline-level)
(let ((rfn (assq mode c-require-final-newline)))
(when rfn
- (make-local-variable 'require-final-newline)
(and (cdr rfn)
- (setq require-final-newline mode-require-final-newline)))))
-
+ (set (make-local-variable '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 +685,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 +799,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 +807,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 +823,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 +863,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 +872,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 +891,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 +929,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 +1016,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 +1053,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 +1069,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)))))))
@@ -1047,8 +1087,7 @@ Note that the style variables are always made local to the buffer."
This does not load the font-lock package. Use after
`c-basic-common-init' and after cc-fonts has been loaded."
- (make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults
+ (set (make-local-variable 'font-lock-defaults)
`(,(if (c-major-mode-is 'awk-mode)
;; awk-mode currently has only one font lock level.
'awk-font-lock-keywords
@@ -1060,8 +1099,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)
@@ -1153,7 +1192,7 @@ Key bindings:
(kill-all-local-variables)
(c-initialize-cc-mode t)
(set-syntax-table c-mode-syntax-table)
- (setq major-mode 'c-mode
+ (setq major-mode 'c-mode ; FIXME: Use define-derived-mode.
mode-name "C"
local-abbrev-table c-mode-abbrev-table
abbrev-mode t)
@@ -1216,7 +1255,7 @@ Key bindings:
(kill-all-local-variables)
(c-initialize-cc-mode t)
(set-syntax-table c++-mode-syntax-table)
- (setq major-mode 'c++-mode
+ (setq major-mode 'c++-mode ; FIXME: Use define-derived-mode.
mode-name "C++"
local-abbrev-table c++-mode-abbrev-table
abbrev-mode t)
@@ -1277,7 +1316,7 @@ Key bindings:
(kill-all-local-variables)
(c-initialize-cc-mode t)
(set-syntax-table objc-mode-syntax-table)
- (setq major-mode 'objc-mode
+ (setq major-mode 'objc-mode ; FIXME: Use define-derived-mode.
mode-name "ObjC"
local-abbrev-table objc-mode-abbrev-table
abbrev-mode t)
@@ -1347,7 +1386,7 @@ Key bindings:
(kill-all-local-variables)
(c-initialize-cc-mode t)
(set-syntax-table java-mode-syntax-table)
- (setq major-mode 'java-mode
+ (setq major-mode 'java-mode ; FIXME: Use define-derived-mode.
mode-name "Java"
local-abbrev-table java-mode-abbrev-table
abbrev-mode t)
@@ -1406,7 +1445,7 @@ Key bindings:
(kill-all-local-variables)
(c-initialize-cc-mode t)
(set-syntax-table idl-mode-syntax-table)
- (setq major-mode 'idl-mode
+ (setq major-mode 'idl-mode ; FIXME: Use define-derived-mode.
mode-name "IDL"
local-abbrev-table idl-mode-abbrev-table)
(use-local-map idl-mode-map)
@@ -1467,7 +1506,7 @@ Key bindings:
(kill-all-local-variables)
(c-initialize-cc-mode t)
(set-syntax-table pike-mode-syntax-table)
- (setq major-mode 'pike-mode
+ (setq major-mode 'pike-mode ; FIXME: Use define-derived-mode.
mode-name "Pike"
local-abbrev-table pike-mode-abbrev-table
abbrev-mode t)
@@ -1541,7 +1580,7 @@ Key bindings:
(kill-all-local-variables)
(c-initialize-cc-mode t)
(set-syntax-table awk-mode-syntax-table)
- (setq major-mode 'awk-mode
+ (setq major-mode 'awk-mode ; FIXME: Use define-derived-mode.
mode-name "AWK"
local-abbrev-table awk-mode-abbrev-table
abbrev-mode t)
@@ -1627,7 +1666,7 @@ Key bindings:
adaptive-fill-regexp)
nil)))
(mapc (lambda (var) (unless (boundp var)
- (setq vars (delq var vars))))
+ (setq vars (delq var vars))))
'(signal-error-on-buffer-boundary
filladapt-mode
defun-prompt-regexp
@@ -1644,5 +1683,4 @@ Key bindings:
(cc-provide 'cc-mode)
-;; arch-tag: 7825e5c4-fd09-439f-a04d-4c13208ba3d7
;;; cc-mode.el ends here
diff --git a/lisp/progmodes/cc-styles.el b/lisp/progmodes/cc-styles.el
index 3adab817be3..e161eb6d0f5 100644
--- a/lisp/progmodes/cc-styles.el
+++ b/lisp/progmodes/cc-styles.el
@@ -1,8 +1,6 @@
;;; cc-styles.el --- support for styles in 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, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1987, 1992-2011 Free Software Foundation, Inc.
;; Authors: 2004- Alan Mackenzie
;; 1998- Martin Stjernholm
@@ -12,8 +10,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 +48,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
@@ -541,13 +538,12 @@ variables."
(when (boundp 'adaptive-fill-first-line-regexp)
;; XEmacs adaptive fill mode doesn't have this.
- (make-local-variable 'adaptive-fill-first-line-regexp)
- (setq adaptive-fill-first-line-regexp
- (concat "\\`" comment-line-prefix
- ;; Maybe we should incorporate the old value here,
- ;; but then we have to do all sorts of kludges to
- ;; deal with the \` and \' it probably contains.
- "\\'"))))
+ (set (make-local-variable 'adaptive-fill-first-line-regexp)
+ (concat "\\`" comment-line-prefix
+ ;; Maybe we should incorporate the old value here,
+ ;; but then we have to do all sorts of kludges to
+ ;; deal with the \` and \' it probably contains.
+ "\\'"))))
;; Set up the values for use in strings. These are the default
;; paragraph-start/separate values, enhanced to accept escaped EOLs as
@@ -649,7 +645,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))
))
@@ -658,5 +654,4 @@ any reason to call this function directly."
(cc-provide 'cc-styles)
-;; arch-tag: c764f61a-96ba-484a-a68f-101c0e9d5d2c
;;; cc-styles.el ends here
diff --git a/lisp/progmodes/cc-vars.el b/lisp/progmodes/cc-vars.el
index 0223cb80a4a..d2a5d117635 100644
--- a/lisp/progmodes/cc-vars.el
+++ b/lisp/progmodes/cc-vars.el
@@ -1,8 +1,6 @@
;;; cc-vars.el --- user customization variables 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, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1987, 1992-2011 Free Software Foundation, Inc.
;; Authors: 2002- Alan Mackenzie
;; 1998- Martin Stjernholm
@@ -12,8 +10,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 +1054,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 +1287,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 +1382,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 +1583,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
@@ -1704,5 +1710,4 @@ It treats escaped EOLs as whitespace.")
(cc-provide 'cc-vars)
-;; arch-tag: d62e9a55-c9fe-409b-b5b6-050b6aa202c9
;;; cc-vars.el ends here
diff --git a/lisp/progmodes/cfengine.el b/lisp/progmodes/cfengine.el
index 1c1589fbbab..a475bbd5932 100644
--- a/lisp/progmodes/cfengine.el
+++ b/lisp/progmodes/cfengine.el
@@ -1,7 +1,6 @@
;;; cfengine.el --- mode for editing Cfengine files
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;; Author: Dave Love <fx@gnu.org>
;; Keywords: languages
@@ -83,12 +82,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))
@@ -227,7 +220,6 @@ to the action header."
;; movement.
(set (make-local-variable 'parens-require-spaces) nil)
- (set (make-local-variable 'require-final-newline) mode-require-final-newline)
(set (make-local-variable 'comment-start) "# ")
(set (make-local-variable 'comment-start-skip)
"\\(\\(?:^\\|[^\\\\\n]\\)\\(?:\\\\\\\\\\)*\\)#+[ \t]*")
@@ -237,13 +229,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)
@@ -255,5 +249,4 @@ to the action header."
(provide 'cfengine)
-;; arch-tag: 6b931be2-1505-4124-afa6-9675971e26d4
;;; cfengine.el ends here
diff --git a/lisp/progmodes/cmacexp.el b/lisp/progmodes/cmacexp.el
index 4f74e407092..322492c5566 100644
--- a/lisp/progmodes/cmacexp.el
+++ b/lisp/progmodes/cmacexp.el
@@ -1,7 +1,6 @@
;;; cmacexp.el --- expand C macros in a region
-;; Copyright (C) 1992, 1994, 1996, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 1994, 1996, 2000-2011 Free Software Foundation, Inc.
;; Author: Francesco Potorti` <pot@gnu.org>
;; Adapted-By: ESR
@@ -403,5 +402,4 @@ Optional arg DISPLAY non-nil means show messages in the echo area."
;; Cleanup.
(kill-buffer outbuf))))
-;; arch-tag: 4f20253c-71ef-4e6d-a774-19087060910e
;;; cmacexp.el ends here
diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el
index e6cbced1fcf..b8cac2fd331 100644
--- a/lisp/progmodes/compile.el
+++ b/lisp/progmodes/compile.el
@@ -1,7 +1,6 @@
;;; compile.el --- run compiler as inferior of Emacs, parse error messages
-;; Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
-;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+;; Copyright (C) 1985-1987, 1993-1999, 2001-2011
;; Free Software Foundation, Inc.
;; Authors: Roland McGrath <roland@gnu.org>,
@@ -29,57 +28,12 @@
;; This package provides the compile facilities documented in the Emacs user's
;; manual.
-;; This mode uses some complex data-structures:
-
-;; LOC (or location) is a list of (COLUMN LINE FILE-STRUCTURE)
-
-;; COLUMN and LINE are numbers parsed from an error message. COLUMN and maybe
-;; LINE will be nil for a message that doesn't contain them. Then the
-;; location refers to a indented beginning of line or beginning of file.
-;; Once any location in some file has been jumped to, the list is extended to
-;; (COLUMN LINE FILE-STRUCTURE MARKER TIMESTAMP . VISITED)
-;; for all LOCs pertaining to that file.
-;; MARKER initially points to LINE and COLUMN in a buffer visiting that file.
-;; Being a marker it sticks to some text, when the buffer grows or shrinks
-;; before that point. VISITED is t if we have jumped there, else nil.
-;; TIMESTAMP is necessary because of "incremental compilation": `omake -P'
-;; polls filesystem for changes and recompiles when a file is modified
-;; using the same *compilation* buffer. this necessitates re-parsing markers.
-
-;; FILE-STRUCTURE is a list of
-;; ((FILENAME DIRECTORY) FORMATS (LINE LOC ...) ...)
-
-;; FILENAME is a string parsed from an error message. DIRECTORY is a string
-;; obtained by following directory change messages. DIRECTORY will be nil for
-;; an absolute filename. FORMATS is a list of formats to apply to FILENAME if
-;; a file of that name can't be found.
-;; The rest of the list is an alist of elements with LINE as key. The keys
-;; are either nil or line numbers. If present, nil comes first, followed by
-;; the numbers in decreasing order. The LOCs for each line are again an alist
-;; ordered the same way. Note that the whole file structure is referenced in
-;; every LOC.
-
-;; MESSAGE is a list of (LOC TYPE END-LOC)
-
-;; TYPE is 0 for info or 1 for warning if the message matcher identified it as
-;; such, 2 otherwise (for a real error). END-LOC is a LOC pointing to the
-;; other end, if the parsed message contained a range. If the end of the
-;; range didn't specify a COLUMN, it defaults to -1, meaning end of line.
-;; These are the value of the `message' text-properties in the compilation
-;; buffer.
-
;;; Code:
(eval-when-compile (require 'cl))
(require 'tool-bar)
(require 'comint)
-(defvar font-lock-extra-managed-props)
-(defvar font-lock-keywords)
-(defvar font-lock-maximum-size)
-(defvar font-lock-support-mode)
-
-
(defgroup compilation nil
"Run compiler as inferior of Emacs, parse error messages."
:group 'tools
@@ -110,6 +64,19 @@ the compilation to be killed, you can use this hook:
integer)
:group 'compilation)
+(defvar compilation-filter-hook nil
+ "Hook run after `compilation-filter' has inserted a string into the buffer.
+It is called with the variable `compilation-filter-start' bound
+to the position of the start of the inserted text, and point at
+its end.
+
+If Emacs lacks asynchronous process support, this hook is run
+after `call-process' inserts the grep output into the buffer.")
+
+(defvar compilation-filter-start nil
+ "Start of the text inserted by `compilation-filter'.
+This is bound to a buffer position before running `compilation-filter-hook'.")
+
(defvar compilation-first-column 1
"*This is how compilers number the first column, usually 1 or 0.")
@@ -123,9 +90,7 @@ in the compilation output, and should return a transformed file name.")
"*Function to call to customize the compilation process.
This function is called immediately before the compilation process is
started. It can be used to set any variables or functions that are used
-while processing the output of the compilation process. The function
-is called with variables `compilation-buffer' and `compilation-window'
-bound to the compilation buffer and window, respectively.")
+while processing the output of the compilation process.")
;;;###autoload
(defvar compilation-buffer-name-function nil
@@ -164,7 +129,10 @@ and a string describing how the process finished.")
(defvar compilation-num-errors-found)
-(defconst compilation-error-regexp-alist-alist
+;; If you make any changes to `compilation-error-regexp-alist-alist',
+;; be sure to run the ERT test in test/automated/compile-tests.el.
+
+(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))
@@ -176,8 +144,8 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1))
" in line \\([0-9]+\\) of file \\([^ \n]+[^. \n]\\)\\.? " 2 1)
(ant
- "^[ \t]*\\[[^] \n]+\\][ \t]*\\([^: \n]+\\):\\([0-9]+\\):\\(?:\\([0-9]+\\):[0-9]+:[0-9]+:\\)?\
-\\( warning\\)?" 1 2 3 (4))
+ "^[ \t]*\\[[^] \n]+\\][ \t]*\\([^: \n]+\\):\\([0-9]+\\):\\(?:\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\):\\)?\
+\\( warning\\)?" 1 (2 . 4) (3 . 5) (4))
(bash
"^\\([^: \n\t]+\\): line \\([0-9]+\\):" 1 2)
@@ -196,6 +164,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))
@@ -228,11 +200,28 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1))
(jikes-file
"^\\(?:Found\\|Issued\\) .* compiling \"\\(.+\\)\":$" 1 nil nil 0)
+
+
+ ;; This used to be pathologically slow on long lines (Bug#3441),
+ ;; due to matching filenames via \\(.*?\\). This might be faster.
+ (maven
+ ;; Maven is a popular free software build tool for Java.
+ "\\([0-9]*[^0-9\n]\\(?:[^\n :]\\| [^-/\n]\\|:[^ \n]\\)*?\\):\\[\\([0-9]+\\),\\([0-9]+\\)\\] " 1 2 3)
+
(jikes-line
"^ *\\([0-9]+\\)\\.[ \t]+.*\n +\\(<-*>\n\\*\\*\\* \\(?:Error\\|Warnin\\(g\\)\\)\\)"
nil 1 nil 2 0
(2 (compilation-face '(3))))
+ (gcc-include
+ "^\\(?:In file included \\| \\|\t\\)from \
+\\([0-9]*[^0-9\n]\\(?:[^\n :]\\| [^-/\n]\\|:[^ \n]\\)*?\\):\
+\\([0-9]+\\)\\(?::\\([0-9]+\\)\\)?\\(?:\\(:\\)\\|\\(,\\|$\\)\\)?"
+ 1 2 3 (4 . 5))
+
+ (ruby-Test::Unit
+ "^[\t ]*\\[\\([^\(].*\\):\\([1-9][0-9]*\\)\\(\\]\\)?:in " 1 2)
+
(gnu
;; The first line matches the program name for
@@ -255,21 +244,17 @@ 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]\\)*?\\): ?\
-\\([0-9]+\\)\\(?:\\([.:]\\)\\([0-9]+\\)\\)?\
+ ;; 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:\\)\\|\
*\\([Ii]nfo\\(?:\\>\\|rmationa?l?\\)\\|I:\\|instantiated from\\|[Nn]ote\\)\\|\
\[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))
+ 1 (2 . 4) (3 . 5) (6 . 7))
(lcc
"^\\(?:E\\|\\(W\\)\\), \\([^(\n]+\\)(\\([0-9]+\\),[ \t]*\\([0-9]+\\)"
@@ -279,16 +264,15 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1))
"^makepp\\(?:\\(?:: warning\\(:\\).*?\\|\\(: Scanning\\|: [LR]e?l?oading makefile\\|: Imported\\|log:.*?\\) \\|: .*?\\)\
`\\(\\(\\S +?\\)\\(?::\\([0-9]+\\)\\)?\\)['(]\\)"
4 5 nil (1 . 2) 3
- ("`\\(\\(\\S +?\\)\\(?::\\([0-9]+\\)\\)?\\)['(]" nil nil
- (2 compilation-info-face)
- (3 compilation-line-face nil t)
- (1 (compilation-error-properties 2 3 nil nil nil 0 nil)
- append)))
-
- ;; This regexp is pathologically slow on long lines (Bug#3441).
- ;; (maven
- ;; ;; Maven is a popular build tool for Java. Maven is Free Software.
- ;; "\\(.*?\\):\\[\\([0-9]+\\),\\([0-9]+\\)\\]" 1 2 3)
+ (0 (progn (save-match-data
+ (compilation-parse-errors
+ (match-end 0) (line-end-position)
+ `("`\\(\\(\\S +?\\)\\(?::\\([0-9]+\\)\\)?\\)['(]"
+ 2 3 nil
+ ,(cond ((match-end 1) 1) ((match-end 2) 0) (t 2))
+ 1)))
+ (end-of-line)
+ nil)))
;; Should be lint-1, lint-2 (SysV lint)
(mips-1
@@ -306,7 +290,12 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1))
(omake
;; "omake -P" reports "file foo changed"
;; (useful if you do "cvs up" and want to see what has changed)
- "omake: file \\(.*\\) changed" 1)
+ "omake: file \\(.*\\) changed" 1 nil nil nil nil
+ ;; FIXME-omake: This tries to prevent reusing pre-existing markers
+ ;; for subsequent messages, since those messages's line numbers
+ ;; are about another version of the file.
+ (0 (progn (compilation--flush-file-structure (match-string 1))
+ nil)))
(oracle
"^\\(?:Semantic error\\|Error\\|PCC-[0-9]+:\\).* line \\([0-9]+\\)\
@@ -360,12 +349,10 @@ File = \\(.+\\), Line = \\([0-9]+\\)\\(?:, Column = \\([0-9]+\\)\\)?"
(gcov-file
"^ *-: *\\(0\\):Source:\\(.+\\)$"
- 2 1 nil 0 nil
- (1 compilation-line-face prepend) (2 compilation-info-face prepend))
+ 2 1 nil 0 nil)
(gcov-header
"^ *-: *\\(0\\):\\(?:Object\\|Graph\\|Data\\|Runs\\|Programs\\):.+$"
- nil 1 nil 0 nil
- (1 compilation-line-face prepend))
+ nil 1 nil 0 nil)
;; Underlines over all lines of gcov output are too uncomfortable to read.
;; However, hyperlinks embedded in the lines are useful.
;; So I put default face on the lines; and then put
@@ -374,18 +361,18 @@ File = \\(.+\\), Line = \\([0-9]+\\)\\(?:, Column = \\([0-9]+\\)\\)?"
(gcov-nomark
"^ *-: *\\([1-9]\\|[0-9]\\{2,\\}\\):.*$"
nil 1 nil 0 nil
- (0 'default t)
- (1 compilation-line-face prepend))
+ (0 'default)
+ (1 compilation-line-face))
(gcov-called-line
"^ *\\([0-9]+\\): *\\([0-9]+\\):.*$"
nil 2 nil 0 nil
- (0 'default t)
- (1 compilation-info-face prepend) (2 compilation-line-face prepend))
+ (0 'default)
+ (1 compilation-info-face) (2 compilation-line-face))
(gcov-never-called
"^ *\\(#####\\): *\\([0-9]+\\):.*$"
nil 2 nil 2 nil
- (0 'default t)
- (1 compilation-error-face prepend) (2 compilation-line-face prepend))
+ (0 'default)
+ (1 compilation-error-face) (2 compilation-line-face))
(perl--Pod::Checker
;; podchecker error messages, per Pod::Checker.
@@ -497,8 +484,9 @@ What matched the HYPERLINK'th subexpression has `mouse-face' and
`compilation-message-face' applied. If this is nil, the text
matched by the whole REGEXP becomes the hyperlink.
-Additional HIGHLIGHTs as described under `font-lock-keywords' can
-be added."
+Additional HIGHLIGHTs take the shape (SUBMATCH FACE), where SUBMATCH is
+the number of a submatch that should be highlighted when it matches,
+and FACE is an expression returning the face to use for that submatch.."
:type '(repeat (choice (symbol :tag "Predefined symbol")
(sexp :tag "Error specification")))
:link `(file-link :tag "example file"
@@ -534,12 +522,12 @@ 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)
+ (0 '(face nil compilation-message nil help-echo nil mouse-face nil) t)
(1 compilation-info-face))
("^Compilation \\(exited abnormally\\|interrupt\\|killed\\|terminated\\|segmentation fault\\)\\(?:.*with code \\([0-9]+\\)\\)?.*"
- (0 '(face nil message nil help-echo nil mouse-face nil) t)
+ (0 '(face nil compilation-message nil help-echo nil mouse-face nil) t)
(1 compilation-error-face)
(2 compilation-error-face nil t)))
"Additional things to highlight in Compilation mode.
@@ -581,6 +569,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.
@@ -649,34 +652,25 @@ starting the compilation process.")
:version "22.1")
(defface compilation-warning
- '((((class color) (min-colors 16)) (:foreground "Orange" :weight bold))
- (((class color)) (:foreground "cyan" :weight bold))
- (t (:weight bold)))
+ '((t :inherit font-lock-variable-name-face))
"Face used to highlight compiler warnings."
:group 'compilation
:version "22.1")
(defface compilation-info
- '((((class color) (min-colors 16) (background light))
- (:foreground "Green3" :weight bold))
- (((class color) (min-colors 88) (background dark))
- (:foreground "Green1" :weight bold))
- (((class color) (min-colors 16) (background dark))
- (:foreground "Green" :weight bold))
- (((class color)) (:foreground "green" :weight bold))
- (t (:weight bold)))
+ '((t :inherit font-lock-type-face))
"Face used to highlight compiler information."
:group 'compilation
:version "22.1")
(defface compilation-line-number
- '((t :inherit font-lock-variable-name-face))
+ '((t :inherit font-lock-keyword-face))
"Face for displaying line numbers in compiler messages."
:group 'compilation
:version "22.1")
(defface compilation-column-number
- '((t :inherit font-lock-type-face))
+ '((t :inherit font-lock-doc-face))
"Face for displaying column numbers in compiler messages."
:group 'compilation
:version "22.1")
@@ -709,17 +703,15 @@ Faces `compilation-error-face', `compilation-warning-face',
(defvar compilation-enter-directory-face 'font-lock-function-name-face
"Face name to use for entering directory messages.")
-(defvar compilation-leave-directory-face 'font-lock-type-face
+(defvar compilation-leave-directory-face 'font-lock-builtin-face
"Face name to use for leaving directory messages.")
;; Used for compatibility with the old compile.el.
-(defvaralias 'compilation-last-buffer 'next-error-last-buffer)
-(defvar compilation-parsing-end (make-marker))
(defvar compilation-parse-errors-function nil)
-(defvar compilation-error-list nil)
-(defvar compilation-old-error-list nil)
+(make-obsolete 'compilation-parse-errors-function
+ 'compilation-error-regexp-alist "24.1")
(defcustom compilation-auto-jump-to-first-error nil
"If non-nil, automatically jump to the first error during compilation."
@@ -731,6 +723,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.")
@@ -741,12 +736,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
@@ -761,23 +771,158 @@ from a different message."
(and (cdr type) (match-end (cdr type)) compilation-info-face)
compilation-error-face))
+;; LOC (or location) is a list of (COLUMN LINE FILE-STRUCTURE nil nil)
+
+;; COLUMN and LINE are numbers parsed from an error message. COLUMN and maybe
+;; LINE will be nil for a message that doesn't contain them. Then the
+;; location refers to a indented beginning of line or beginning of file.
+;; Once any location in some file has been jumped to, the list is extended to
+;; (COLUMN LINE FILE-STRUCTURE MARKER TIMESTAMP . VISITED)
+;; for all LOCs pertaining to that file.
+;; MARKER initially points to LINE and COLUMN in a buffer visiting that file.
+;; Being a marker it sticks to some text, when the buffer grows or shrinks
+;; before that point. VISITED is t if we have jumped there, else nil.
+;; FIXME-omake: TIMESTAMP was used to try and handle "incremental compilation":
+;; `omake -P' polls filesystem for changes and recompiles when a file is
+;; modified using the same *compilation* buffer. this necessitates
+;; re-parsing markers.
+
+;; (defstruct (compilation--loc
+;; (:constructor nil)
+;; (:copier nil)
+;; (:constructor compilation--make-loc
+;; (file-struct line col marker))
+;; (:conc-name compilation--loc->))
+;; col line file-struct marker timestamp visited)
+
+;; FIXME: We don't use a defstruct because of compilation-assq which looks up
+;; and creates part of the LOC (only the first cons cell containing the COL).
+
+(defmacro compilation--make-cdrloc (line file-struct marker)
+ `(list ,line ,file-struct ,marker nil))
+(defmacro compilation--loc->col (loc) `(car ,loc))
+(defmacro compilation--loc->line (loc) `(cadr ,loc))
+(defmacro compilation--loc->file-struct (loc) `(nth 2 ,loc))
+(defmacro compilation--loc->marker (loc) `(nth 3 ,loc))
+;; (defmacro compilation--loc->timestamp (loc) `(nth 4 ,loc))
+(defmacro compilation--loc->visited (loc) `(nthcdr 5 ,loc))
+
+;; FILE-STRUCTURE is a list of
+;; ((FILENAME DIRECTORY) FORMATS (LINE LOC ...) ...)
+
+;; FILENAME is a string parsed from an error message. DIRECTORY is a string
+;; obtained by following directory change messages. DIRECTORY will be nil for
+;; an absolute filename. FORMATS is a list of formats to apply to FILENAME if
+;; a file of that name can't be found.
+;; The rest of the list is an alist of elements with LINE as key. The keys
+;; are either nil or line numbers. If present, nil comes first, followed by
+;; the numbers in decreasing order. The LOCs for each line are again an alist
+;; ordered the same way. Note that the whole file structure is referenced in
+;; every LOC.
+
+(defmacro compilation--make-file-struct (file-spec formats &optional loc-tree)
+ `(cons ,file-spec (cons ,formats ,loc-tree)))
+(defmacro compilation--file-struct->file-spec (fs) `(car ,fs))
+(defmacro compilation--file-struct->formats (fs) `(cadr ,fs))
+;; The FORMATS field plays the role of ANCHOR in the loc-tree.
+(defmacro compilation--file-struct->loc-tree (fs) `(cdr ,fs))
+
+;; MESSAGE is a list of (LOC TYPE END-LOC)
+
+;; TYPE is 0 for info or 1 for warning if the message matcher identified it as
+;; such, 2 otherwise (for a real error). END-LOC is a LOC pointing to the
+;; other end, if the parsed message contained a range. If the end of the
+;; range didn't specify a COLUMN, it defaults to -1, meaning end of line.
+;; These are the value of the `compilation-message' text-properties in the
+;; compilation buffer.
+
+(defstruct (compilation--message
+ (:constructor nil)
+ (:copier nil)
+ ;; (:type list) ;Old representation.
+ (:constructor compilation--make-message (loc type end-loc))
+ (:conc-name compilation--message->))
+ loc type end-loc)
+
+(defvar compilation--previous-directory-cache nil
+ "A pair (POS . RES) caching the result of previous directory search.
+Basically, this pair says that calling
+ (previous-single-property-change POS 'compilation-directory)
+returned RES, i.e. there is no change of `compilation-directory' between
+POS and RES.")
+(make-variable-buffer-local 'compilation--previous-directory-cache)
+
+(defun compilation--flush-directory-cache (start _end)
+ (cond
+ ((or (not compilation--previous-directory-cache)
+ (<= (car compilation--previous-directory-cache) start)))
+ ((or (not (cdr compilation--previous-directory-cache))
+ (null (marker-buffer (cdr compilation--previous-directory-cache)))
+ (<= (cdr compilation--previous-directory-cache) start))
+ (set-marker (car compilation--previous-directory-cache) start))
+ (t (setq compilation--previous-directory-cache nil))))
+
+(defun compilation--previous-directory (pos)
+ "Like (previous-single-property-change POS 'compilation-directory), but faster."
+ ;; This avoids an N² behavior when there's no/few compilation-directory
+ ;; entries, in which case each call to previous-single-property-change
+ ;; ends up having to walk very far back to find the last change.
+ (if (and compilation--previous-directory-cache
+ (< pos (car compilation--previous-directory-cache))
+ (or (null (cdr compilation--previous-directory-cache))
+ (< (cdr compilation--previous-directory-cache) pos)))
+ ;; No need to call previous-single-property-change.
+ (cdr compilation--previous-directory-cache)
+
+ (let* ((cache (and compilation--previous-directory-cache
+ (<= (car compilation--previous-directory-cache) pos)
+ (car compilation--previous-directory-cache)))
+ (prev
+ (previous-single-property-change
+ pos 'compilation-directory nil cache))
+ (res
+ (cond
+ ((null cache)
+ (setq compilation--previous-directory-cache
+ (cons (copy-marker pos) (if prev (copy-marker prev))))
+ prev)
+ ((and prev (= prev cache))
+ (if cache
+ (set-marker (car compilation--previous-directory-cache) pos)
+ (setq compilation--previous-directory-cache
+ (cons (copy-marker pos) nil)))
+ (cdr compilation--previous-directory-cache))
+ (t
+ (if cache
+ (progn
+ (set-marker cache pos)
+ (setcdr compilation--previous-directory-cache
+ (copy-marker prev)))
+ (setq compilation--previous-directory-cache
+ (cons (copy-marker pos) (if prev (copy-marker prev)))))
+ prev))))
+ (if (markerp res) (marker-position res) res))))
+
;; Internal function for calculating the text properties of a directory
-;; change message. The directory property is important, because it is
-;; the stack of nested enter-messages. Relative filenames on the following
+;; change message. The compilation-directory property is important, because it
+;; is the stack of nested enter-messages. Relative filenames on the following
;; lines are relative to the top of the stack.
(defun compilation-directory-properties (idx leave)
(if leave (setq leave (match-end leave)))
;; find previous stack, and push onto it, or if `leave' pop it
- (let ((dir (previous-single-property-change (point) 'directory)))
- (setq dir (if dir (or (get-text-property (1- dir) 'directory)
- (get-text-property dir 'directory))))
- `(face ,(if leave
- compilation-leave-directory-face
- compilation-enter-directory-face)
- directory ,(if leave
- (or (cdr dir)
- '(nil)) ; nil only isn't a property-change
- (cons (match-string-no-properties idx) dir))
+ (let ((dir (compilation--previous-directory (match-beginning 0))))
+ (setq dir (if dir (or (get-text-property (1- dir) 'compilation-directory)
+ (get-text-property dir 'compilation-directory))))
+ `(font-lock-face ,(if leave
+ compilation-leave-directory-face
+ compilation-enter-directory-face)
+ compilation-directory ,(if leave
+ (or (cdr dir)
+ '(nil)) ; nil only isn't a property-change
+ (cons (match-string-no-properties idx) dir))
+ ;; Place a `compilation-message' everywhere we change text-properties
+ ;; so compilation--remove-properties can know what to remove.
+ compilation-message ,(compilation--make-message nil 0 nil)
mouse-face highlight
keymap compilation-button-map
help-echo "mouse-2: visit destination directory")))
@@ -816,28 +961,29 @@ from a different message."
;; Return a property list with all meta information on this error location.
(defun compilation-error-properties (file line end-line col end-col type fmt)
- (unless (< (next-single-property-change (match-beginning 0)
- 'directory nil (point))
- (point))
+ (unless (text-property-not-all (match-beginning 0) (point)
+ 'compilation-message nil)
(if file
- (if (functionp file)
- (setq file (funcall file))
- (let (dir)
- (setq file (match-string-no-properties file))
+ (when (stringp
+ (setq file (if (functionp file) (funcall file)
+ (match-string-no-properties file))))
+ (let ((dir
(unless (file-name-absolute-p file)
- (setq dir (previous-single-property-change (point) 'directory)
- dir (if dir (or (get-text-property (1- dir) 'directory)
- (get-text-property dir 'directory)))))
+ (let ((pos (compilation--previous-directory
+ (match-beginning 0))))
+ (when pos
+ (or (get-text-property (1- pos) 'compilation-directory)
+ (get-text-property pos 'compilation-directory)))))))
(setq file (cons file (car dir)))))
;; This message didn't mention one, get it from previous
(let ((prev-pos
;; Find the previous message.
- (previous-single-property-change (point) 'message)))
+ (previous-single-property-change (point) 'compilation-message)))
(if prev-pos
;; Get the file structure that belongs to it.
(let* ((prev
- (or (get-text-property (1- prev-pos) 'message)
- (get-text-property prev-pos 'message)))
+ (or (get-text-property (1- prev-pos) 'compilation-message)
+ (get-text-property prev-pos 'compilation-message)))
(prev-struct
(car (nth 2 (car prev)))))
;; Construct FILE . DIR from that.
@@ -876,7 +1022,8 @@ from a different message."
(run-with-timer 0 nil 'compilation-auto-jump
(current-buffer) (match-beginning 0)))
- (compilation-internal-error-properties file line end-line col end-col type fmt)))
+ (compilation-internal-error-properties
+ file line end-line col end-col type fmt)))
(defun compilation-move-to-column (col screen)
"Go to column COL on the current line.
@@ -897,22 +1044,25 @@ FMTS is a list of format specs for transforming the file name.
(let* ((file-struct (compilation-get-file-structure file fmts))
;; Get first already existing marker (if any has one, all have one).
;; Do this first, as the compilation-assq`s may create new nodes.
- (marker-line (car (cddr file-struct))) ; a line structure
- (marker (nth 3 (cadr marker-line))) ; its marker
+ (marker-line ; a line structure
+ (cadr (compilation--file-struct->loc-tree file-struct)))
+ (marker
+ (if marker-line (compilation--loc->marker (cadr marker-line))))
(compilation-error-screen-columns compilation-error-screen-columns)
end-marker loc end-loc)
(if (not (and marker (marker-buffer marker)))
(setq marker nil) ; no valid marker for this file
(setq loc (or line 1)) ; normalize no linenumber to line 1
(catch 'marker ; find nearest loc, at least one exists
- (dolist (x (nthcdr 3 file-struct)) ; loop over remaining lines
+ (dolist (x (cddr (compilation--file-struct->loc-tree
+ file-struct))) ; Loop over remaining lines.
(if (> (car x) loc) ; still bigger
(setq marker-line x)
(if (> (- (or (car marker-line) 1) loc)
(- loc (car x))) ; current line is nearer
(setq marker-line x))
(throw 'marker t))))
- (setq marker (nth 3 (cadr marker-line))
+ (setq marker (compilation--loc->marker (cadr marker-line))
marker-line (or (car marker-line) 1))
(with-current-buffer (marker-buffer marker)
(save-excursion
@@ -925,7 +1075,7 @@ FMTS is a list of format specs for transforming the file name.
(end-of-line)
(compilation-move-to-column
end-col compilation-error-screen-columns))
- (setq end-marker (list (point-marker))))
+ (setq end-marker (point-marker)))
(beginning-of-line (if end-line
(- line end-line -1)
(- loc marker-line -1)))
@@ -933,120 +1083,259 @@ FMTS is a list of format specs for transforming the file name.
(compilation-move-to-column
col compilation-error-screen-columns)
(forward-to-indentation 0))
- (setq marker (list (point-marker)))))))
+ (setq marker (point-marker))))))
- (setq loc (compilation-assq line (cdr file-struct)))
+ (setq loc (compilation-assq line (compilation--file-struct->loc-tree
+ file-struct)))
+ (setq end-loc
(if end-line
- (setq end-loc (compilation-assq end-line (cdr file-struct))
- end-loc (compilation-assq end-col end-loc))
+ (compilation-assq
+ end-col (compilation-assq
+ end-line (compilation--file-struct->loc-tree
+ file-struct)))
(if end-col ; use same line element
- (setq end-loc (compilation-assq end-col loc))))
+ (compilation-assq end-col loc))))
(setq loc (compilation-assq col loc))
;; If they are new, make the loc(s) reference the file they point to.
- (or (cdr loc) (setcdr loc `(,line ,file-struct ,@marker)))
+ ;; FIXME-omake: there's a problem with timestamps here: the markers
+ ;; relative to which we computed the current `marker' have a timestamp
+ ;; almost guaranteed to be different from compilation-buffer-modtime, so if
+ ;; we use their timestamp, we'll never use `loc' since the timestamp won't
+ ;; match compilation-buffer-modtime, and if we use
+ ;; compilation-buffer-modtime then we have different timestamps for
+ ;; locations that were computed together, which doesn't make sense either.
+ ;; I think this points to a fundamental problem in our approach to the
+ ;; "omake -P" problem. --Stef
+ (or (cdr loc)
+ (setcdr loc (compilation--make-cdrloc line file-struct marker)))
(if end-loc
(or (cdr end-loc)
- (setcdr end-loc `(,(or end-line line) ,file-struct ,@end-marker))))
+ (setcdr end-loc
+ (compilation--make-cdrloc (or end-line line) file-struct
+ end-marker))))
;; Must start with face
- `(face ,compilation-message-face
- message (,loc ,type ,end-loc)
- ,@(if compilation-debug
- `(debug (,(assoc (with-no-warnings matcher) font-lock-keywords)
- ,@(match-data))))
- help-echo ,(if col
- "mouse-2: visit this file, line and column"
- (if line
- "mouse-2: visit this file and line"
- "mouse-2: visit this file"))
- keymap compilation-button-map
- mouse-face highlight)))
+ `(font-lock-face ,compilation-message-face
+ compilation-message ,(compilation--make-message loc type end-loc)
+ help-echo ,(if col
+ "mouse-2: visit this file, line and column"
+ (if line
+ "mouse-2: visit this file and line"
+ "mouse-2: visit this file"))
+ keymap compilation-button-map
+ mouse-face highlight)))
+
+(defun compilation--put-prop (matchnum prop val)
+ (when (and (integerp matchnum) (match-beginning matchnum))
+ (put-text-property
+ (match-beginning matchnum) (match-end matchnum)
+ prop val)))
+
+(defun compilation--remove-properties (&optional start end)
+ (with-silent-modifications
+ ;; When compile.el used font-lock directly, we could just remove all
+ ;; our text-properties in one go, but now that we manually place
+ ;; font-lock-face, we have to be careful to only remove the font-lock-face
+ ;; we placed.
+ ;; (remove-list-of-text-properties
+ ;; (or start (point-min)) (or end (point-max))
+ ;; '(compilation-debug compilation-directory compilation-message
+ ;; font-lock-face help-echo mouse-face))
+ (let (next)
+ (unless start (setq start (point-min)))
+ (unless end (setq end (point-max)))
+ (compilation--flush-directory-cache start end)
+ (while
+ (progn
+ (setq next (or (next-single-property-change
+ start 'compilation-message nil end)
+ end))
+ (when (get-text-property start 'compilation-message)
+ (remove-list-of-text-properties
+ start next
+ '(compilation-debug compilation-directory compilation-message
+ font-lock-face help-echo mouse-face)))
+ (< next end))
+ (setq start next)))))
+
+(defun compilation--parse-region (start end)
+ (goto-char end)
+ (unless (bolp)
+ ;; We generally don't like to parse partial lines.
+ (assert (eobp))
+ (when (let ((proc (get-buffer-process (current-buffer))))
+ (and proc (memq (process-status proc) '(run open))))
+ (setq end (line-beginning-position))))
+ (compilation--remove-properties start end)
+ (if compilation-parse-errors-function
+ ;; An old package! Try the compatibility code.
+ (progn
+ (goto-char start)
+ (compilation--compat-parse-errors end))
+
+ ;; compilation-directory-matcher is the only part that really needs to be
+ ;; parsed sequentially. So we could split it out, handle directories
+ ;; like syntax-propertize, and the rest as font-lock-keywords. But since
+ ;; we want to have it work even when font-lock is off, we'd then need to
+ ;; use our own compilation-parsed text-property to keep track of the parts
+ ;; that have already been parsed.
+ (goto-char start)
+ (while (re-search-forward (car compilation-directory-matcher)
+ end t)
+ (compilation--flush-directory-cache (match-beginning 0) (match-end 0))
+ (when compilation-debug
+ (font-lock-append-text-property
+ (match-beginning 0) (match-end 0)
+ 'compilation-debug
+ (vector 'directory compilation-directory-matcher)))
+ (dolist (elt (cdr compilation-directory-matcher))
+ (add-text-properties (match-beginning (car elt))
+ (match-end (car elt))
+ (compilation-directory-properties
+ (car elt) (cdr elt)))))
+
+ (compilation-parse-errors start end)))
+
+(defun compilation-parse-errors (start end &rest rules)
+ "Parse errors between START and END.
+The errors recognized are the ones specified in RULES which default
+to `compilation-error-regexp-alist' if RULES is nil."
+ (dolist (item (or rules compilation-error-regexp-alist))
+ (if (symbolp item)
+ (setq item (cdr (assq item
+ compilation-error-regexp-alist-alist))))
+ (let ((file (nth 1 item))
+ (line (nth 2 item))
+ (col (nth 3 item))
+ (type (nth 4 item))
+ (pat (car item))
+ end-line end-col fmt
+ props)
+
+ ;; omake reports some error indented, so skip the indentation.
+ ;; another solution is to modify (some?) regexps in
+ ;; `compilation-error-regexp-alist'.
+ ;; note that omake usage is not limited to ocaml and C (for stubs).
+ ;; FIXME-omake: Doing it here seems wrong, at least it should depend on
+ ;; whether or not omake's own error messages are recognized.
+ (cond
+ ((not (memq 'omake compilation-error-regexp-alist)) nil)
+ ((string-match "\\`\\([^^]\\|^\\( \\*\\|\\[\\)\\)" pat)
+ nil) ;; Not anchored or anchored but already allows empty spaces.
+ (t (setq pat (concat "^ *" (substring pat 1)))))
+
+ (if (consp file) (setq fmt (cdr file) file (car file)))
+ (if (consp line) (setq end-line (cdr line) line (car line)))
+ (if (consp col) (setq end-col (cdr col) col (car col)))
+
+ (if (functionp line)
+ ;; The old compile.el had here an undocumented hook that
+ ;; allowed `line' to be a function that computed the actual
+ ;; error location. Let's do our best.
+ (progn
+ (goto-char start)
+ (while (re-search-forward pat end t)
+ (save-match-data
+ (when compilation-debug
+ (font-lock-append-text-property
+ (match-beginning 0) (match-end 0)
+ 'compilation-debug (vector 'functionp item)))
+ (add-text-properties
+ (match-beginning 0) (match-end 0)
+ (compilation--compat-error-properties
+ (funcall line (cons (match-string file)
+ (cons default-directory
+ (nthcdr 4 item)))
+ (if col (match-string col))))))
+ (compilation--put-prop
+ file 'font-lock-face compilation-error-face)))
+
+ (unless (or (null (nth 5 item)) (integerp (nth 5 item)))
+ (error "HYPERLINK should be an integer: %s" (nth 5 item)))
+
+ (goto-char start)
+ (while (re-search-forward pat end t)
+ (when (setq props (compilation-error-properties
+ file line end-line col end-col (or type 2) fmt))
+
+ (when (integerp file)
+ (compilation--put-prop
+ file 'font-lock-face
+ (if (consp type)
+ (compilation-face type)
+ (symbol-value (aref [compilation-info-face
+ compilation-warning-face
+ compilation-error-face]
+ (or type 2))))))
+
+ (compilation--put-prop
+ line 'font-lock-face compilation-line-face)
+ (compilation--put-prop
+ end-line 'font-lock-face compilation-line-face)
+
+ (compilation--put-prop
+ col 'font-lock-face compilation-column-face)
+ (compilation--put-prop
+ end-col 'font-lock-face compilation-column-face)
+
+ (dolist (extra-item (nthcdr 6 item))
+ (let ((mn (pop extra-item)))
+ (when (match-beginning mn)
+ (let ((face (eval (car extra-item))))
+ (cond
+ ((null face))
+ ((symbolp face)
+ (put-text-property
+ (match-beginning mn) (match-end mn)
+ 'font-lock-face face))
+ (t
+ (error "Don't know how to handle face %S"
+ face)))))))
+ (let ((mn (or (nth 5 item) 0)))
+ (when compilation-debug
+ (font-lock-append-text-property
+ (match-beginning 0) (match-end 0)
+ 'compilation-debug (vector 'std item props)))
+ (add-text-properties
+ (match-beginning mn) (match-end mn)
+ (cddr props))
+ (font-lock-append-text-property
+ (match-beginning mn) (match-end mn)
+ 'font-lock-face (cadr props)))))))))
+
+(defvar compilation--parsed -1)
+(make-variable-buffer-local 'compilation--parsed)
+
+(defun compilation--ensure-parse (limit)
+ "Make sure the text has been parsed up to LIMIT."
+ (save-excursion
+ (goto-char limit)
+ (setq limit (line-beginning-position 2))
+ (unless (markerp compilation--parsed)
+ ;; We use a marker for compilation--parsed so that users (such as
+ ;; grep.el) don't need to flush-parse when they modify the buffer
+ ;; in a way that impacts buffer positions but does not require
+ ;; re-parsing.
+ (setq compilation--parsed (point-min-marker)))
+ (when (< compilation--parsed limit)
+ (let ((start (max compilation--parsed (point-min))))
+ (move-marker compilation--parsed limit)
+ (goto-char start)
+ (forward-line 0) ;Not line-beginning-position: ignore (comint) fields.
+ (with-silent-modifications
+ (compilation--parse-region (point) compilation--parsed)))))
+ nil)
+
+(defun compilation--flush-parse (start _end)
+ "Mark the region between START and END for re-parsing."
+ (if (markerp compilation--parsed)
+ (move-marker compilation--parsed (min start compilation--parsed))))
(defun compilation-mode-font-lock-keywords ()
"Return expressions to highlight in Compilation mode."
- (if compilation-parse-errors-function
- ;; An old package! Try the compatibility code.
- '((compilation-compat-parse-errors))
- (append
- ;; make directory tracking
- (if compilation-directory-matcher
- `((,(car compilation-directory-matcher)
- ,@(mapcar (lambda (elt)
- `(,(car elt)
- (compilation-directory-properties
- ,(car elt) ,(cdr elt))
- t t))
- (cdr compilation-directory-matcher)))))
-
- ;; Compiler warning/error lines.
- (mapcar
- (lambda (item)
- (if (symbolp item)
- (setq item (cdr (assq item
- compilation-error-regexp-alist-alist))))
- (let ((file (nth 1 item))
- (line (nth 2 item))
- (col (nth 3 item))
- (type (nth 4 item))
- (pat (car item))
- end-line end-col fmt)
- ;; omake reports some error indented, so skip the indentation.
- ;; another solution is to modify (some?) regexps in
- ;; `compilation-error-regexp-alist'.
- ;; note that omake usage is not limited to ocaml and C (for stubs).
- (when (and (= ?^ (aref pat 0)) ; anchored: starts with "^"
- ;; but does not allow an arbitrary number of leading spaces
- (not (and (= ? (aref pat 1)) (= ?* (aref pat 2)))))
- (setq pat (concat "^ *" (substring pat 1))))
- (if (consp file) (setq fmt (cdr file) file (car file)))
- (if (consp line) (setq end-line (cdr line) line (car line)))
- (if (consp col) (setq end-col (cdr col) col (car col)))
-
- (if (functionp line)
- ;; The old compile.el had here an undocumented hook that
- ;; allowed `line' to be a function that computed the actual
- ;; error location. Let's do our best.
- `(,pat
- (0 (save-match-data
- (compilation-compat-error-properties
- (funcall ',line (cons (match-string ,file)
- (cons default-directory
- ',(nthcdr 4 item)))
- ,(if col `(match-string ,col))))))
- (,file compilation-error-face t))
-
- (unless (or (null (nth 5 item)) (integerp (nth 5 item)))
- (error "HYPERLINK should be an integer: %s" (nth 5 item)))
-
- `(,pat
-
- ,@(when (integerp file)
- `((,file ,(if (consp type)
- `(compilation-face ',type)
- (aref [compilation-info-face
- compilation-warning-face
- compilation-error-face]
- (or type 2))))))
-
- ,@(when line
- `((,line compilation-line-face nil t)))
- ,@(when end-line
- `((,end-line compilation-line-face nil t)))
-
- ,@(when (integerp col)
- `((,col compilation-column-face nil t)))
- ,@(when (integerp end-col)
- `((,end-col compilation-column-face nil t)))
-
- ,@(nthcdr 6 item)
- (,(or (nth 5 item) 0)
- (compilation-error-properties ',file ,line ,end-line
- ,col ,end-col ',(or type 2)
- ',fmt)
- append))))) ; for compilation-message-face
- compilation-error-regexp-alist)
-
- compilation-mode-font-lock-keywords)))
+ (append
+ '((compilation--ensure-parse))
+ compilation-mode-font-lock-keywords))
(defun compilation-read-command (command)
(read-shell-command "Compile command: " command
@@ -1092,7 +1381,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))
@@ -1103,7 +1393,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
@@ -1127,31 +1418,31 @@ point on its location in the *compilation* buffer."
:group 'compilation)
-(defun compilation-buffer-name (mode-name mode-command name-function)
+(defun compilation-buffer-name (name-of-mode mode-command name-function)
"Return the name of a compilation buffer to use.
-If NAME-FUNCTION is non-nil, call it with one argument MODE-NAME
+If NAME-FUNCTION is non-nil, call it with one argument NAME-OF-MODE
to determine the buffer name.
Likewise if `compilation-buffer-name-function' is non-nil.
If current buffer has the major mode MODE-COMMAND,
return the name of the current buffer, so that it gets reused.
-Otherwise, construct a buffer name from MODE-NAME."
+Otherwise, construct a buffer name from NAME-OF-MODE."
(cond (name-function
- (funcall name-function mode-name))
+ (funcall name-function name-of-mode))
(compilation-buffer-name-function
- (funcall compilation-buffer-name-function mode-name))
+ (funcall compilation-buffer-name-function name-of-mode))
((eq mode-command major-mode)
(buffer-name))
(t
- (concat "*" (downcase mode-name) "*"))))
+ (concat "*" (downcase name-of-mode) "*"))))
;; This is a rough emulation of the old hack, until the transition to new
;; compile is complete.
(defun compile-internal (command error-message
- &optional name-of-mode parser
+ &optional _name-of-mode parser
error-regexp-alist name-function
- enter-regexp-alist leave-regexp-alist
- file-regexp-alist nomessage-regexp-alist
- no-async highlight-regexp local-map)
+ _enter-regexp-alist _leave-regexp-alist
+ file-regexp-alist _nomessage-regexp-alist
+ _no-async highlight-regexp _local-map)
(if parser
(error "Compile now works very differently, see `compilation-error-regexp-alist'"))
(let ((compilation-error-regexp-alist
@@ -1185,7 +1476,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
@@ -1215,7 +1506,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))
"~")
@@ -1242,7 +1534,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
@@ -1338,9 +1631,11 @@ Returns the compilation buffer created."
;; Insert the output at the end, after the initial text,
;; regardless of where the user sees point.
(goto-char (point-max))
- (let* ((buffer-read-only nil) ; call-process needs to modify outbuf
+ (let* ((inhibit-read-only t) ; call-process needs to modify outbuf
+ (compilation-filter-start (point))
(status (call-process shell-file-name nil outbuf nil "-c"
command)))
+ (run-hooks 'compilation-filter-hook)
(cond ((numberp status)
(compilation-handle-exit
'exit status
@@ -1352,10 +1647,6 @@ Returns the compilation buffer created."
(concat status "\n")))
(t
(compilation-handle-exit 'bizarre status status)))))
- ;; Without async subprocesses, the buffer is not yet
- ;; fontified, so fontify it now.
- (let ((font-lock-verbose nil)) ; shut up font-lock messages
- (font-lock-fontify-buffer))
(set-buffer-modified-p nil)
(message "Executing `%s'...done" command)))
;; Now finally cd to where the shell started make/grep/...
@@ -1436,6 +1727,7 @@ Returns the compilation buffer created."
(defvar compilation-minor-mode-map
(let ((map (make-sparse-keymap)))
+ (set-keymap-parent map special-mode-map)
(define-key map [mouse-2] 'compile-goto-error)
(define-key map [follow-link] 'mouse-face)
(define-key map "\C-c\C-c" 'compile-goto-error)
@@ -1446,7 +1738,6 @@ Returns the compilation buffer created."
(define-key map "\M-{" 'compilation-previous-file)
(define-key map "\M-}" 'compilation-next-file)
(define-key map "g" 'recompile) ; revert
- (define-key map "q" 'quit-window)
;; Set up the menu-bar
(define-key map [menu-bar compilation]
(cons "Errors" compilation-menu-map))
@@ -1480,6 +1771,7 @@ Returns the compilation buffer created."
;; Don't inherit from compilation-minor-mode-map,
;; because that introduces a menu bar item we don't want.
;; That confuses C-down-mouse-3.
+ (set-keymap-parent map special-mode-map)
(define-key map [mouse-2] 'compile-goto-error)
(define-key map [follow-link] 'mouse-face)
(define-key map "\C-c\C-c" 'compile-goto-error)
@@ -1492,10 +1784,7 @@ Returns the compilation buffer created."
(define-key map "\t" 'compilation-next-error)
(define-key map [backtab] 'compilation-previous-error)
(define-key map "g" 'recompile) ; revert
- (define-key map "q" 'quit-window)
- (define-key map " " 'scroll-up)
- (define-key map "\^?" 'scroll-down)
(define-key map "\C-c\C-f" 'next-error-follow-minor-mode)
;; Set up the menu-bar
@@ -1521,9 +1810,11 @@ Returns the compilation buffer created."
(defvar compilation-mode-tool-bar-map
;; When bootstrapping, tool-bar-map is not properly initialized yet,
;; so don't do anything.
- (when (keymapp (butlast tool-bar-map))
- (let ((map (butlast (copy-keymap tool-bar-map)))
- (help (last tool-bar-map))) ;; Keep Help last in tool bar
+ (when (keymapp tool-bar-map)
+ (let ((map (copy-keymap tool-bar-map)))
+ (define-key map [undo] nil)
+ (define-key map [separator-2] nil)
+ (define-key-after map [separator-compile] menu-bar-separator)
(tool-bar-local-item
"left-arrow" 'previous-error-no-select 'previous-error-no-select map
:rtl "right-arrow"
@@ -1540,7 +1831,7 @@ Returns the compilation buffer created."
(tool-bar-local-item
"refresh" 'recompile 'recompile map
:help "Restart compilation")
- (append map help))))
+ map)))
(put 'compilation-mode 'mode-class 'special)
@@ -1560,10 +1851,11 @@ Runs `compilation-mode-hook' with `run-mode-hooks' (which see).
;; Let windows scroll along with the output.
(set (make-local-variable 'window-point-insertion-type) t)
(set (make-local-variable 'tool-bar-map) compilation-mode-tool-bar-map)
- (setq major-mode 'compilation-mode
+ (setq major-mode 'compilation-mode ; FIXME: Use define-derived-mode.
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))
@@ -1584,6 +1876,7 @@ by replacing the first word, e.g `compilation-scroll-output' from
(symbol-name v)))))
(and (cdr v)
(or (boundp (cdr v))
+ ;; FIXME: This is hackish, using undocumented info.
(if (boundp 'byte-compile-bound-variables)
(memq (cdr v) byte-compile-bound-variables)))
`(set (make-local-variable ',(car v)) ,(cdr v))))
@@ -1621,9 +1914,6 @@ The global commands next/previous/first-error/goto-error use this.")
"Buffer position of the beginning of the compilation messages.
If nil, use the beginning of buffer.")
-;; A function name can't be a hook, must be something with a value.
-(defconst compilation-turn-on-font-lock 'turn-on-font-lock)
-
(defun compilation-setup (&optional minor)
"Prepare the buffer for the compilation parsing commands to work.
Optional argument MINOR indicates this is called from
@@ -1642,26 +1932,29 @@ Optional argument MINOR indicates this is called from
(setq next-error-function 'compilation-next-error-function)
(set (make-local-variable 'comint-file-name-prefix)
(or (file-remote-p default-directory) ""))
- (set (make-local-variable 'font-lock-extra-managed-props)
- '(directory message help-echo mouse-face debug))
(set (make-local-variable 'compilation-locs)
(make-hash-table :test 'equal :weakness 'value))
- ;; lazy-lock would never find the message unless it's scrolled to.
- ;; jit-lock might fontify some things too late.
- (set (make-local-variable 'font-lock-support-mode) nil)
- (set (make-local-variable 'font-lock-maximum-size) nil)
+ ;; It's generally preferable to use after-change-functions since they
+ ;; can be subject to combine-after-change-calls, but if we do that, we risk
+ ;; running our hook after font-lock, resulting in incorrect refontification.
+ (add-hook 'before-change-functions 'compilation--flush-parse nil t)
+ ;; Also for minor mode, since it's not permanent-local.
+ (add-hook 'change-major-mode-hook #'compilation--remove-properties nil t)
(if minor
- (let ((fld font-lock-defaults))
+ (progn
(font-lock-add-keywords nil (compilation-mode-font-lock-keywords))
(if font-lock-mode
- (if fld
- (font-lock-fontify-buffer)
- (font-lock-change-mode)
- (turn-on-font-lock))
- (turn-on-font-lock)))
- (setq font-lock-defaults '(compilation-mode-font-lock-keywords t))
- ;; maybe defer font-lock till after derived mode is set up
- (run-mode-hooks 'compilation-turn-on-font-lock)))
+ (font-lock-fontify-buffer)))
+ (setq font-lock-defaults '(compilation-mode-font-lock-keywords t))))
+
+(defun compilation--unsetup ()
+ ;; Only for minor mode.
+ (font-lock-remove-keywords nil (compilation-mode-font-lock-keywords))
+ (remove-hook 'before-change-functions 'compilation--flush-parse t)
+ (kill-local-variable 'compilation--parsed)
+ (compilation--remove-properties)
+ (if font-lock-mode
+ (font-lock-fontify-buffer)))
;;;###autoload
(define-minor-mode compilation-shell-minor-mode
@@ -1675,8 +1968,7 @@ Turning the mode on runs the normal hook `compilation-shell-minor-mode-hook'."
:group 'compilation
(if compilation-shell-minor-mode
(compilation-setup t)
- (font-lock-remove-keywords nil (compilation-mode-font-lock-keywords))
- (font-lock-fontify-buffer)))
+ (compilation--unsetup)))
;;;###autoload
(define-minor-mode compilation-minor-mode
@@ -1689,8 +1981,7 @@ Turning the mode on runs the normal hook `compilation-minor-mode-hook'."
:group 'compilation
(if compilation-minor-mode
(compilation-setup t)
- (font-lock-remove-keywords nil (compilation-mode-font-lock-keywords))
- (font-lock-fontify-buffer)))
+ (compilation--unsetup)))
(defun compilation-handle-exit (process-status exit-status msg)
"Write MSG in the current buffer and hack its `mode-line-process'."
@@ -1718,7 +2009,8 @@ Turning the mode on runs the normal hook `compilation-minor-mode-hook'."
(setq mode-line-process
(let ((out-string (format ":%s [%s]" process-status (cdr status)))
(msg (format "%s %s" mode-name
- (replace-regexp-in-string "\n?$" "" (car status)))))
+ (replace-regexp-in-string "\n?$" ""
+ (car status)))))
(message "%s" msg)
(propertize out-string
'help-echo msg 'face (if (> exit-status 0)
@@ -1763,15 +2055,16 @@ and runs `compilation-filter-hook'."
(let ((inhibit-read-only t)
;; `save-excursion' doesn't use the right insertion-type for us.
(pos (copy-marker (point) t))
+ ;; `save-restriction' doesn't use the right insertion type either:
+ ;; If we are inserting at the end of the accessible part of the
+ ;; buffer, keep the inserted text visible.
(min (point-min-marker))
- (max (point-max-marker)))
+ (max (copy-marker (point-max) t))
+ (compilation-filter-start (marker-position (process-mark proc))))
(unwind-protect
(progn
- ;; If we are inserting at the end of the accessible part
- ;; of the buffer, keep the inserted text visible.
- (set-marker-insertion-type max t)
(widen)
- (goto-char (process-mark proc))
+ (goto-char compilation-filter-start)
;; We used to use `insert-before-markers', so that windows with
;; point at `process-mark' scroll along with the output, but we
;; now use window-point-insertion-type instead.
@@ -1779,9 +2072,12 @@ 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)
+ (set-marker pos nil)
(set-marker min nil)
(set-marker max nil))))))
@@ -1800,31 +2096,50 @@ and runs `compilation-filter-hook'."
`(let (opt)
(while (,< n 0)
(setq opt pt)
- (or (setq pt (,property-change pt 'message))
+ (or (setq pt (,property-change pt 'compilation-message))
;; Handle the case where where the first error message is
;; at the start of the buffer, and n < 0.
- (if (or (eq (get-text-property ,limit 'message)
- (get-text-property opt 'message))
+ (if (or (eq (get-text-property ,limit 'compilation-message)
+ (get-text-property opt 'compilation-message))
(eq pt opt))
(error ,error compilation-error)
(setq pt ,limit)))
- ;; prop 'message usually has 2 changes, on and off, so
+ ;; prop 'compilation-message usually has 2 changes, on and off, so
;; re-search if off
- (or (setq msg (get-text-property pt 'message))
- (if (setq pt (,property-change pt 'message nil ,limit))
- (setq msg (get-text-property pt 'message)))
+ (or (setq msg (get-text-property pt 'compilation-message))
+ (if (setq pt (,property-change pt 'compilation-message nil ,limit))
+ (setq msg (get-text-property pt 'compilation-message)))
(error ,error compilation-error))
- (or (< (cadr msg) compilation-skip-threshold)
+ (or (< (compilation--message->type msg) compilation-skip-threshold)
(if different-file
- (eq (prog1 last (setq last (nth 2 (car msg))))
+ (eq (prog1 last
+ (setq last (compilation--loc->file-struct
+ (compilation--message->loc msg))))
last))
(if compilation-skip-visited
- (nthcdr 5 (car msg)))
+ (compilation--loc->visited (compilation--message->loc msg)))
(if compilation-skip-to-next-location
- (eq (car msg) loc))
+ (eq (compilation--message->loc msg) loc))
;; count this message only if none of the above are true
(setq n (,1+ n))))))
+(defun compilation-next-single-property-change (position prop
+ &optional object limit)
+ (let (parsed res)
+ (while (progn
+ ;; We parse the buffer here "on-demand" by chunks of 500 chars.
+ ;; But we could also just parse the whole buffer.
+ (compilation--ensure-parse
+ (setq parsed (max compilation--parsed
+ (min (+ position 500)
+ (or limit (point-max))))))
+ (and (or (not (setq res (next-single-property-change
+ position prop object limit)))
+ (eq res limit))
+ (< position (or limit (point-max)))))
+ (setq position parsed))
+ res))
+
(defun compilation-next-error (n &optional different-file pt)
"Move point to the next error in the compilation buffer.
This function does NOT find the source line like \\[next-error].
@@ -1838,31 +2153,34 @@ looking for the next message."
(or (compilation-buffer-p (current-buffer))
(error "Not in a compilation buffer"))
(or pt (setq pt (point)))
- (let* ((msg (get-text-property pt 'message))
- ;; `loc' is used by the compilation-loop macro.
- (loc (car msg))
+ (let* ((msg (get-text-property pt 'compilation-message))
+ ;; `loc', `msg', and `last' are used by the compilation-loop macro.
+ (loc (and msg (compilation--message->loc msg)))
last)
(if (zerop n)
(unless (or msg ; find message near here
(setq msg (get-text-property (max (1- pt) (point-min))
- 'message)))
- (setq pt (previous-single-property-change pt 'message nil
+ 'compilation-message)))
+ (setq pt (previous-single-property-change pt 'compilation-message nil
(line-beginning-position)))
- (unless (setq msg (get-text-property (max (1- pt) (point-min)) 'message))
- (setq pt (next-single-property-change pt 'message nil
+ (unless (setq msg (get-text-property (max (1- pt) (point-min))
+ 'compilation-message))
+ (setq pt (next-single-property-change pt 'compilation-message nil
(line-end-position)))
- (or (setq msg (get-text-property pt 'message))
+ (or (setq msg (get-text-property pt 'compilation-message))
(setq pt (point)))))
- (setq last (nth 2 (car msg)))
+ (setq last (compilation--loc->file-struct loc))
(if (>= n 0)
- (compilation-loop > next-single-property-change 1-
+ (compilation-loop > compilation-next-single-property-change 1-
(if (get-buffer-process (current-buffer))
"No more %ss yet"
"Moved past last %s")
(point-max))
+ (compilation--ensure-parse pt)
;; Don't move "back" to message at or before point.
;; Pass an explicit (point-min) to make sure pt is non-nil.
- (setq pt (previous-single-property-change pt 'message nil (point-min)))
+ (setq pt (previous-single-property-change
+ pt 'compilation-message nil (point-min)))
(compilation-loop < previous-single-property-change 1+
"Moved back before first %s" (point-min))))
(goto-char pt)
@@ -1906,12 +2224,16 @@ Use this command in a compilation log buffer. Sets the mark at point there."
(if event (posn-set-point (event-end event)))
(or (compilation-buffer-p (current-buffer))
(error "Not in a compilation buffer"))
- (if (get-text-property (point) 'directory)
- (dired-other-window (car (get-text-property (point) 'directory)))
+ (compilation--ensure-parse (point))
+ (if (get-text-property (point) 'compilation-directory)
+ (dired-other-window
+ (car (get-text-property (point) 'compilation-directory)))
(push-mark)
(setq compilation-current-error (point))
(next-error-internal)))
+;; This is mostly unused, but we keep it for the sake of some external
+;; packages which seem to make use of it.
(defun compilation-find-buffer (&optional avoid-current)
"Return a compilation buffer.
If AVOID-CURRENT is nil, and the current buffer is a compilation buffer,
@@ -1929,59 +2251,66 @@ This is the value of `next-error-function' in Compilation buffers."
(when reset
(setq compilation-current-error nil))
(let* ((columns compilation-error-screen-columns) ; buffer's local value
- (last 1) timestamp
- (loc (compilation-next-error (or n 1) nil
+ (last 1)
+ (msg (compilation-next-error (or n 1) nil
(or compilation-current-error
compilation-messages-start
(point-min))))
- (end-loc (nth 2 loc))
+ (loc (compilation--message->loc msg))
+ (end-loc (compilation--message->end-loc msg))
(marker (point-marker)))
(setq compilation-current-error (point-marker)
overlay-arrow-position
(if (bolp)
compilation-current-error
- (copy-marker (line-beginning-position)))
- loc (car loc))
+ (copy-marker (line-beginning-position))))
;; If loc contains no marker, no error in that file has been visited.
;; If the marker is invalid the buffer has been killed.
- ;; If the file is newer than the timestamp, it has been modified
- ;; (`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))))))
- (with-current-buffer (compilation-find-file marker (caar (nth 2 loc))
- (cadr (car (nth 2 loc))))
+ (unless (and (compilation--loc->marker loc)
+ (marker-buffer (compilation--loc->marker loc))
+ ;; FIXME-omake: For "omake -P", which automatically recompiles
+ ;; when the file is modified, the line numbers of new output
+ ;; may not be related to line numbers from earlier output
+ ;; (earlier markers), so we used to try to detect it here and
+ ;; force a reparse. But that caused more problems elsewhere,
+ ;; so instead we now flush the file-structure when we see
+ ;; omake's message telling it's about to recompile a file.
+ ;; (or (null (compilation--loc->timestamp loc)) ;A fake-loc
+ ;; (equal (compilation--loc->timestamp loc)
+ ;; (setq timestamp compilation-buffer-modtime)))
+ )
+ (with-current-buffer
+ (compilation-find-file
+ marker
+ (caar (compilation--loc->file-struct loc))
+ (cadr (car (compilation--loc->file-struct loc))))
(save-restriction
(widen)
(goto-char (point-min))
;; Treat file's found lines in forward order, 1 by 1.
- (dolist (line (reverse (cddr (nth 2 loc))))
+ (dolist (line (reverse (cddr (compilation--loc->file-struct loc))))
(when (car line) ; else this is a filename w/o a line#
(beginning-of-line (- (car line) last -1))
(setq last (car line)))
;; Treat line's found columns and store/update a marker for each.
(dolist (col (cdr line))
- (if (car col)
- (if (eq (car col) -1) ; special case for range end
+ (if (compilation--loc->col col)
+ (if (eq (compilation--loc->col col) -1)
+ ;; Special case for range end.
(end-of-line)
- (compilation-move-to-column (car col) columns))
+ (compilation-move-to-column (compilation--loc->col col)
+ columns))
(beginning-of-line)
(skip-chars-forward " \t"))
- (if (nth 3 col)
- (set-marker (nth 3 col) (point))
- (setcdr (nthcdr 2 col) `(,(point-marker)))))))))
- (compilation-goto-locus marker (nth 3 loc) (nth 3 end-loc))
- (setcdr (nthcdr 3 loc) (list timestamp))
- (setcdr (nthcdr 4 loc) t))) ; Set this one as visited.
+ (if (compilation--loc->marker col)
+ (set-marker (compilation--loc->marker col) (point))
+ (setf (compilation--loc->marker col) (point-marker)))
+ ;; (setf (compilation--loc->timestamp col) timestamp)
+ )))))
+ (compilation-goto-locus marker (compilation--loc->marker loc)
+ (compilation--loc->marker end-loc))
+ (setf (compilation--loc->visited loc) t)))
(defvar compilation-gcpro nil
"Internal variable used to keep some values from being GC'd.")
@@ -1992,8 +2321,8 @@ This is the value of `next-error-function' in Compilation buffers."
FILE should be ABSOLUTE-FILENAME or (RELATIVE-FILENAME . DIRNAME).
This is useful when you compile temporary files, but want
automatic translation of the messages to the real buffer from
-which the temporary file came. This only works if done before a
-message about FILE appears!
+which the temporary file came. This may also affect previous messages
+about FILE.
Optional args LINE and COL default to 1 and beginning of
indentation respectively. The marker is expected to reflect
@@ -2005,18 +2334,19 @@ header with variable assignments and a code region), you must
call this several times, once each for the last line of one
region and the first line of the next region."
(or (consp file) (setq file (list file)))
- (setq file (compilation-get-file-structure file))
- ;; Between the current call to compilation-fake-loc and the first occurrence
- ;; of an error message referring to `file', the data is only kept in the
- ;; weak hash-table compilation-locs, so we need to prevent this entry
- ;; in compilation-locs from being GC'd away. --Stef
- (push file compilation-gcpro)
- (let ((loc (compilation-assq (or line 1) (cdr file))))
- (setq loc (compilation-assq col loc))
- (if (cdr loc)
- (setcdr (cddr loc) (list marker))
- (setcdr loc (list line file marker)))
- loc))
+ (compilation--flush-file-structure file)
+ (let ((fs (compilation-get-file-structure file)))
+ ;; Between the current call to compilation-fake-loc and the first
+ ;; occurrence of an error message referring to `file', the data is
+ ;; only kept in the weak hash-table compilation-locs, so we need
+ ;; to prevent this entry in compilation-locs from being GC'd
+ ;; away. --Stef
+ (push fs compilation-gcpro)
+ (let ((loc (compilation-assq (or line 1) (cdr fs))))
+ (setq loc (compilation-assq col loc))
+ (assert (null (cdr loc)))
+ (setcdr loc (compilation--make-cdrloc line fs marker))
+ loc)))
(defcustom compilation-context-lines nil
"Display this many lines of leading context before the current message.
@@ -2062,7 +2392,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
@@ -2234,7 +2564,7 @@ FILE should be (FILENAME) or (RELATIVE-FILENAME . DIRNAME).
In the former case, FILENAME may be relative or absolute.
The file-structure looks like this:
- (list (list FILENAME [DIR-FROM-PREV-MSG]) FMT LINE-STRUCT...)"
+ ((FILENAME [DIR-FROM-PREV-MSG]) FMT LINE-STRUCT...)"
(or (gethash file compilation-locs)
;; File was not previously encountered, at least not in the form passed.
;; Let's normalize it and look again.
@@ -2279,25 +2609,41 @@ The file-structure looks like this:
;; http://lists.gnu.org/archive/html/emacs-devel/2007-08/msg00463.html
(or (gethash (cons filename spec-directory) compilation-locs)
(puthash (cons filename spec-directory)
- (list (list filename spec-directory) fmt)
+ (compilation--make-file-struct
+ (list filename spec-directory) fmt)
compilation-locs))
compilation-locs))))
-(add-to-list 'debug-ignored-errors "^No more [-a-z ]+s yet$")
+(defun compilation--flush-file-structure (file)
+ (or (consp file) (setq file (list file)))
+ (let ((fs (compilation-get-file-structure file)))
+ (assert (eq fs (gethash file compilation-locs)))
+ (assert (eq fs (gethash (cons (caar fs) (cadr (car fs)))
+ compilation-locs)))
+ (maphash (lambda (k v)
+ (if (eq v fs) (remhash k compilation-locs)))
+ compilation-locs)))
+
+(add-to-list 'debug-ignored-errors "\\`No more [-a-z ]+s yet\\'")
+(add-to-list 'debug-ignored-errors "\\`Moved past last .*")
;;; Compatibility with the old compile.el.
-(defun compile-buffer-substring (n) (if n (match-string n)))
+(defvaralias 'compilation-last-buffer 'next-error-last-buffer)
+(defvar compilation-parsing-end (make-marker))
+(defvar compilation-error-list nil)
+(defvar compilation-old-error-list nil)
-(defun compilation-compat-error-properties (err)
+(defun compilation--compat-error-properties (err)
"Map old-style error ERR to new-style message."
;; Old-style structure is (MARKER (FILE DIR) LINE COL) or
;; (MARKER . MARKER).
(let ((dst (cdr err)))
(if (markerp dst)
- ;; Must start with a face, for font-lock.
- `(face nil
- message ,(list (list nil nil nil dst) 2)
+ `(compilation-message ,(compilation--make-message
+ (cons nil (compilation--make-cdrloc
+ nil nil dst))
+ 2 nil)
help-echo "mouse-2: visit the source location"
keymap compilation-button-map
mouse-face highlight)
@@ -2311,19 +2657,19 @@ The file-structure looks like this:
(compilation-internal-error-properties
(cons filename dirname) line nil col nil 2 fmt)))))
-(defun compilation-compat-parse-errors (limit)
+(defun compilation--compat-parse-errors (limit)
(when compilation-parse-errors-function
;; FIXME: We should remove the rest of the compilation keywords
;; but we can't do that from here because font-lock is using
- ;; the value right now. --stef
+ ;; the value right now. --Stef
(save-excursion
(setq compilation-error-list nil)
;; Reset compilation-parsing-end each time because font-lock
;; might force us the re-parse many times (typically because
;; some code adds some text-property to the output that we
;; already parsed). You might say "why reparse", well:
- ;; because font-lock has just removed the `message' property so
- ;; have to do it all over again.
+ ;; because font-lock has just removed the `compilation-message' property
+ ;; so have to do it all over again.
(if compilation-parsing-end
(set-marker compilation-parsing-end (point))
(setq compilation-parsing-end (point-marker)))
@@ -2335,23 +2681,30 @@ The file-structure looks like this:
(dolist (err (if (listp compilation-error-list) compilation-error-list))
(let* ((src (car err))
(dst (cdr err))
- (loc (cond ((markerp dst) (list nil nil nil dst))
+ (loc (cond ((markerp dst)
+ (cons nil
+ (compilation--make-cdrloc nil nil dst)))
((consp dst)
- (list (nth 2 dst) (nth 1 dst)
- (cons (cdar dst) (caar dst)))))))
+ (cons (nth 2 dst)
+ (compilation--make-cdrloc
+ (nth 1 dst)
+ (cons (cdar dst) (caar dst))
+ nil))))))
(when loc
(goto-char src)
- ;; (put-text-property src (line-end-position) 'font-lock-face 'font-lock-warning-face)
+ ;; (put-text-property src (line-end-position)
+ ;; 'font-lock-face 'font-lock-warning-face)
(put-text-property src (line-end-position)
- 'message (list loc 2)))))))
+ 'compilation-message
+ (compilation--make-message loc 2 nil)))))))
(goto-char limit)
nil)
-;; Beware: this is not only compatibility code. New code stil uses it. --Stef
+;; Beware! this is not only compatibility code. New code also uses it. --Stef
(defun compilation-forget-errors ()
;; In case we hit the same file/line specs, we want to recompute a new
;; marker for them, so flush our cache.
- (setq compilation-locs (make-hash-table :test 'equal :weakness 'value))
+ (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
@@ -2382,9 +2735,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)
;;; compile.el ends here
diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el
index 3910ae0c166..f6d497569ba 100644
--- a/lisp/progmodes/cperl-mode.el
+++ b/lisp/progmodes/cperl-mode.el
@@ -1,8 +1,6 @@
;;; 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, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1985-1987, 1991-2011 Free Software Foundation, Inc.
;; Author: Ilya Zakharevich
;; Bob Olson
@@ -1802,13 +1800,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 +1837,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 +2143,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 +2180,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 +2213,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 +2356,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 +2395,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 +2474,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 +2940,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 +2982,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 +3212,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 +3801,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 +4046,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 +4992,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 +5035,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 +5050,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 +5203,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 +7037,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 +7465,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 +8971,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/cpp.el b/lisp/progmodes/cpp.el
index 5cff3b36c73..a8f01705e2d 100644
--- a/lisp/progmodes/cpp.el
+++ b/lisp/progmodes/cpp.el
@@ -1,7 +1,6 @@
;;; cpp.el --- highlight or hide text according to cpp conditionals
-;; Copyright (C) 1994, 1995, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation
+;; Copyright (C) 1994-1995, 2001-2011 Free Software Foundation, Inc.
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: c, faces, tools
@@ -309,7 +308,6 @@ A prefix arg suppresses display of that buffer."
;; Pop top of cpp-state-stack and create overlay.
(let ((entry (assoc (nth 1 (car cpp-state-stack)) cpp-edit-list))
(branch (nth 0 (car cpp-state-stack)))
- (begin (nth 2 (car cpp-state-stack)))
(end (nth 3 (car cpp-state-stack))))
(setq cpp-state-stack (cdr cpp-state-stack))
(if entry
@@ -399,7 +397,7 @@ A prefix arg suppresses display of that buffer."
(overlay-put overlay 'insert-in-front-hooks '(cpp-grow-overlay))
(overlay-put overlay 'insert-behind-hooks '(cpp-grow-overlay)))
-(defun cpp-signal-read-only (overlay after start end &optional len)
+(defun cpp-signal-read-only (overlay after start end &optional _len)
;; Only allow deleting the whole overlay.
;; Trying to change a read-only overlay.
(if (and (not after)
@@ -407,7 +405,7 @@ A prefix arg suppresses display of that buffer."
(> (overlay-end overlay) end)))
(error "This text is read only")))
-(defun cpp-grow-overlay (overlay after start end &optional len)
+(defun cpp-grow-overlay (overlay after start end &optional _len)
;; Make OVERLAY grow to contain range START to END.
(if after
(move-overlay overlay
@@ -416,63 +414,59 @@ A prefix arg suppresses display of that buffer."
;;; Edit Buffer:
-(defvar cpp-edit-map nil)
-;; Keymap for `cpp-edit-mode'.
-
-(if cpp-edit-map
- ()
- (setq cpp-edit-map (make-keymap))
- (suppress-keymap cpp-edit-map)
- (define-key cpp-edit-map [ down-mouse-2 ] 'cpp-push-button)
- (define-key cpp-edit-map [ mouse-2 ] 'ignore)
- (define-key cpp-edit-map " " 'scroll-up)
- (define-key cpp-edit-map "\C-?" 'scroll-down)
- (define-key cpp-edit-map [ delete ] 'scroll-down)
- (define-key cpp-edit-map "\C-c\C-c" 'cpp-edit-apply)
- (define-key cpp-edit-map "a" 'cpp-edit-apply)
- (define-key cpp-edit-map "A" 'cpp-edit-apply)
- (define-key cpp-edit-map "r" 'cpp-edit-reset)
- (define-key cpp-edit-map "R" 'cpp-edit-reset)
- (define-key cpp-edit-map "s" 'cpp-edit-save)
- (define-key cpp-edit-map "S" 'cpp-edit-save)
- (define-key cpp-edit-map "l" 'cpp-edit-load)
- (define-key cpp-edit-map "L" 'cpp-edit-load)
- (define-key cpp-edit-map "h" 'cpp-edit-home)
- (define-key cpp-edit-map "H" 'cpp-edit-home)
- (define-key cpp-edit-map "b" 'cpp-edit-background)
- (define-key cpp-edit-map "B" 'cpp-edit-background)
- (define-key cpp-edit-map "k" 'cpp-edit-known)
- (define-key cpp-edit-map "K" 'cpp-edit-known)
- (define-key cpp-edit-map "u" 'cpp-edit-unknown)
- (define-key cpp-edit-map "u" 'cpp-edit-unknown)
- (define-key cpp-edit-map "t" 'cpp-edit-true)
- (define-key cpp-edit-map "T" 'cpp-edit-true)
- (define-key cpp-edit-map "f" 'cpp-edit-false)
- (define-key cpp-edit-map "F" 'cpp-edit-false)
- (define-key cpp-edit-map "w" 'cpp-edit-write)
- (define-key cpp-edit-map "W" 'cpp-edit-write)
- (define-key cpp-edit-map "X" 'cpp-edit-toggle-known)
- (define-key cpp-edit-map "x" 'cpp-edit-toggle-known)
- (define-key cpp-edit-map "Y" 'cpp-edit-toggle-unknown)
- (define-key cpp-edit-map "y" 'cpp-edit-toggle-unknown)
- (define-key cpp-edit-map "q" 'bury-buffer)
- (define-key cpp-edit-map "Q" 'bury-buffer))
+(defvar cpp-edit-mode-map
+ (let ((map (make-keymap)))
+ (suppress-keymap map)
+ (define-key map [ down-mouse-2 ] 'cpp-push-button)
+ (define-key map [ mouse-2 ] 'ignore)
+ (define-key map " " 'scroll-up)
+ (define-key map "\C-?" 'scroll-down)
+ (define-key map [ delete ] 'scroll-down)
+ (define-key map "\C-c\C-c" 'cpp-edit-apply)
+ (define-key map "a" 'cpp-edit-apply)
+ (define-key map "A" 'cpp-edit-apply)
+ (define-key map "r" 'cpp-edit-reset)
+ (define-key map "R" 'cpp-edit-reset)
+ (define-key map "s" 'cpp-edit-save)
+ (define-key map "S" 'cpp-edit-save)
+ (define-key map "l" 'cpp-edit-load)
+ (define-key map "L" 'cpp-edit-load)
+ (define-key map "h" 'cpp-edit-home)
+ (define-key map "H" 'cpp-edit-home)
+ (define-key map "b" 'cpp-edit-background)
+ (define-key map "B" 'cpp-edit-background)
+ (define-key map "k" 'cpp-edit-known)
+ (define-key map "K" 'cpp-edit-known)
+ (define-key map "u" 'cpp-edit-unknown)
+ (define-key map "u" 'cpp-edit-unknown)
+ (define-key map "t" 'cpp-edit-true)
+ (define-key map "T" 'cpp-edit-true)
+ (define-key map "f" 'cpp-edit-false)
+ (define-key map "F" 'cpp-edit-false)
+ (define-key map "w" 'cpp-edit-write)
+ (define-key map "W" 'cpp-edit-write)
+ (define-key map "X" 'cpp-edit-toggle-known)
+ (define-key map "x" 'cpp-edit-toggle-known)
+ (define-key map "Y" 'cpp-edit-toggle-unknown)
+ (define-key map "y" 'cpp-edit-toggle-unknown)
+ (define-key map "q" 'bury-buffer)
+ (define-key map "Q" 'bury-buffer)
+ map)
+ "Keymap for `cpp-edit-mode'.")
+
+
(defvar cpp-edit-symbols nil)
;; Symbols defined in the edit buffer.
(make-variable-buffer-local 'cpp-edit-symbols)
-(defun cpp-edit-mode ()
+(define-derived-mode cpp-edit-mode fundamental-mode "CPP Edit"
"Major mode for editing the criteria for highlighting cpp conditionals.
Click on objects to change them.
You can also use the keyboard accelerators indicated like this: [K]ey."
- (kill-all-local-variables)
(buffer-disable-undo)
(auto-save-mode -1)
- (setq buffer-read-only t)
- (setq major-mode 'cpp-edit-mode)
- (setq mode-name "CPP Edit")
- (use-local-map cpp-edit-map))
+ (setq buffer-read-only t))
(defun cpp-edit-apply ()
"Apply edited display information to original buffer."
@@ -568,7 +562,7 @@ You can also use the keyboard accelerators indicated like this: [K]ey."
(load-file cpp-config-file))
((file-readable-p (concat "~/" cpp-config-file))
(load-file cpp-config-file)))
- (if (eq major-mode 'cpp-edit-mode)
+ (if (derived-mode-p 'cpp-edit-mode)
(cpp-edit-reset)))
(defun cpp-edit-save ()
@@ -830,5 +824,4 @@ BRANCH should be either nil (false branch), t (true branch) or 'both."
(provide 'cpp)
-;; arch-tag: fb7d433d-745d-495a-96f0-86908ab63f74
;;; cpp.el ends here
diff --git a/lisp/progmodes/cwarn.el b/lisp/progmodes/cwarn.el
index 64b204891ed..211c856f9b7 100644
--- a/lisp/progmodes/cwarn.el
+++ b/lisp/progmodes/cwarn.el
@@ -1,12 +1,11 @@
;;; cwarn.el --- highlight suspicious C and C++ constructions
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; 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.
@@ -381,5 +380,4 @@ The mode is turned if some feature is enabled for the current
;;}}}
-;; arch-tag: 225fb5e2-0838-4eb1-88ce-3811c5e4d738
;;; cwarn.el ends here
diff --git a/lisp/progmodes/dcl-mode.el b/lisp/progmodes/dcl-mode.el
index ac9c8680eab..b4094914d61 100644
--- a/lisp/progmodes/dcl-mode.el
+++ b/lisp/progmodes/dcl-mode.el
@@ -1,7 +1,6 @@
;;; dcl-mode.el --- major mode for editing DCL command files
-;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Odd Gripenstam <gripenstamol@decus.se>
;; Maintainer: Odd Gripenstam <gripenstamol@decus.se>
@@ -296,72 +295,69 @@ See `imenu-generic-expression' for details."
)
-(defvar dcl-mode-map ()
+(defvar dcl-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\e\n" 'dcl-split-line)
+ (define-key map "\e\t" 'tempo-complete-tag)
+ (define-key map "\e^" 'dcl-delete-indentation)
+ (define-key map "\em" 'dcl-back-to-indentation)
+ (define-key map "\ee" 'dcl-forward-command)
+ (define-key map "\ea" 'dcl-backward-command)
+ (define-key map "\e\C-q" 'dcl-indent-command)
+ (define-key map "\t" 'dcl-tab)
+ (define-key map ":" 'dcl-electric-character)
+ (define-key map "F" 'dcl-electric-character)
+ (define-key map "f" 'dcl-electric-character)
+ (define-key map "E" 'dcl-electric-character)
+ (define-key map "e" 'dcl-electric-character)
+ (define-key map "\C-c\C-o" 'dcl-set-option)
+ (define-key map "\C-c\C-f" 'tempo-forward-mark)
+ (define-key map "\C-c\C-b" 'tempo-backward-mark)
+
+ (define-key map [menu-bar] (make-sparse-keymap))
+ (define-key map [menu-bar dcl]
+ (cons "DCL" (make-sparse-keymap "DCL")))
+
+ ;; Define these in bottom-up order
+ (define-key map [menu-bar dcl tempo-backward-mark]
+ '("Previous template mark" . tempo-backward-mark))
+ (define-key map [menu-bar dcl tempo-forward-mark]
+ '("Next template mark" . tempo-forward-mark))
+ (define-key map [menu-bar dcl tempo-complete-tag]
+ '("Complete template tag" . tempo-complete-tag))
+ (define-key map [menu-bar dcl dcl-separator-tempo]
+ '("--"))
+ (define-key map [menu-bar dcl dcl-save-all-options]
+ '("Save all options" . dcl-save-all-options))
+ (define-key map [menu-bar dcl dcl-save-nondefault-options]
+ '("Save changed options" . dcl-save-nondefault-options))
+ (define-key map [menu-bar dcl dcl-set-option]
+ '("Set option" . dcl-set-option))
+ (define-key map [menu-bar dcl dcl-separator-option]
+ '("--"))
+ (define-key map [menu-bar dcl dcl-delete-indentation]
+ '("Delete indentation" . dcl-delete-indentation))
+ (define-key map [menu-bar dcl dcl-split-line]
+ '("Split line" . dcl-split-line))
+ (define-key map [menu-bar dcl dcl-indent-command]
+ '("Indent command" . dcl-indent-command))
+ (define-key map [menu-bar dcl dcl-tab]
+ '("Indent line/insert tab" . dcl-tab))
+ (define-key map [menu-bar dcl dcl-back-to-indentation]
+ '("Back to indentation" . dcl-back-to-indentation))
+ (define-key map [menu-bar dcl dcl-forward-command]
+ '("End of statement" . dcl-forward-command))
+ (define-key map [menu-bar dcl dcl-backward-command]
+ '("Beginning of statement" . dcl-backward-command))
+ ;; imenu is only supported for versions with imenu-generic-expression
+ (if (boundp 'imenu-generic-expression)
+ (progn
+ (define-key map [menu-bar dcl dcl-separator-movement]
+ '("--"))
+ (define-key map [menu-bar dcl imenu]
+ '("Buffer index menu" . imenu))))
+ map)
"Keymap used in DCL-mode buffers.")
-(if dcl-mode-map
- ()
- (setq dcl-mode-map (make-sparse-keymap))
- (define-key dcl-mode-map "\e\n" 'dcl-split-line)
- (define-key dcl-mode-map "\e\t" 'tempo-complete-tag)
- (define-key dcl-mode-map "\e^" 'dcl-delete-indentation)
- (define-key dcl-mode-map "\em" 'dcl-back-to-indentation)
- (define-key dcl-mode-map "\ee" 'dcl-forward-command)
- (define-key dcl-mode-map "\ea" 'dcl-backward-command)
- (define-key dcl-mode-map "\e\C-q" 'dcl-indent-command)
- (define-key dcl-mode-map "\t" 'dcl-tab)
- (define-key dcl-mode-map ":" 'dcl-electric-character)
- (define-key dcl-mode-map "F" 'dcl-electric-character)
- (define-key dcl-mode-map "f" 'dcl-electric-character)
- (define-key dcl-mode-map "E" 'dcl-electric-character)
- (define-key dcl-mode-map "e" 'dcl-electric-character)
- (define-key dcl-mode-map "\C-c\C-o" 'dcl-set-option)
- (define-key dcl-mode-map "\C-c\C-f" 'tempo-forward-mark)
- (define-key dcl-mode-map "\C-c\C-b" 'tempo-backward-mark)
-
- (define-key dcl-mode-map [menu-bar] (make-sparse-keymap))
- (define-key dcl-mode-map [menu-bar dcl]
- (cons "DCL" (make-sparse-keymap "DCL")))
-
- ;; Define these in bottom-up order
- (define-key dcl-mode-map [menu-bar dcl tempo-backward-mark]
- '("Previous template mark" . tempo-backward-mark))
- (define-key dcl-mode-map [menu-bar dcl tempo-forward-mark]
- '("Next template mark" . tempo-forward-mark))
- (define-key dcl-mode-map [menu-bar dcl tempo-complete-tag]
- '("Complete template tag" . tempo-complete-tag))
- (define-key dcl-mode-map [menu-bar dcl dcl-separator-tempo]
- '("--"))
- (define-key dcl-mode-map [menu-bar dcl dcl-save-all-options]
- '("Save all options" . dcl-save-all-options))
- (define-key dcl-mode-map [menu-bar dcl dcl-save-nondefault-options]
- '("Save changed options" . dcl-save-nondefault-options))
- (define-key dcl-mode-map [menu-bar dcl dcl-set-option]
- '("Set option" . dcl-set-option))
- (define-key dcl-mode-map [menu-bar dcl dcl-separator-option]
- '("--"))
- (define-key dcl-mode-map [menu-bar dcl dcl-delete-indentation]
- '("Delete indentation" . dcl-delete-indentation))
- (define-key dcl-mode-map [menu-bar dcl dcl-split-line]
- '("Split line" . dcl-split-line))
- (define-key dcl-mode-map [menu-bar dcl dcl-indent-command]
- '("Indent command" . dcl-indent-command))
- (define-key dcl-mode-map [menu-bar dcl dcl-tab]
- '("Indent line/insert tab" . dcl-tab))
- (define-key dcl-mode-map [menu-bar dcl dcl-back-to-indentation]
- '("Back to indentation" . dcl-back-to-indentation))
- (define-key dcl-mode-map [menu-bar dcl dcl-forward-command]
- '("End of statement" . dcl-forward-command))
- (define-key dcl-mode-map [menu-bar dcl dcl-backward-command]
- '("Beginning of statement" . dcl-backward-command))
- ;; imenu is only supported for versions with imenu-generic-expression
- (if (boundp 'imenu-generic-expression)
- (progn
- (define-key dcl-mode-map [menu-bar dcl dcl-separator-movement]
- '("--"))
- (define-key dcl-mode-map [menu-bar dcl imenu]
- '("Buffer index menu" . imenu))))
- )
-
(defcustom dcl-ws-r
"\\([ \t]*-[ \t]*\\(!.*\\)*\n\\)*[ \t]*"
@@ -475,7 +471,7 @@ Preloaded with all known option names from dcl-option-alist")
;;;###autoload
-(defun dcl-mode ()
+(define-derived-mode dcl-mode prog-mode "DCL"
"Major mode for editing DCL-files.
This mode indents command lines in blocks. (A block is commands between
@@ -593,29 +589,17 @@ $
There is some minimal font-lock support (see vars
`dcl-font-lock-defaults' and `dcl-font-lock-keywords')."
- (interactive)
- (kill-all-local-variables)
- (set-syntax-table dcl-mode-syntax-table)
-
- (make-local-variable 'indent-line-function)
- (setq indent-line-function 'dcl-indent-line)
-
- (make-local-variable 'comment-start)
- (setq comment-start "!")
-
- (make-local-variable 'comment-end)
- (setq comment-end "")
-
- (make-local-variable 'comment-multi-line)
- (setq comment-multi-line nil)
+ (set (make-local-variable 'indent-line-function) 'dcl-indent-line)
+ (set (make-local-variable 'comment-start) "!")
+ (set (make-local-variable 'comment-end) "")
+ (set (make-local-variable 'comment-multi-line) nil)
;; This used to be "^\\$[ \t]*![ \t]*" which looks more correct.
;; The drawback was that you couldn't make empty comment lines by pressing
;; C-M-j repeatedly - only the first line became a comment line.
;; This version has the drawback that the "$" can be anywhere in the line,
;; and something inappropriate might be interpreted as a comment.
- (make-local-variable 'comment-start-skip)
- (setq comment-start-skip "\\$[ \t]*![ \t]*")
+ (set (make-local-variable 'comment-start-skip) "\\$[ \t]*![ \t]*")
(if (boundp 'imenu-generic-expression)
(progn (setq imenu-generic-expression dcl-imenu-generic-expression)
@@ -636,14 +620,9 @@ There is some minimal font-lock support (see vars
(make-local-variable 'dcl-electric-reindent-regexps)
;; font lock
- (make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults dcl-font-lock-defaults)
+ (set (make-local-variable 'font-lock-defaults) dcl-font-lock-defaults)
- (setq major-mode 'dcl-mode)
- (setq mode-name "DCL")
- (use-local-map dcl-mode-map)
- (tempo-use-tag-list 'dcl-tempo-tags)
- (run-mode-hooks 'dcl-mode-hook))
+ (tempo-use-tag-list 'dcl-tempo-tags))
;;; *** Movement commands ***************************************************
@@ -683,8 +662,7 @@ There is some minimal font-lock support (see vars
(defun dcl-end-of-command ()
"Move point to end of current command or next command if not on a command."
(interactive)
- (let ((type (dcl-get-line-type))
- (start (point)))
+ (let ((type (dcl-get-line-type)))
(if (or (eq type '$)
(eq type '-))
(progn
@@ -821,7 +799,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)))
@@ -962,7 +940,7 @@ Returns one of the following symbols:
;;;---------------------------------------------------------------------------
(defun dcl-calc-command-indent-multiple
- (indent-type cur-indent extra-indent last-point this-point)
+ (indent-type cur-indent extra-indent _last-point _this-point)
"Indent lines to a multiple of dcl-basic-offset.
Set dcl-calc-command-indent-function to this function to customize
@@ -1206,7 +1184,7 @@ The indent-type classification could probably be expanded upon.
;;;---------------------------------------------------------------------------
-(defun dcl-calc-cont-indent-relative (cur-indent extra-indent)
+(defun dcl-calc-cont-indent-relative (_cur-indent _extra-indent)
"Indent continuation lines to align with words on previous line.
Indent continuation lines to a position relative to preceding
@@ -1549,13 +1527,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)))))
@@ -1563,7 +1539,7 @@ Also remove the continuation mark if easily detected."
;;;-------------------------------------------------------------------------
-(defun dcl-option-value-basic (option-assoc)
+(defun dcl-option-value-basic (_option-assoc)
"Guess a value for basic-offset."
(save-excursion
(dcl-beginning-of-command)
@@ -1598,7 +1574,7 @@ Also remove the continuation mark if easily detected."
;;;-------------------------------------------------------------------------
-(defun dcl-option-value-offset (option-assoc)
+(defun dcl-option-value-offset (_option-assoc)
"Guess a value for an offset.
Find the column of the first non-blank character on the line.
Returns the column offset."
@@ -1609,7 +1585,7 @@ Returns the column offset."
;;;-------------------------------------------------------------------------
-(defun dcl-option-value-margin-offset (option-assoc)
+(defun dcl-option-value-margin-offset (_option-assoc)
"Guess a value for margin offset.
Find the column of the first non-blank character on the line, not
counting labels.
@@ -1621,7 +1597,7 @@ Returns a number as a string."
;;;-------------------------------------------------------------------------
-(defun dcl-option-value-comment-line (option-assoc)
+(defun dcl-option-value-comment-line (_option-assoc)
"Guess a value for `dcl-comment-line-regexp'.
Must return a string."
;; Should we set comment-start and comment-start-skip as well?
@@ -1785,7 +1761,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
@@ -1812,8 +1788,7 @@ Set or update the value of VAR in the current buffers
(if (eolp) (error "Missing colon in local variables entry"))
(skip-chars-backward " \t")
(let* ((str (buffer-substring beg (point)))
- (found-var (read str))
- val)
+ (found-var (read str)))
;; Setting variable named "end" means end of list.
(if (string-equal (downcase str) "end")
(progn
@@ -1918,6 +1893,10 @@ section at the end of the current buffer."
;;;-------------------------------------------------------------------------
+(with-no-warnings
+ ;; Dynamically bound in `dcl-save-mode'.
+ (defvar mode))
+
(defun dcl-save-mode ()
"Save the current mode for this buffer.
Save the current mode in a `Local Variables:'
@@ -1925,7 +1904,7 @@ section at the end of the current buffer."
(interactive)
(let ((mode (prin1-to-string major-mode)))
(if (string-match "-mode$" mode)
- (let ((mode (intern (substring mode 0 (match-beginning 0)))))
+ (let ((mode (intern (substring mode 0 (match-beginning 0)))))
(dcl-save-option 'mode))
(message "Strange mode: %s" mode))))
@@ -2216,5 +2195,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 30cd15a91df..c809079381f 100644
--- a/lisp/progmodes/delphi.el
+++ b/lisp/progmodes/delphi.el
@@ -1,7 +1,6 @@
;;; delphi.el --- major mode for editing Delphi source (Object Pascal) in Emacs
-;; Copyright (C) 1998, 1999, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-1999, 2001-2011 Free Software Foundation, Inc.
;; Authors: Ray Blaak <blaak@infomatch.com>,
;; Simon South <ssouth@member.fsf.org>
@@ -27,14 +26,14 @@
;; To enter Delphi mode when you find a Delphi source file, one must override
;; the auto-mode-alist to associate Delphi with .pas (and .dpr and .dpk)
-;; files. Emacs, by default, will otherwise enter Pascal mode. E.g.
+;; files. Emacs, by default, will otherwise enter Pascal mode. E.g.
;;
;; (autoload 'delphi-mode "delphi")
;; (setq auto-mode-alist
;; (cons '("\\.\\(pas\\|dpr\\|dpk\\)$" . delphi-mode) auto-mode-alist))
;; To get keyword, comment, and string literal coloring, be sure that font-lock
-;; is running. One can manually do M-x font-lock-mode in a Delphi buffer, or
+;; is running. One can manually do M-x font-lock-mode in a Delphi buffer, or
;; one can put in .emacs:
;;
;; (add-hook 'delphi-mode-hook 'turn-on-font-lock)
@@ -57,8 +56,8 @@
;; When you have entered Delphi mode, you may get more info by pressing
;; C-h m.
-;; This delphi mode implementation is fairly tolerant of syntax errors, relying
-;; as much as possible on the indentation of the previous statement. This also
+;; This Delphi mode implementation is fairly tolerant of syntax errors, relying
+;; as much as possible on the indentation of the previous statement. This also
;; makes it faster and simpler, since there is less searching for properly
;; constructed beginnings.
@@ -75,15 +74,16 @@
"True if in debug mode.")
(defcustom delphi-search-path "."
- "*Directories to search when finding external units. It is a list of
-directory strings. If only a single directory, it can be a single
-string instead of a list. If a directory ends in \"...\" then that
-directory is recursively searched."
+ "*Directories to search when finding external units.
+It is a list of directory strings. If only a single directory,
+it can be a single string instead of a list. If a directory
+ends in \"...\" then that directory is recursively searched."
:type 'string
:group 'delphi)
(defcustom delphi-indent-level 3
- "*Indentation of Delphi statements with respect to containing block. E.g.
+ "*Indentation of Delphi statements with respect to containing block.
+E.g.
begin
// This is an indent of 3.
@@ -118,7 +118,7 @@ end; end;"
:group 'delphi)
(defcustom delphi-verbose t ; nil
- "*If true then delphi token processing progress is reported to the user."
+ "*If true then Delphi token processing progress is reported to the user."
:type 'boolean
:group 'delphi)
@@ -138,17 +138,17 @@ differs from the default."
:group 'delphi)
(defcustom delphi-comment-face 'font-lock-comment-face
- "*Face used to color delphi comments."
+ "*Face used to color Delphi comments."
:type 'face
:group 'delphi)
(defcustom delphi-string-face 'font-lock-string-face
- "*Face used to color delphi strings."
+ "*Face used to color Delphi strings."
:type 'face
:group 'delphi)
(defcustom delphi-keyword-face 'font-lock-keyword-face
- "*Face used to color delphi keywords."
+ "*Face used to color Delphi keywords."
:type 'face
:group 'delphi)
@@ -328,7 +328,7 @@ routine.")
(after-change-functions nil)
(modified (buffer-modified-p)))
;; Disable any queries about editing obsolete files.
- (fset 'ask-user-about-supersession-threat (lambda (fn)))
+ (fset 'ask-user-about-supersession-threat (lambda (_fn)))
(unwind-protect
(progn ,@forms)
(set-buffer-modified-p modified)
@@ -444,6 +444,12 @@ routine.")
(goto-char curr-point)
next))
+(defvar delphi-ignore-changes t
+ "Internal flag to control if the Delphi mode responds to buffer changes.
+Defaults to t in case the `delphi-after-change' function is called on a
+non-Delphi buffer. Set to nil in a Delphi buffer. To override, just do:
+ (let ((delphi-ignore-changes t)) ...)")
+
(defun delphi-set-text-properties (from to properties)
;; Like `set-text-properties', except we do not consider this to be a buffer
;; modification.
@@ -590,7 +596,6 @@ routine.")
;; character set.
(let ((currp (point))
(end nil)
- (start nil)
(token nil))
(goto-char p)
(when (> (skip-chars-forward charset) 0)
@@ -628,7 +633,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 +645,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))
@@ -719,13 +725,7 @@ routine.")
(delphi-step-progress p "Fontifying" delphi-fontifying-progress-step))
(delphi-progress-done)))))
-(defvar delphi-ignore-changes t
- "Internal flag to control if the delphi-mode responds to buffer changes.
-Defaults to t in case the delphi-after-change function is called on a
-non-delphi buffer. Set to nil in a delphi buffer. To override, just do:
- (let ((delphi-ignore-changes t)) ...)")
-
-(defun delphi-after-change (change-start change-end old-length)
+(defun delphi-after-change (change-start change-end _old-length)
;; Called when the buffer has changed. Reparses the changed region.
(unless delphi-ignore-changes
(let ((delphi-ignore-changes t)) ; Prevent recursive calls.
@@ -888,7 +888,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)
@@ -904,8 +921,7 @@ non-delphi buffer. Set to nil in a delphi buffer. To override, just do:
;; Returns the token of the if or case statement.
(let ((token (delphi-previous-token from-else))
(token-kind nil)
- (semicolon-count 0)
- (if-count 0))
+ (semicolon-count 0))
(catch 'done
(while token
(setq token-kind (delphi-token-kind token))
@@ -953,8 +969,7 @@ non-delphi buffer. Set to nil in a delphi buffer. To override, just do:
comment
;; Scan until we run out of // comments.
(let ((prev-comment comment)
- (start-comment comment)
- (kind nil))
+ (start-comment comment))
(while (let ((kind (delphi-token-kind prev-comment)))
(cond ((eq kind 'space))
((eq kind 'comment-single-line)
@@ -971,8 +986,7 @@ non-delphi buffer. Set to nil in a delphi buffer. To override, just do:
comment
;; Scan until we run out of // comments.
(let ((next-comment comment)
- (end-comment comment)
- (kind nil))
+ (end-comment comment))
(while (let ((kind (delphi-token-kind next-comment)))
(cond ((eq kind 'space))
((eq kind 'comment-single-line)
@@ -1058,6 +1072,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 +1116,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.
@@ -1495,12 +1518,11 @@ non-delphi buffer. Set to nil in a delphi buffer. To override, just do:
indent)))
(defun delphi-indent-line ()
- "Indent the current line according to the current language construct. If
-before the indent, the point is moved to the indent."
+ "Indent the current line according to the current language construct.
+If before the indent, the point is moved to the indent."
(interactive)
(delphi-save-match-data
(let ((marked-point (point-marker)) ; Maintain our position reliably.
- (new-point nil)
(line-start nil)
(old-indent 0)
(new-indent 0))
@@ -1521,7 +1543,7 @@ before the indent, the point is moved to the indent."
(set-marker marked-point nil))))
(defvar delphi-mode-abbrev-table nil
- "Abbrev table in use in delphi-mode buffers.")
+ "Abbrev table in use in Delphi mode buffers.")
(define-abbrev-table 'delphi-mode-abbrev-table ())
(defmacro delphi-ensure-buffer (buffer-var buffer-name)
@@ -1542,7 +1564,7 @@ before the indent, the point is moved to the indent."
;; Debugging helpers:
(defvar delphi-debug-buffer nil
- "Buffer to write delphi-mode debug messages to. Created on demand.")
+ "Buffer to write Delphi mode debug messages to. Created on demand.")
(defun delphi-debug-log (format-string &rest args)
;; Writes a message to the log buffer.
@@ -1653,7 +1675,7 @@ before the indent, the point is moved to the indent."
(defun delphi-tab ()
"Indent the region, when Transient Mark mode is enabled and the region is
-active. Otherwise, indent the current line or insert a TAB, depending on the
+active. Otherwise, indent the current line or insert a TAB, depending on the
value of `delphi-tab-always-indents' and the current line position."
(interactive)
(cond ((use-region-p)
@@ -1742,8 +1764,8 @@ value of `delphi-tab-always-indents' and the current line position."
nil))
(defun delphi-find-unit (unit)
- "Finds the specified delphi source file according to `delphi-search-path'.
-If no extension is specified, .pas is assumed. Creates a buffer for the unit."
+ "Find the specified Delphi source file according to `delphi-search-path'.
+If no extension is specified, .pas is assumed. Creates a buffer for the unit."
(interactive "sDelphi unit name: ")
(let* ((unit-file (if (string-match "^\\(.*\\)\\.[a-z]+$" unit)
unit
@@ -1752,7 +1774,7 @@ If no extension is specified, .pas is assumed. Creates a buffer for the unit."
(if (null file)
(error "unit not found: %s" unit-file)
(find-file file)
- (if (not (eq major-mode 'delphi-mode))
+ (if (not (derived-mode-p 'delphi-mode))
(delphi-mode)))
file))
@@ -1765,7 +1787,7 @@ If no extension is specified, .pas is assumed. Creates a buffer for the unit."
"Find the definition of the identifier under the current point, searching
in external units if necessary (as listed in the current unit's use clause).
The set of directories to search for a unit is specified by the global variable
-delphi-search-path."
+`delphi-search-path'."
(interactive)
(error "delphi-find-current-xdef: not implemented yet"))
@@ -1776,7 +1798,7 @@ it is a routine."
(error "delphi-find-current-body: not implemented yet"))
(defun delphi-fill-comment ()
- "Fills the text of the current comment, according to `fill-column'.
+ "Fill the text of the current comment, according to `fill-column'.
An error is raised if not in a comment."
(interactive)
(save-excursion
@@ -1862,8 +1884,8 @@ An error is raised if not in a comment."
(delphi-progress-done)))))))
(defun delphi-new-comment-line ()
- "If in a // comment, does a newline, indented such that one is still in the
-comment block. If not in a // comment, just does a normal newline."
+ "If in a // comment, do a newline, indented such that one is still in the
+comment block. If not in a // comment, just does a normal newline."
(interactive)
(let ((comment (delphi-current-token)))
(if (not (eq 'comment-single-line (delphi-token-kind comment)))
@@ -1897,7 +1919,7 @@ comment block. If not in a // comment, just does a normal newline."
nil ; Syntax begin movement doesn't apply
(font-lock-fontify-region-function . delphi-fontify-region)
(font-lock-verbose . delphi-fontifying-progress-step))
- "Delphi mode font-lock defaults. Syntactic fontification is ignored.")
+ "Delphi mode font-lock defaults. Syntactic fontification is ignored.")
(defvar delphi-debug-mode-map
(let ((kmap (make-sparse-keymap)))
@@ -1918,7 +1940,7 @@ comment block. If not in a // comment, just does a normal newline."
("x" delphi-debug-show-is-stable)
))
kmap)
- "Keystrokes for delphi-mode debug commands.")
+ "Keystrokes for Delphi mode debug commands.")
(defvar delphi-mode-map
(let ((kmap (make-sparse-keymap)))
@@ -1938,7 +1960,7 @@ comment block. If not in a // comment, just does a normal newline."
"Keymap used in Delphi mode.")
(defconst delphi-mode-syntax-table (make-syntax-table)
- "Delphi mode's syntax table. It is just a standard syntax table.
+ "Delphi mode's syntax table. It is just a standard syntax table.
This is ok since we do our own keyword/comment/string face coloring.")
;;;###autoload
@@ -1950,7 +1972,7 @@ This is ok since we do our own keyword/comment/string face coloring.")
\\[delphi-fill-comment]\t- Fill the current comment.
\\[delphi-new-comment-line]\t- If in a // comment, do a new comment line.
-M-x indent-region also works for indenting a whole region.
+\\[indent-region] also works for indenting a whole region.
Customization:
@@ -1970,25 +1992,25 @@ Customization:
`delphi-search-path' (default .)
Directories to search when finding external units.
`delphi-verbose' (default nil)
- If true then delphi token processing progress is reported to the user.
+ If true then Delphi token processing progress is reported to the user.
Coloring:
`delphi-comment-face' (default font-lock-comment-face)
- Face used to color delphi comments.
+ Face used to color Delphi comments.
`delphi-string-face' (default font-lock-string-face)
- Face used to color delphi strings.
+ Face used to color Delphi strings.
`delphi-keyword-face' (default font-lock-keyword-face)
- Face used to color delphi keywords.
+ Face used to color Delphi keywords.
`delphi-other-face' (default nil)
Face used to color everything else.
-Turning on Delphi mode calls the value of the variable delphi-mode-hook with
-no args, if that value is non-nil."
+Turning on Delphi mode calls the value of the variable `delphi-mode-hook'
+with no args, if that value is non-nil."
(interactive)
(kill-all-local-variables)
(use-local-map delphi-mode-map)
- (setq major-mode 'delphi-mode)
+ (setq major-mode 'delphi-mode) ;FIXME: Use define-derived-mode.
(setq mode-name "Delphi")
(setq local-abbrev-table delphi-mode-abbrev-table)
@@ -1998,8 +2020,7 @@ no args, if that value is non-nil."
(mapc #'(lambda (var)
(let ((var-symb (car var))
(var-val (cadr var)))
- (make-local-variable var-symb)
- (set var-symb var-val)))
+ (set (make-local-variable var-symb) var-val)))
(list '(indent-line-function delphi-indent-line)
'(comment-indent-function delphi-indent-line)
'(case-fold-search t)
@@ -2021,5 +2042,4 @@ no args, if that value is non-nil."
(run-mode-hooks 'delphi-mode-hook))
-;; arch-tag: 410e192d-e9b5-4397-ad62-12340fc3fa41
;;; delphi.el ends here
diff --git a/lisp/progmodes/ebnf-abn.el b/lisp/progmodes/ebnf-abn.el
index f141a01dc98..b45a47f8a3f 100644
--- a/lisp/progmodes/ebnf-abn.el
+++ b/lisp/progmodes/ebnf-abn.el
@@ -1,12 +1,12 @@
;;; ebnf-abn.el --- parser for ABNF (Augmented BNF)
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: wp, ebnf, PostScript
;; Version: 1.2
+;; Package: ebnf2ps
;; This file is part of GNU Emacs.
@@ -663,5 +663,4 @@ See documentation for variable `ebnf-abn-lex'."
(provide 'ebnf-abn)
-;; arch-tag: 8d1b3c4d-4226-4393-b9ae-b7ccf07cf779
;;; ebnf-abn.el ends here
diff --git a/lisp/progmodes/ebnf-bnf.el b/lisp/progmodes/ebnf-bnf.el
index 2f2b6b0f2bf..cb8ebf8aab0 100644
--- a/lisp/progmodes/ebnf-bnf.el
+++ b/lisp/progmodes/ebnf-bnf.el
@@ -1,12 +1,12 @@
;;; ebnf-bnf.el --- parser for EBNF
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: wp, ebnf, PostScript
;; Version: 1.10
+;; Package: ebnf2ps
;; This file is part of GNU Emacs.
@@ -604,5 +604,4 @@ See documentation for variable `ebnf-bnf-lex'."
(provide 'ebnf-bnf)
-;; arch-tag: 3b1834d3-8367-475b-80d5-8e0bbd00ce50
;;; ebnf-bnf.el ends here
diff --git a/lisp/progmodes/ebnf-dtd.el b/lisp/progmodes/ebnf-dtd.el
index a41cd6e99e0..204b6a91b0f 100644
--- a/lisp/progmodes/ebnf-dtd.el
+++ b/lisp/progmodes/ebnf-dtd.el
@@ -1,12 +1,12 @@
;;; ebnf-dtd.el --- parser for DTD (Data Type Description for XML)
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: wp, ebnf, PostScript
;; Version: 1.1
+;; Package: ebnf2ps
;; This file is part of GNU Emacs.
@@ -1349,5 +1349,4 @@ See documentation for variable `ebnf-dtd-lex'."
(provide 'ebnf-dtd)
-;; arch-tag: c21bb640-135f-4afa-8712-fa11d86301c4
;;; ebnf-dtd.el ends here
diff --git a/lisp/progmodes/ebnf-ebx.el b/lisp/progmodes/ebnf-ebx.el
index ddbe5e6fade..7d697e889b7 100644
--- a/lisp/progmodes/ebnf-ebx.el
+++ b/lisp/progmodes/ebnf-ebx.el
@@ -1,12 +1,12 @@
;;; ebnf-ebx.el --- parser for EBNF used to specify XML (EBNFX)
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: wp, ebnf, PostScript
;; Version: 1.2
+;; Package: ebnf2ps
;; This file is part of GNU Emacs.
@@ -668,5 +668,4 @@ See documentation for variable `ebnf-ebx-lex'."
(provide 'ebnf-ebx)
-;; arch-tag: bfe2f95b-66bc-4dc6-8b7e-b7831e68f5fb
;;; ebnf-ebx.el ends here
diff --git a/lisp/progmodes/ebnf-iso.el b/lisp/progmodes/ebnf-iso.el
index f189f4eb92c..d33167093a3 100644
--- a/lisp/progmodes/ebnf-iso.el
+++ b/lisp/progmodes/ebnf-iso.el
@@ -1,12 +1,12 @@
;;; ebnf-iso.el --- parser for ISO EBNF
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: wp, ebnf, PostScript
;; Version: 1.9
+;; Package: ebnf2ps
;; This file is part of GNU Emacs.
@@ -611,5 +611,4 @@ See documentation for variable `ebnf-iso-lex'."
(provide 'ebnf-iso)
-;; arch-tag: 03315eef-8f64-404a-bf9d-256d42442ee3
;;; ebnf-iso.el ends here
diff --git a/lisp/progmodes/ebnf-otz.el b/lisp/progmodes/ebnf-otz.el
index bb038ee2f47..0392505972d 100644
--- a/lisp/progmodes/ebnf-otz.el
+++ b/lisp/progmodes/ebnf-otz.el
@@ -1,12 +1,12 @@
;;; ebnf-otz.el --- syntactic chart OpTimiZer
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: wp, ebnf, PostScript
;; Version: 1.0
+;; Package: ebnf2ps
;; This file is part of GNU Emacs.
@@ -696,5 +696,4 @@
(provide 'ebnf-otz)
-;; arch-tag: 7ef2249d-9e8b-4bc1-999f-95d784690636
;;; ebnf-otz.el ends here
diff --git a/lisp/progmodes/ebnf-yac.el b/lisp/progmodes/ebnf-yac.el
index 9fa88760659..5ff239bfa21 100644
--- a/lisp/progmodes/ebnf-yac.el
+++ b/lisp/progmodes/ebnf-yac.el
@@ -1,12 +1,12 @@
;;; ebnf-yac.el --- parser for Yacc/Bison
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: wp, ebnf, PostScript
;; Version: 1.4
+;; Package: ebnf2ps
;; This file is part of GNU Emacs.
@@ -512,5 +512,4 @@ See documentation for variable `ebnf-yac-lex'."
(provide 'ebnf-yac)
-;; arch-tag: 8a96989c-0b1d-42ba-a020-b2901f9a2a4d
;;; ebnf-yac.el ends here
diff --git a/lisp/progmodes/ebnf2ps.el b/lisp/progmodes/ebnf2ps.el
index 517fc5445e6..f7965d2cd01 100644
--- a/lisp/progmodes/ebnf2ps.el
+++ b/lisp/progmodes/ebnf2ps.el
@@ -1,7 +1,6 @@
;;; 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, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
@@ -2230,8 +2229,8 @@ processed.
See also `ebnf-print-buffer'."
(interactive
- (list (read-file-name "Directory containing EBNF files (print): "
- nil default-directory)))
+ (list (read-directory-name "Directory containing EBNF files (print): "
+ nil default-directory)))
(ebnf-log-header "(ebnf-print-directory %S)" directory)
(ebnf-directory 'ebnf-print-buffer directory))
@@ -2288,8 +2287,8 @@ processed.
See also `ebnf-spool-buffer'."
(interactive
- (list (read-file-name "Directory containing EBNF files (spool): "
- nil default-directory)))
+ (list (read-directory-name "Directory containing EBNF files (spool): "
+ nil default-directory)))
(ebnf-log-header "(ebnf-spool-directory %S)" directory)
(ebnf-directory 'ebnf-spool-buffer directory))
@@ -2341,8 +2340,8 @@ processed.
See also `ebnf-eps-buffer'."
(interactive
- (list (read-file-name "Directory containing EBNF files (EPS): "
- nil default-directory)))
+ (list (read-directory-name "Directory containing EBNF files (EPS): "
+ nil default-directory)))
(ebnf-log-header "(ebnf-eps-directory %S)" directory)
(ebnf-directory 'ebnf-eps-buffer directory))
@@ -2426,8 +2425,8 @@ are processed.
See also `ebnf-syntax-buffer'."
(interactive
- (list (read-file-name "Directory containing EBNF files (syntax): "
- nil default-directory)))
+ (list (read-directory-name "Directory containing EBNF files (syntax): "
+ nil default-directory)))
(ebnf-log-header "(ebnf-syntax-directory %S)" directory)
(ebnf-directory 'ebnf-syntax-buffer directory))
@@ -5279,7 +5278,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 +6394,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 8e0ad7e51e9..d31a46cc308 100644
--- a/lisp/progmodes/ebrowse.el
+++ b/lisp/progmodes/ebrowse.el
@@ -1,8 +1,6 @@
;;; 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, 2011
-;; Free Software Foundation Inc.
+;; Copyright (C) 1992-2011 Free Software Foundation, Inc.
;; Author: Gerd Moellmann <gerd@gnu.org>
;; Maintainer: FSF
@@ -738,7 +736,7 @@ MARKED-ONLY non-nil means include marked classes only."
"Return a list containing all files mentioned in a tree.
MARKED-ONLY non-nil means include marked classes only."
(let (list)
- (maphash #'(lambda (file dummy) (setq list (cons file list)))
+ (maphash (lambda (file _dummy) (setq list (cons file list)))
(ebrowse-files-table marked-only))
list))
@@ -786,9 +784,9 @@ The class tree is found in the buffer-local variable `ebrowse--tree-obarray'."
(defun ebrowse-sort-tree-list (list)
"Sort a LIST of `ebrowse-ts' structures by qualified class names."
(sort list
- #'(lambda (a b)
- (string< (ebrowse-qualified-class-name (ebrowse-ts-class a))
- (ebrowse-qualified-class-name (ebrowse-ts-class b))))))
+ (lambda (a b)
+ (string< (ebrowse-qualified-class-name (ebrowse-ts-class a))
+ (ebrowse-qualified-class-name (ebrowse-ts-class b))))))
(defun ebrowse-class-in-tree (class tree)
@@ -925,7 +923,7 @@ and TREE is a list of `ebrowse-ts' structures forming the class tree."
(list header tree)))
-(defun ebrowse-revert-tree-buffer-from-file (ignore-auto-save noconfirm)
+(defun ebrowse-revert-tree-buffer-from-file (_ignore-auto-save noconfirm)
"Function installed as `revert-buffer-function' in tree buffers.
See that variable's documentation for the meaning of IGNORE-AUTO-SAVE and
NOCONFIRM."
@@ -939,11 +937,11 @@ NOCONFIRM."
(current-buffer)))
-(defun ebrowse-create-tree-buffer (tree tags-file header obarray pop)
+(defun ebrowse-create-tree-buffer (tree tags-file header classes pop)
"Create a new tree buffer for tree TREE.
The tree was loaded from file TAGS-FILE.
HEADER is the header structure of the file.
-OBARRAY is an obarray with a symbol for each class in the tree.
+CLASSES is an obarray with a symbol for each class in the tree.
POP non-nil means popup the buffer up at the end.
Return the buffer created."
(let ((name ebrowse-tree-buffer-name))
@@ -951,7 +949,7 @@ Return the buffer created."
(ebrowse-tree-mode)
(setq ebrowse--tree tree
ebrowse--tags-file-name tags-file
- ebrowse--tree-obarray obarray
+ ebrowse--tree-obarray classes
ebrowse--header header
ebrowse--frozen-flag nil)
(ebrowse-redraw-tree)
@@ -1116,7 +1114,7 @@ if for some reason a circle is in the inheritance graph."
;;; Tree-mode - mode for tree buffers
;;;###autoload
-(defun ebrowse-tree-mode ()
+(define-derived-mode ebrowse-tree-mode special-mode "Ebrowse-Tree"
"Major mode for Ebrowse class tree buffers.
Each line corresponds to a class in a class tree.
Letters do not insert themselves, they are commands.
@@ -1125,12 +1123,10 @@ E.g.\\[save-buffer] writes the tree to the file it was loaded from.
Tree mode key bindings:
\\{ebrowse-tree-mode-map}"
- (interactive)
(let* ((ident (propertized-buffer-identification "C++ Tree"))
- header tree buffer-read-only)
+ (inhibit-read-only t)
+ header tree)
- (kill-all-local-variables)
- (use-local-map ebrowse-tree-mode-map)
(buffer-disable-undo)
(unless (zerop (buffer-size))
@@ -1141,38 +1137,27 @@ Tree mode key bindings:
(erase-buffer)
(message nil))
- (mapc 'make-local-variable
- '(ebrowse--tags-file-name
- ebrowse--indentation
- ebrowse--tree
- ebrowse--header
- ebrowse--show-file-names-flag
- ebrowse--frozen-flag
- ebrowse--tree-obarray
- revert-buffer-function))
-
- (setf ebrowse--show-file-names-flag nil
- ebrowse--tree-obarray (make-vector 127 0)
- ebrowse--frozen-flag nil
- major-mode 'ebrowse-tree-mode
- mode-name "Ebrowse-Tree"
- mode-line-buffer-identification ident
- buffer-read-only t
- selective-display t
- selective-display-ellipses t
- revert-buffer-function 'ebrowse-revert-tree-buffer-from-file
- ebrowse--header header
- ebrowse--tree tree
- ebrowse--tags-file-name (buffer-file-name)
- ebrowse--tree-obarray (and tree (ebrowse-build-tree-obarray tree))
- ebrowse--frozen-flag nil)
-
- (add-hook 'local-write-file-hooks 'ebrowse-write-file-hook-fn)
+ (set (make-local-variable 'ebrowse--show-file-names-flag) nil)
+ (set (make-local-variable 'ebrowse--tree-obarray) (make-vector 127 0))
+ (set (make-local-variable 'ebrowse--frozen-flag) nil)
+ (setq mode-line-buffer-identification ident)
+ (setq buffer-read-only t)
+ (setq selective-display t)
+ (setq selective-display-ellipses t)
+ (set (make-local-variable 'revert-buffer-function)
+ #'ebrowse-revert-tree-buffer-from-file)
+ (set (make-local-variable 'ebrowse--header) header)
+ (set (make-local-variable 'ebrowse--tree) tree)
+ (set (make-local-variable 'ebrowse--tags-file-name) buffer-file-name)
+ (set (make-local-variable 'ebrowse--tree-obarray)
+ (and tree (ebrowse-build-tree-obarray tree)))
+ (set (make-local-variable 'ebrowse--frozen-flag) nil)
+
+ (add-hook 'local-write-file-hooks 'ebrowse-write-file-hook-fn nil t)
(modify-syntax-entry ?_ (char-to-string (char-syntax ?a)))
(when tree
(ebrowse-redraw-tree)
- (set-buffer-modified-p nil))
- (run-mode-hooks 'ebrowse-tree-mode-hook)))
+ (set-buffer-modified-p nil))))
@@ -1230,17 +1215,16 @@ Do not ask for confirmation if FORCED is non-nil."
"Toggle mark for class cursor is on.
If given a numeric N-TIMES argument, mark that many classes."
(interactive "p")
- (let (to-change pnt)
+ (let (to-change)
;; Get the classes whose mark must be toggled. Note that
;; ebrowse-tree-at-point might issue an error.
- (condition-case error
- (loop repeat (or n-times 1)
- as tree = (ebrowse-tree-at-point)
- do (progn
- (setf (ebrowse-ts-mark tree) (not (ebrowse-ts-mark tree)))
- (forward-line 1)
- (push tree to-change)))
- (error nil))
+ (ignore-errors
+ (loop repeat (or n-times 1)
+ as tree = (ebrowse-tree-at-point)
+ do (progn
+ (setf (ebrowse-ts-mark tree) (not (ebrowse-ts-mark tree)))
+ (forward-line 1)
+ (push tree to-change))))
(save-excursion
;; For all these classes, reverse the mark char in the display
;; by a regexp replace over the whole buffer. The reason for this
@@ -1313,7 +1297,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
@@ -1340,6 +1324,7 @@ With PREFIX, insert that many filenames."
(defun ebrowse-member-buffer-p (buffer)
"Value is non-nil if BUFFER is a member buffer."
+ ;; FIXME: Why not (buffer-local-value 'major-mode buffer)?
(eq (cdr (assoc 'major-mode (buffer-local-variables buffer)))
'ebrowse-member-mode))
@@ -1390,9 +1375,9 @@ one buffer. Prefer tree buffers over member buffers."
(defun ebrowse-same-tree-member-buffer-list ()
"Return a list of members buffers with same tree as current buffer."
(ebrowse-delete-if-not
- #'(lambda (buffer)
- (eq (ebrowse-value-in-buffer 'ebrowse--tree buffer)
- ebrowse--tree))
+ (lambda (buffer)
+ (eq (ebrowse-value-in-buffer 'ebrowse--tree buffer)
+ ebrowse--tree))
(ebrowse-member-buffer-list)))
@@ -1431,9 +1416,9 @@ If no member buffer exists, make one."
when (eq class tree) do (kill-buffer buffer)))
-(defun ebrowse-frozen-tree-buffer-name (tags-file-name)
- "Return the buffer name of a tree which is associated TAGS-FILE-NAME."
- (concat ebrowse-tree-buffer-name " (" tags-file-name ")"))
+(defun ebrowse-frozen-tree-buffer-name (tags-file)
+ "Return the buffer name of a tree which is associated TAGS-FILE."
+ (concat ebrowse-tree-buffer-name " (" tags-file ")"))
(defun ebrowse-pop-to-browser-buffer (arg)
@@ -1459,12 +1444,13 @@ Pop to member buffer if no prefix ARG, to tree buffer otherwise."
(defun ebrowse-set-tree-indentation ()
"Set the indentation width of the tree display."
(interactive)
- (let ((width (string-to-number (read-from-minibuffer
- (concat "Indentation ("
+ (let ((width (string-to-number (read-string
+ (concat "Indentation (default "
(int-to-string ebrowse--indentation)
- "): ")))))
+ "): ")
+ nil nil ebrowse--indentation))))
(when (plusp width)
- (setf ebrowse--indentation width)
+ (set (make-local-variable 'ebrowse--indentation) width)
(ebrowse-redraw-tree))))
@@ -1558,41 +1544,41 @@ VIEW non-nil means view it. WHERE is additional position info."
where)))
-(defun ebrowse-find-class-declaration (prefix-arg)
+(defun ebrowse-find-class-declaration (prefix)
"Find a class declaration and position cursor on it.
-PREFIX-ARG 4 means find it in another window.
-PREFIX-ARG 5 means find it in another frame."
+PREFIX 4 means find it in another window.
+PREFIX 5 means find it in another frame."
(interactive "p")
(ebrowse-view/find-class-declaration
:view nil
- :where (cond ((= prefix-arg 4) 'other-window)
- ((= prefix-arg 5) 'other-frame)
- (t 'this-window))))
+ :where (cond ((= prefix 4) 'other-window)
+ ((= prefix 5) 'other-frame)
+ (t 'this-window))))
-(defun ebrowse-view-class-declaration (prefix-arg)
+(defun ebrowse-view-class-declaration (prefix)
"View class declaration and position cursor on it.
-PREFIX-ARG 4 means view it in another window.
-PREFIX-ARG 5 means view it in another frame."
+PREFIX 4 means view it in another window.
+PREFIX 5 means view it in another frame."
(interactive "p")
(ebrowse-view/find-class-declaration
:view 'view
- :where (cond ((= prefix-arg 4) 'other-window)
- ((= prefix-arg 5) 'other-frame)
- (t 'this-window))))
+ :where (cond ((= prefix 4) 'other-window)
+ ((= prefix 5) 'other-frame)
+ (t 'this-window))))
;;; The FIND engine
-(defun ebrowse-find-source-file (file tags-file-name)
+(defun ebrowse-find-source-file (file tags-file)
"Find source file FILE.
-Source files are searched for (a) relative to TAGS-FILE-NAME
+Source files are searched for (a) relative to TAGS-FILE
which is the path of the BROWSE file from which the class tree was loaded,
and (b) in the directories named in `ebrowse-search-path'."
(let (file-name
(try-file (expand-file-name file
- (file-name-directory tags-file-name))))
+ (file-name-directory tags-file))))
(if (file-readable-p try-file)
(setq file-name try-file)
(let ((search-in ebrowse-search-path))
@@ -1632,18 +1618,17 @@ The new frame is deleted when you quit viewing the file in that frame."
(had-a-buf (get-file-buffer file))
(buf-to-view (find-file-noselect file)))
(switch-to-buffer-other-frame buf-to-view)
- (make-local-variable 'ebrowse--frame-configuration)
- (setq ebrowse--frame-configuration old-frame-configuration)
- (make-local-variable 'ebrowse--view-exit-action)
- (setq ebrowse--view-exit-action
- (and (not had-a-buf)
- (not (buffer-modified-p buf-to-view))
- 'kill-buffer))
+ (set (make-local-variable 'ebrowse--frame-configuration)
+ old-frame-configuration)
+ (set (make-local-variable 'ebrowse--view-exit-action)
+ (and (not had-a-buf)
+ (not (buffer-modified-p buf-to-view))
+ 'kill-buffer))
(view-mode-enter (cons (selected-window) (cons (selected-window) t))
'ebrowse-view-exit-fn)))
(defun ebrowse-view/find-file-and-search-pattern
- (struc info file tags-file-name &optional view where)
+ (struc info file tags-file &optional view where)
"Find or view a member or class.
STRUC is an `ebrowse-bs' structure (or a structure including that)
describing what to search.
@@ -1655,7 +1640,7 @@ if MEMBER-OR-CLASS is an `ebrowse-ms'.
FILE is the file to search the member in.
FILE is not taken out of STRUC here because the filename in STRUC
may be nil in which case the filename of the class description is used.
-TAGS-FILE-NAME is the name of the BROWSE file from which the
+TAGS-FILE is the name of the BROWSE file from which the
tree was loaded.
If VIEW is non-nil, view file else find the file.
WHERE is either `other-window', `other-frame' or `this-window' and
@@ -1664,7 +1649,7 @@ specifies where to find/view the result."
(error "Sorry, no file information available for %s"
(ebrowse-bs-name struc)))
;; Get the source file to view or find.
- (setf file (ebrowse-find-source-file file tags-file-name))
+ (setf file (ebrowse-find-source-file file tags-file))
;; If current window is dedicated, use another frame.
(when (window-dedicated-p (selected-window))
(setf where 'other-window))
@@ -2006,21 +1991,16 @@ COLLAPSE non-nil means collapse the branch."
(put 'ebrowse-electric-list-undefined 'suppress-keymap t)
-(defun ebrowse-electric-list-mode ()
+(define-derived-mode ebrowse-electric-list-mode
+ fundamental-mode "Electric Position Menu"
"Mode for electric tree list mode."
- (kill-all-local-variables)
- (use-local-map ebrowse-electric-list-mode-map)
- (setq mode-name "Electric Position Menu"
- mode-line-buffer-identification "Electric Tree Menu")
+ (setq mode-line-buffer-identification "Electric Tree Menu")
(when (memq 'mode-name mode-line-format)
(setq mode-line-format (copy-sequence mode-line-format))
(setcar (memq 'mode-name mode-line-format) "Tree Buffers"))
- (make-local-variable 'Helper-return-blurb)
- (setq Helper-return-blurb "return to buffer editing"
- truncate-lines t
- buffer-read-only t
- major-mode 'ebrowse-electric-list-mode)
- (run-mode-hooks 'ebrowse-electric-list-mode-hook))
+ (set (make-local-variable 'Helper-return-blurb) "return to buffer editing")
+ (setq truncate-lines t
+ buffer-read-only t))
(defun ebrowse-list-tree-buffers ()
@@ -2226,13 +2206,8 @@ See 'Electric-command-loop' for a description of STATE and CONDITION."
;;; Member mode
;;;###autoload
-(defun ebrowse-member-mode ()
- "Major mode for Ebrowse member buffers.
-
-\\{ebrowse-member-mode-map}"
- (kill-all-local-variables)
- (use-local-map ebrowse-member-mode-map)
- (setq major-mode 'ebrowse-member-mode)
+(define-derived-mode ebrowse-member-mode special-mode "Ebrowse-Members"
+ "Major mode for Ebrowse member buffers."
(mapc 'make-local-variable
'(ebrowse--decl-column ;display column
ebrowse--n-columns ;number of short columns
@@ -2255,8 +2230,7 @@ See 'Electric-command-loop' for a description of STATE and CONDITION."
ebrowse--const-display-flag
ebrowse--pure-display-flag
ebrowse--frozen-flag)) ;buffer not automagically reused
- (setq mode-name "Ebrowse-Members"
- mode-line-buffer-identification
+ (setq mode-line-buffer-identification
(propertized-buffer-identification "C++ Members")
buffer-read-only t
ebrowse--long-display-flag nil
@@ -2270,8 +2244,7 @@ See 'Electric-command-loop' for a description of STATE and CONDITION."
ebrowse--inline-display-flag nil
ebrowse--const-display-flag nil
ebrowse--pure-display-flag nil)
- (modify-syntax-entry ?_ (char-to-string (char-syntax ?a)))
- (run-mode-hooks 'ebrowse-member-mode-hook))
+ (modify-syntax-entry ?_ (char-to-string (char-syntax ?a))))
@@ -2564,7 +2537,7 @@ find file in another frame."
(defun* ebrowse-view/find-member-declaration/definition
- (prefix view &optional definition info header tags-file-name)
+ (prefix view &optional definition info header tags-file)
"Find or view a member declaration or definition.
With PREFIX 4. find file in another window, with prefix 5
find file in another frame.
@@ -2572,11 +2545,11 @@ DEFINITION non-nil means find the definition, otherwise find the
declaration.
INFO is a list (TREE ACCESSOR MEMBER) describing the member to
search.
-TAGS-FILE-NAME is the file name of the BROWSE file."
+TAGS-FILE is the file name of the BROWSE file."
(unless header
(setq header ebrowse--header))
- (unless tags-file-name
- (setq tags-file-name ebrowse--tags-file-name))
+ (unless tags-file
+ (setq tags-file ebrowse--tags-file-name))
(let (tree member accessor file on-class
(where (if (= prefix 4) 'other-window
(if (= prefix 5) 'other-frame 'this-window))))
@@ -2596,7 +2569,7 @@ TAGS-FILE-NAME is the file name of the BROWSE file."
(ebrowse-ts-class tree)
(list ebrowse--header (ebrowse-ts-class tree) nil)
(ebrowse-cs-file (ebrowse-ts-class tree))
- tags-file-name view where)))
+ tags-file view where)))
;; For some member lists, it doesn't make sense to search for
;; a definition. If this is requested, silently search for the
;; declaration.
@@ -2633,7 +2606,7 @@ TAGS-FILE-NAME is the file name of the BROWSE file."
(message nil)
;; Recurse with new info.
(ebrowse-view/find-member-declaration/definition
- prefix view (not definition) info header tags-file-name))
+ prefix view (not definition) info header tags-file))
(error "Search canceled"))
;; Find that thing.
(ebrowse-view/find-file-and-search-pattern
@@ -2644,7 +2617,7 @@ TAGS-FILE-NAME is the file name of the BROWSE file."
:point (ebrowse-ms-point member))
(list header member accessor)
file
- tags-file-name
+ tags-file
view
where))))
@@ -2703,7 +2676,7 @@ LIST is the member list to display. STAND-ALONE non-nil
means the member buffer is standalone. CLASS is its class."
(let* ((classes ebrowse--tree-obarray)
(tree ebrowse--tree)
- (tags-file-name ebrowse--tags-file-name)
+ (tags-file ebrowse--tags-file-name)
(header ebrowse--header)
temp-buffer-setup-hook
(temp-buffer (get-buffer ebrowse-member-buffer-name)))
@@ -2723,7 +2696,7 @@ means the member buffer is standalone. CLASS is its class."
ebrowse--accessor list
ebrowse--tree-obarray classes
ebrowse--frozen-flag stand-alone
- ebrowse--tags-file-name tags-file-name
+ ebrowse--tags-file-name tags-file
ebrowse--header header
ebrowse--tree tree
buffer-read-only t)
@@ -2875,7 +2848,7 @@ is nil."
;;; Switching member buffer to display a selected member
-(defun ebrowse-goto-visible-member/all-member-lists (prefix)
+(defun ebrowse-goto-visible-member/all-member-lists (_prefix)
"Position cursor on a member read from the minibuffer.
With PREFIX, search all members in the tree. Otherwise consider
only members visible in the buffer."
@@ -3305,7 +3278,7 @@ HEADER is the `ebrowse-hs' structure of the class tree.
Prompt with PROMPT. Insert into the minibuffer a C++ identifier read
from point as default. Value is a list (CLASS-NAME MEMBER-NAME)."
(save-excursion
- (let* (start member-info (members (ebrowse-member-table header)))
+ (let ((members (ebrowse-member-table header)))
(multiple-value-bind (class-name member-name)
(values-list (ebrowse-tags-read-member+class-name))
(unless member-name
@@ -3316,7 +3289,7 @@ from point as default. Value is a list (CLASS-NAME MEMBER-NAME)."
(completion-result (try-completion name members)))
;; Cannot rely on `try-completion' returning t for exact
;; matches! It returns the name as a string.
- (unless (setq member-info (gethash name members))
+ (unless (gethash name members)
(if (y-or-n-p "No exact match found. Try substrings? ")
(setq name
(or (first (ebrowse-list-of-matching-members
@@ -3342,7 +3315,7 @@ MEMBER-NAME is the name of the member found."
(list class name))))
-(defun ebrowse-tags-choose-class (tree header name initial-class-name)
+(defun ebrowse-tags-choose-class (_tree header name initial-class-name)
"Read a class name for a member from the minibuffer.
TREE is the class tree we operate on.
HEADER is its header structure.
@@ -3380,7 +3353,7 @@ definition."
info)
(unless name
(multiple-value-setq (class-name name)
- (values-list
+ (values-list
(ebrowse-tags-read-name
header
(concat (if view "View" "Find") " member "
@@ -3507,7 +3480,7 @@ Otherwise read a member name from point."
(let* ((marker (point-marker)) class-name (name fix-name) info)
(unless name
(multiple-value-setq (class-name name)
- (values-list
+ (values-list
(ebrowse-tags-read-name header
(concat "Find member list of: ")))))
(setq info (ebrowse-tags-choose-class tree header name class-name))
@@ -3521,10 +3494,10 @@ Both NAME and REGEXP may be nil in which case exact or regexp matches
are not performed."
(let (list)
(when (or name regexp)
- (maphash #'(lambda (member-name info)
- (when (or (and name (string= name member-name))
- (and regexp (string-match regexp member-name)))
- (setq list (cons member-name list))))
+ (maphash (lambda (member-name _info)
+ (when (or (and name (string= name member-name))
+ (and regexp (string-match regexp member-name)))
+ (setq list (cons member-name list))))
members))
list))
@@ -3561,18 +3534,18 @@ The file name is read from the minibuffer."
(with-output-to-temp-buffer (concat "*Members in file " file "*")
(set-buffer standard-output)
(maphash
- #'(lambda (member-name list)
- (loop for info in list
- as member = (third info)
- as class = (ebrowse-ts-class (first info))
- when (or (and (null (ebrowse-ms-file member))
- (string= (ebrowse-cs-file class) file))
- (string= file (ebrowse-ms-file member)))
- do (ebrowse-draw-file-member-info info "decl.")
- when (or (and (null (ebrowse-ms-definition-file member))
- (string= (ebrowse-cs-source-file class) file))
- (string= file (ebrowse-ms-definition-file member)))
- do (ebrowse-draw-file-member-info info "defn.")))
+ (lambda (_member-name list)
+ (loop for info in list
+ as member = (third info)
+ as class = (ebrowse-ts-class (first info))
+ when (or (and (null (ebrowse-ms-file member))
+ (string= (ebrowse-cs-file class) file))
+ (string= file (ebrowse-ms-file member)))
+ do (ebrowse-draw-file-member-info info "decl.")
+ when (or (and (null (ebrowse-ms-definition-file member))
+ (string= (ebrowse-cs-source-file class) file))
+ (string= file (ebrowse-ms-definition-file member)))
+ do (ebrowse-draw-file-member-info info "defn.")))
members))))
@@ -3592,12 +3565,12 @@ KIND is an additional string printed in the buffer."
(insert kind)
(indent-to 50)
(insert (case (second info)
- ('ebrowse-ts-member-functions "member function")
- ('ebrowse-ts-member-variables "member variable")
- ('ebrowse-ts-static-functions "static function")
- ('ebrowse-ts-static-variables "static variable")
- ('ebrowse-ts-friends (if globals-p "define" "friend"))
- ('ebrowse-ts-types "type")
+ (ebrowse-ts-member-functions "member function")
+ (ebrowse-ts-member-variables "member variable")
+ (ebrowse-ts-static-functions "static function")
+ (ebrowse-ts-static-variables "static variable")
+ (ebrowse-ts-friends (if globals-p "define" "friend"))
+ (ebrowse-ts-types "type")
(t "unknown"))
"\n")))
@@ -3967,22 +3940,17 @@ Prefix arg ARG says how much."
(put 'ebrowse-electric-position-undefined 'suppress-keymap t)
-(defun ebrowse-electric-position-mode ()
+(define-derived-mode ebrowse-electric-position-mode
+ fundamental-mode "Electric Position Menu"
"Mode for electric position buffers.
Runs the hook `ebrowse-electric-position-mode-hook'."
- (kill-all-local-variables)
- (use-local-map ebrowse-electric-position-mode-map)
- (setq mode-name "Electric Position Menu"
- mode-line-buffer-identification "Electric Position Menu")
+ (setq mode-line-buffer-identification "Electric Position Menu")
(when (memq 'mode-name mode-line-format)
(setq mode-line-format (copy-sequence mode-line-format))
(setcar (memq 'mode-name mode-line-format) "Positions"))
- (make-local-variable 'Helper-return-blurb)
- (setq Helper-return-blurb "return to buffer editing"
- truncate-lines t
- buffer-read-only t
- major-mode 'ebrowse-electric-position-mode)
- (run-mode-hooks 'ebrowse-electric-position-mode-hook))
+ (set (make-local-variable 'Helper-return-blurb) "return to buffer editing")
+ (setq truncate-lines t
+ buffer-read-only t))
(defun ebrowse-draw-position-buffer ()
@@ -4491,5 +4459,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 7df34d8f3df..6bd2de992cb 100644
--- a/lisp/progmodes/etags.el
+++ b/lisp/progmodes/etags.el
@@ -1,7 +1,6 @@
;;; 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, 2011
+;; Copyright (C) 1985-1986, 1988-1989, 1992-1996, 1998, 2000-2011
;; Free Software Foundation, Inc.
;; Author: Roland McGrath <roland@gnu.org>
@@ -40,6 +39,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 +67,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)
@@ -261,7 +263,7 @@ One argument, the tag info returned by `snarf-tag-function'.")
(defun initialize-new-tags-table ()
"Initialize the tags table in the current buffer.
Return non-nil if it is a valid tags table, and
-in that case, also make the tags table state variables
+in that case, also make the tags table state variables
buffer-local and set them to nil."
(set (make-local-variable 'tags-table-files) nil)
(set (make-local-variable 'tags-completion-table) nil)
@@ -277,7 +279,7 @@ buffer-local and set them to nil."
(defun tags-table-mode ()
"Major mode for tags table file buffers."
(interactive)
- (setq major-mode 'tags-table-mode
+ (setq major-mode 'tags-table-mode ;FIXME: Use define-derived-mode.
mode-name "Tags Table"
buffer-undo-list t)
(initialize-new-tags-table))
@@ -423,9 +425,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 +473,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 +789,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."
@@ -827,6 +853,7 @@ The functions using this are `find-tag-noselect',
;; Dynamic bondage:
(defvar etags-case-fold-search)
(defvar etags-syntax-table)
+(defvar local-find-tag-hook)
;;;###autoload
(defun find-tag-noselect (tagname &optional next-p regexp-p)
@@ -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)))))
@@ -1634,7 +1657,7 @@ Point should be just after a string that matches TAG."
;; partial file name match, i.e. searched tag must match a substring
;; of the file name (potentially including a directory separator).
-(defun tag-partial-file-name-match-p (tag)
+(defun tag-partial-file-name-match-p (_tag)
"Return non-nil if current tag matches file name.
This is a substring match, and it can include directory separators.
Point should be just after a string that matches TAG."
@@ -1644,7 +1667,7 @@ Point should be just after a string that matches TAG."
(looking-at "\f\n"))))
;; t if point is in a tag line with a tag containing TAG as a substring.
-(defun tag-any-match-p (tag)
+(defun tag-any-match-p (_tag)
"Return non-nil if current tag line contains TAG as a substring."
(looking-at ".*\177"))
@@ -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
@@ -1733,9 +1756,9 @@ if the file was newly read in, the value is the filename."
(with-current-buffer buffer
(revert-buffer t t)))
(if (not (and new novisit))
- (set-buffer (find-file-noselect next novisit))
+ (find-file next novisit)
;; Like find-file, but avoids random warning messages.
- (set-buffer (get-buffer-create " *next-file*"))
+ (switch-to-buffer (get-buffer-create " *next-file*"))
(kill-all-local-variables)
(erase-buffer)
(setq new next)
@@ -1884,7 +1907,7 @@ See also the documentation of the variable `tags-file-name'."
(try-completion string (tags-table-files) predicate))))
;;;###autoload
-(defun list-tags (file &optional next-match)
+(defun list-tags (file &optional _next-match)
"Display list of tags in file FILE.
This searches only the first table in the list, and no included tables.
FILE should be as it appeared in the `etags' command, usually without a
@@ -2007,10 +2030,8 @@ see the doc of that variable if you want to add names to the list."
(define-key map "q" 'select-tags-table-quit)
map))
-(define-derived-mode select-tags-table-mode fundamental-mode "Select Tags Table"
- "Major mode for choosing a current tags table among those already loaded.
-
-\\{select-tags-table-mode-map}"
+(define-derived-mode select-tags-table-mode special-mode "Select Tags Table"
+ "Major mode for choosing a current tags table among those already loaded."
(setq buffer-read-only t))
(defun select-tags-table-select (button)
@@ -2039,20 +2060,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 +2080,4 @@ for \\[find-tag] (which see)."
(provide 'etags)
-;; arch-tag: b897c2b5-08f3-4837-b2d3-0e7d6db1b63e
;;; etags.el ends here
diff --git a/lisp/progmodes/executable.el b/lisp/progmodes/executable.el
index 61d0c5ec5cb..d8133cb6b90 100644
--- a/lisp/progmodes/executable.el
+++ b/lisp/progmodes/executable.el
@@ -1,7 +1,6 @@
;;; executable.el --- base functionality for executable interpreter scripts -*- byte-compile-dynamic: t -*-
-;; Copyright (C) 1994, 1995, 1996, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1996, 2000-2011 Free Software Foundation, Inc.
;; Author: Daniel Pfeiffer <occitan@esperanto.org>
;; Keywords: languages, unix
@@ -174,6 +173,8 @@ non-executable files."
(file-modes buffer-file-name)))))))
+(defvar compilation-error-regexp-alist) ; from compile.el
+
;;;###autoload
(defun executable-interpret (command)
"Run script with user-specified args, and collect output in a buffer.
@@ -187,7 +188,7 @@ command to find the next error. The buffer is also in `comint-mode' and
(save-some-buffers (not compilation-ask-about-save))
(set (make-local-variable 'executable-command) command)
(let ((compilation-error-regexp-alist executable-error-regexp-alist))
- (compilation-start command t (lambda (x) "*interpretation*"))))
+ (compilation-start command t (lambda (_x) "*interpretation*"))))
@@ -276,5 +277,4 @@ file modes."
(provide 'executable)
-;; arch-tag: 58458d1c-d9db-45ec-942b-8bbb1d5e319d
;;; executable.el ends here
diff --git a/lisp/progmodes/f90.el b/lisp/progmodes/f90.el
index afdd2f2e1b7..53aa95498da 100644
--- a/lisp/progmodes/f90.el
+++ b/lisp/progmodes/f90.el
@@ -1,9 +1,8 @@
;;; f90.el --- Fortran-90 mode (free format)
-;; Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-1997, 2000-2011 Free Software Foundation, Inc.
-;; Author: Torbj\"orn Einarsson <Torbjorn.Einarsson@era.ericsson.se>
+;; Author: Torbjörn Einarsson <Torbjorn.Einarsson@era.ericsson.se>
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: fortran, f90, languages
@@ -657,6 +656,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 +1008,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,16 +1065,10 @@ 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
+ :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)
(set (make-local-variable 'comment-start) "!")
(set (make-local-variable 'comment-start-skip) "!+ *")
(set (make-local-variable 'comment-indent-function) 'f90-comment-indent)
@@ -1094,8 +1088,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.
@@ -1362,11 +1355,10 @@ if all else fails."
(defun f90-get-correct-indent ()
"Get correct indent for a line starting with line number.
Does not check type and subprogram indentation."
- (let ((epnt (line-end-position)) icol cont)
+ (let ((epnt (line-end-position)) icol)
(save-excursion
(while (and (f90-previous-statement)
- (or (memq (setq cont (f90-present-statement-cont))
- '(middle end))
+ (or (memq (f90-present-statement-cont) '(middle end))
(looking-at "[ \t]*[0-9]"))))
(setq icol (current-indentation))
(beginning-of-line)
@@ -2210,7 +2202,7 @@ CHANGE-WORD should be one of 'upcase-word, 'downcase-word, 'capitalize-word."
(let ((tag (find-tag-default)))
(or (and tag
;; See bug#7919. TODO I imagine there are other cases...?
- (string-match "%\\(.+\\)" tag)
+ (string-match "%\\([^%]+\\)\\'" tag)
(match-string-no-properties 1 tag))
tag)))
@@ -2221,7 +2213,7 @@ CHANGE-WORD should be one of 'upcase-word, 'downcase-word, 'capitalize-word."
With optional argument ALL, change the default for all present
and future F90 buffers. F90 mode normally treats backslash as an
escape character."
- (or (eq major-mode 'f90-mode)
+ (or (derived-mode-p 'f90-mode)
(error "This function should only be used in F90 buffers"))
(when (equal (char-syntax ?\\ ) ?\\ )
(or all (set-syntax-table (copy-syntax-table (syntax-table))))
@@ -2230,5 +2222,9 @@ escape character."
(provide 'f90)
-;; arch-tag: fceac97c-c147-44bd-aec0-172d4b560ef8
+;; Local Variables:
+;; coding: utf-8
+;; lexical-binding: t
+;; End:
+
;;; f90.el ends here
diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el
index da28a2e36f6..6200591fbbb 100644
--- a/lisp/progmodes/flymake.el
+++ b/lisp/progmodes/flymake.el
@@ -1,7 +1,6 @@
;;; flymake.el -- a universal on-the-fly syntax checker
-;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2003-2011 Free Software Foundation, Inc.
;; Author: Pavel Kobyakov <pk_at_work@yahoo.com>
;; Maintainer: Pavel Kobyakov <pk_at_work@yahoo.com>
@@ -106,16 +105,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
@@ -423,9 +412,11 @@ to the beginning of the list (File.h -> File.cpp moved to top)."
(not (equal file-one file-two))))
(defcustom flymake-check-file-limit 8192
- "Max number of chars to look at when checking possible master file."
+ "Maximum number of chars to look at when checking possible master file.
+Nil means search the entire file."
:group 'flymake
- :type 'integer)
+ :type '(choice (const :tag "No limit" nil)
+ (integer :tag "Characters")))
(defun flymake-check-patch-master-file-buffer
(master-file-temp-buffer
@@ -441,16 +432,26 @@ For example, foo.cpp is a master file if it includes foo.h.
Whether a buffer for MATER-FILE-NAME exists, use it as a source
instead of reading master file from disk."
(let* ((source-file-nondir (file-name-nondirectory source-file-name))
+ (source-file-extension (file-name-extension source-file-nondir))
+ (source-file-nonext (file-name-sans-extension source-file-nondir))
(found nil)
(inc-name nil)
(search-limit flymake-check-file-limit))
(setq regexp
(format regexp ; "[ \t]*#[ \t]*include[ \t]*\"\\(.*%s\\)\""
- (regexp-quote source-file-nondir)))
+ ;; Hack for tex files, where \include often excludes .tex.
+ ;; Maybe this is safe generally.
+ (if (and (> (length source-file-extension) 1)
+ (string-equal source-file-extension "tex"))
+ (format "%s\\(?:\\.%s\\)?"
+ (regexp-quote source-file-nonext)
+ (regexp-quote source-file-extension))
+ (regexp-quote source-file-nondir))))
(unwind-protect
(with-current-buffer master-file-temp-buffer
- (when (> search-limit (point-max))
- (setq search-limit (point-max)))
+ (if (or (not search-limit)
+ (> search-limit (point-max)))
+ (setq search-limit (point-max)))
(flymake-log 3 "checking %s against regexp %s"
master-file-name regexp)
(goto-char (point-min))
@@ -461,6 +462,11 @@ instead of reading master file from disk."
(flymake-log 3 "found possible match for %s" source-file-nondir)
(setq inc-name (match-string 1))
+ (and (> (length source-file-extension) 1)
+ (string-equal source-file-extension "tex")
+ (not (string-match (format "\\.%s\\'" source-file-extension)
+ inc-name))
+ (setq inc-name (concat inc-name "." source-file-extension)))
(when (eq t (compare-strings
source-file-nondir nil nil
inc-name (- (length inc-name)
@@ -590,7 +596,7 @@ It's flymake process filter."
(with-current-buffer source-buffer
(flymake-parse-output-and-residual output)))))
-(defun flymake-process-sentinel (process event)
+(defun flymake-process-sentinel (process _event)
"Sentinel for syntax check buffers."
(when (memq (process-status process) '(signal exit))
(let* ((exit-status (process-exit-status process))
@@ -808,8 +814,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)))
@@ -1104,7 +1110,7 @@ For the format of LINE-ERR-INFO, see `flymake-ler-make-ler'."
(flymake-log 1 "deleted file %s" file-name)))
(defun flymake-safe-delete-directory (dir-name)
- (condition-case err
+ (condition-case nil
(progn
(delete-directory dir-name)
(flymake-log 1 "deleted dir %s" dir-name))
@@ -1146,35 +1152,34 @@ For the format of LINE-ERR-INFO, see `flymake-ler-make-ler'."
(defun flymake-start-syntax-check-process (cmd args dir)
"Start syntax check process."
- (let* ((process nil))
- (condition-case err
- (progn
- (when dir
- (let ((default-directory dir))
- (flymake-log 3 "starting process on dir %s" default-directory)))
- (setq process (apply 'start-file-process
- "flymake-proc" (current-buffer) cmd args))
- (set-process-sentinel process 'flymake-process-sentinel)
- (set-process-filter process 'flymake-process-filter)
- (push process flymake-processes)
-
- (setq flymake-is-running t)
- (setq flymake-last-change-time nil)
- (setq flymake-check-start-time (flymake-float-time))
-
- (flymake-report-status nil "*")
- (flymake-log 2 "started process %d, command=%s, dir=%s"
- (process-id process) (process-command process)
- default-directory)
- process)
- (error
- (let* ((err-str (format "Failed to launch syntax check process '%s' with args %s: %s"
- cmd args (error-message-string err)))
- (source-file-name buffer-file-name)
- (cleanup-f (flymake-get-cleanup-function source-file-name)))
- (flymake-log 0 err-str)
- (funcall cleanup-f)
- (flymake-report-fatal-status "PROCERR" err-str))))))
+ (condition-case err
+ (let* ((process
+ (let ((default-directory (or dir default-directory)))
+ (when dir
+ (flymake-log 3 "starting process on dir %s" dir))
+ (apply 'start-file-process
+ "flymake-proc" (current-buffer) cmd args))))
+ (set-process-sentinel process 'flymake-process-sentinel)
+ (set-process-filter process 'flymake-process-filter)
+ (push process flymake-processes)
+
+ (setq flymake-is-running t)
+ (setq flymake-last-change-time nil)
+ (setq flymake-check-start-time (flymake-float-time))
+
+ (flymake-report-status nil "*")
+ (flymake-log 2 "started process %d, command=%s, dir=%s"
+ (process-id process) (process-command process)
+ default-directory)
+ process)
+ (error
+ (let* ((err-str (format "Failed to launch syntax check process '%s' with args %s: %s"
+ cmd args (error-message-string err)))
+ (source-file-name buffer-file-name)
+ (cleanup-f (flymake-get-cleanup-function source-file-name)))
+ (flymake-log 0 err-str)
+ (funcall cleanup-f)
+ (flymake-report-fatal-status "PROCERR" err-str)))))
(defun flymake-kill-process (proc)
"Kill process PROC."
@@ -1381,7 +1386,7 @@ With arg, turn Flymake mode on if and only if arg is positive."
:group 'flymake
:type 'boolean)
-(defun flymake-after-change-function (start stop len)
+(defun flymake-after-change-function (start stop _len)
"Start syntax check for current buffer if it isn't already running."
;;+(flymake-log 0 "setting change time to %s" (flymake-float-time))
(let((new-text (buffer-substring start stop)))
@@ -1491,7 +1496,7 @@ With arg, turn Flymake mode on if and only if arg is positive."
(flymake-log 3 "create-temp-inplace: file=%s temp=%s" file-name temp-name)
temp-name))
-(defun flymake-create-temp-with-folder-structure (file-name prefix)
+(defun flymake-create-temp-with-folder-structure (file-name _prefix)
(unless (stringp file-name)
(error "Invalid file-name"))
@@ -1747,15 +1752,18 @@ Use CREATE-TEMP-F for creating temp copy."
(defun flymake-simple-tex-init ()
(flymake-get-tex-args (flymake-init-create-temp-buffer-copy 'flymake-create-temp-inplace)))
+;; Perhaps there should be a buffer-local variable flymake-master-file
+;; that people can set to override this stuff. Could inherit from
+;; the similar AUCTeX variable.
(defun flymake-master-tex-init ()
(let* ((temp-master-file-name (flymake-init-create-temp-source-and-master-buffer-copy
'flymake-get-include-dirs-dot 'flymake-create-temp-inplace
'("\\.tex\\'")
- "[ \t]*\\input[ \t]*{\\(.*%s\\)}")))
+ "[ \t]*\\in\\(?:put\\|clude\\)[ \t]*{\\(.*%s\\)}")))
(when temp-master-file-name
(flymake-get-tex-args temp-master-file-name))))
-(defun flymake-get-include-dirs-dot (base-dir)
+(defun flymake-get-include-dirs-dot (_base-dir)
'("."))
;;;; xml-specific init-cleanup routines
@@ -1764,5 +1772,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 3a9b325c9d2..f03d2013467 100644
--- a/lisp/progmodes/fortran.el
+++ b/lisp/progmodes/fortran.el
@@ -1,8 +1,6 @@
;;; fortran.el --- Fortran mode for GNU Emacs
-;; Copyright (C) 1986, 1993, 1994, 1995, 1997, 1998, 1999, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1986, 1993-1995, 1997-2011 Free Software Foundation, Inc.
;; Author: Michael D. Prange <prange@erl.mit.edu>
;; Maintainer: Glenn Morris <rgm@gnu.org>
@@ -293,7 +291,7 @@ buffer). This corresponds to the g77 compiler option
:type 'integer
:safe 'integerp
:initialize 'custom-initialize-default
- :set (lambda (symbol value)
+ :set (lambda (_symbol value)
;; Do all fortran buffers, and the default.
(fortran-line-length value t))
:version "23.1"
@@ -488,13 +486,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 0.5% 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 +785,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 +855,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 +894,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 +909,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 +1313,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 +2204,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..c2ee1a93389
--- /dev/null
+++ b/lisp/progmodes/gdb-mi.el
@@ -0,0 +1,4205 @@
+;;; gdb-mi.el --- User Interface for running GDB
+
+;; Copyright (C) 2007-2011 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))
+
+(declare-function speedbar-change-initial-expansion-list "speedbar" (new-default))
+(declare-function speedbar-timer-fn "speedbar" ())
+(declare-function speedbar-line-text "speedbar" (&optional p))
+(declare-function speedbar-change-expand-button-char "speedbar" (char))
+(declare-function speedbar-delete-subblock "speedbar" (indent))
+(declare-function speedbar-center-buffer-smartly "speedbar" ())
+
+(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)
+ (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)
+ (when (ring-empty-p comint-input-ring) ; cf shell-mode
+ (let ((hfile (expand-file-name (or (getenv "GDBHISTFILE")
+ (if (eq system-type 'ms-dos)
+ "_gdb_history"
+ ".gdb_history"))))
+ ;; gdb defaults to 256, but we'll default to comint-input-ring-size.
+ (hsize (getenv "HISTSIZE")))
+ (dolist (file (append '("~/.gdbinit")
+ (unless (string-equal (expand-file-name ".")
+ (expand-file-name "~"))
+ '(".gdbinit"))))
+ (if (file-readable-p (setq file (expand-file-name file)))
+ (with-temp-buffer
+ (insert-file-contents file)
+ ;; TODO? check for "set history save\\( *on\\)?" and do
+ ;; not use history otherwise?
+ (while (re-search-forward
+ "^ *set history \\(filename\\|size\\) *\\(.*\\)" nil t)
+ (cond ((string-equal (match-string 1) "filename")
+ (setq hfile (expand-file-name
+ (match-string 2)
+ (file-name-directory file))))
+ ((string-equal (match-string 1) "size")
+ (setq hsize (match-string 2))))))))
+ (and (stringp hsize)
+ (integerp (setq hsize (string-to-number hsize)))
+ (> hsize 0)
+ (set (make-local-variable 'comint-input-ring-size) hsize))
+ (if (stringp hfile)
+ (set (make-local-variable 'comint-input-ring-file-name) hfile))
+ (comint-read-input-ring t)))
+ (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 (derived-mode-p '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."
+ :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-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)))
+ (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 (or func "unknown")
+ '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 ()
+ ;; 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) (derived-mode-p '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."
+ (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))
+ '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
+ (let ((map (make-sparse-keymap "Format")))
+
+ (define-key map [binary]
+ '(menu-item "Binary" gdb-memory-format-binary
+ :button (:radio . (equal gdb-memory-format "t"))))
+ (define-key map [octal]
+ '(menu-item "Octal" gdb-memory-format-octal
+ :button (:radio . (equal gdb-memory-format "o"))))
+ (define-key map [unsigned]
+ '(menu-item "Unsigned Decimal" gdb-memory-format-unsigned
+ :button (:radio . (equal gdb-memory-format "u"))))
+ (define-key map [signed]
+ '(menu-item "Signed Decimal" gdb-memory-format-signed
+ :button (:radio . (equal gdb-memory-format "d"))))
+ (define-key map [hexadecimal]
+ '(menu-item "Hexadecimal" gdb-memory-format-hexadecimal
+ :button (:radio . (equal gdb-memory-format "x"))))
+ map)
+ "Menu of display formats in the header line.")
+
+(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
+ (let ((map (make-sparse-keymap "Unit")))
+ (define-key map [giantwords]
+ '(menu-item "Giant words" gdb-memory-unit-giant
+ :button (:radio . (equal gdb-memory-unit 8))))
+ (define-key map [words]
+ '(menu-item "Words" gdb-memory-unit-word
+ :button (:radio . (equal gdb-memory-unit 4))))
+ (define-key map [halfwords]
+ '(menu-item "Halfwords" gdb-memory-unit-halfword
+ :button (:radio . (equal gdb-memory-unit 2))))
+ (define-key map [bytes]
+ '(menu-item "Bytes" gdb-memory-unit-byte
+ :button (:radio . (equal gdb-memory-unit 1))))
+ map)
+ "Menu of units in the header line.")
+
+(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."
+ (setq header-line-format gdb-memory-header)
+ (set (make-local-variable 'font-lock-defaults)
+ '(gdb-memory-font-lock-keywords))
+ '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."
+ ;; 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))
+ '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))
+ (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."
+ (setq header-line-format gdb-breakpoints-header)
+ '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."
+ (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))
+ '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."
+ (setq header-line-format gdb-locals-header)
+ '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."
+ (setq header-line-format gdb-registers-header)
+ '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)))
+ (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)
+
+;;; gdb-mi.el ends here
diff --git a/lisp/progmodes/gdb-ui.el b/lisp/progmodes/gdb-ui.el
deleted file mode 100644
index 83c9ee528f4..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, 2011
-;; 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/glasses.el b/lisp/progmodes/glasses.el
index a95d1a5c009..6792e861888 100644
--- a/lisp/progmodes/glasses.el
+++ b/lisp/progmodes/glasses.el
@@ -1,7 +1,6 @@
;;; glasses.el --- make cantReadThis readable
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Milan Zamazal <pdm@zamazal.org>
;; Maintainer: Milan Zamazal <pdm@zamazal.org>
@@ -117,6 +116,15 @@ parenthesis expression starts."
:group 'glasses
:type '(repeat regexp))
+(defcustom glasses-separate-capital-groups t
+ "If non-nil, try to separate groups of capital letters.
+When the value is non-nil, HTMLSomething and IPv6 are displayed
+as HTML_Something and I_Pv6 respectively. Set the value to nil
+if you prefer to display them unchanged."
+ :group 'glasses
+ :type 'boolean
+ :version "24.1")
+
(defcustom glasses-uncapitalize-p nil
"If non-nil, downcase embedded capital letters in identifiers.
Only identifiers starting with lower case letters are affected, letters inside
@@ -213,8 +221,11 @@ CATEGORY is the overlay category. If it is nil, use the `glasses' category."
'glasses-init))
;; Face + separator
(goto-char beg)
- (while (re-search-forward "[a-z]\\([A-Z]\\)\\|[A-Z]\\([A-Z]\\)[a-z]"
- end t)
+ (while (re-search-forward
+ (if glasses-separate-capital-groups
+ "[a-z]\\([A-Z]\\)\\|[A-Z]\\([A-Z]\\)[a-z]"
+ "[a-z]\\([A-Z]\\)")
+ end t)
(let* ((n (if (match-string 1) 1 2))
(o (glasses-make-overlay (match-beginning n) (match-end n))))
(goto-char (match-beginning n))
@@ -291,7 +302,7 @@ recognized according to the current value of the variable `glasses-separator'."
nil)
-(defun glasses-change (beg end &optional old-len)
+(defun glasses-change (beg end &optional _old-len)
"After-change function updating glass overlays."
(let ((beg-line (save-excursion (goto-char beg) (line-beginning-position)))
(end-line (save-excursion (goto-char end) (line-end-position))))
@@ -329,5 +340,4 @@ at places they belong to."
(provide 'glasses)
-;; arch-tag: a3515167-c89e-484f-90a1-d85143e52b12
;;; glasses.el ends here
diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el
index dd6dc025d5b..12295efc2d1 100644
--- a/lisp/progmodes/grep.el
+++ b/lisp/progmodes/grep.el
@@ -1,7 +1,6 @@
-;;; grep.el --- run Grep as inferior of Emacs, parse match messages
+;;; grep.el --- run `grep' and display the results
-;; Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
-;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+;; Copyright (C) 1985-1987, 1993-1999, 2001-2011
;; Free Software Foundation, Inc.
;; Author: Roland McGrath <roland@gnu.org>
@@ -34,7 +33,7 @@
(defgroup grep nil
- "Run grep as inferior of Emacs, parse error messages."
+ "Run `grep' and display the results."
:group 'tools
:group 'processes)
@@ -73,7 +72,9 @@ SYMBOL should be one of `grep-command', `grep-template',
Some grep programs are able to surround matches with special
markers in grep output. Such markers can be used to highlight
-matches in grep mode.
+matches in grep mode. This requires `font-lock-mode' to be active
+in grep buffers, so if you have globally disabled font-lock-mode,
+you will not get highlighting.
This option sets the environment variable GREP_COLORS to specify
markers for highlighting and GREP_OPTIONS to add the --color
@@ -342,13 +343,17 @@ Notice that using \\[next-error] or \\[compile-goto-error] modifies
;;;###autoload
(defconst grep-regexp-alist
- '(("^\\(.+?\\)\\(:[ \t]*\\)\\([0-9]+\\)\\2"
+ '(("^\\(.+?\\)\\(:[ \t]*\\)\\([1-9][0-9]*\\)\\2"
1 3)
;; Rule to match column numbers is commented out since no known grep
;; 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 +362,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'.")
@@ -381,37 +386,20 @@ Notice that using \\[next-error] or \\[compile-goto-error] modifies
(defvar grep-mode-font-lock-keywords
'(;; Command output lines.
- ("^\\([A-Za-z_0-9/\.+-]+\\)[ \t]*:" 1 font-lock-function-name-face)
(": \\(.+\\): \\(?:Permission denied\\|No such \\(?:file or directory\\|device or address\\)\\)$"
1 grep-error-face)
;; remove match from grep-regexp-alist before fontifying
("^Grep[/a-zA-z]* started.*"
- (0 '(face nil message nil help-echo nil mouse-face nil) t))
+ (0 '(face nil compilation-message nil help-echo nil mouse-face nil) t))
("^Grep[/a-zA-z]* finished \\(?:(\\(matches found\\))\\|with \\(no matches found\\)\\).*"
- (0 '(face nil message nil help-echo nil mouse-face nil) t)
+ (0 '(face nil compilation-message nil help-echo nil mouse-face nil) t)
(1 compilation-info-face nil t)
(2 compilation-warning-face nil t))
("^Grep[/a-zA-z]* \\(exited abnormally\\|interrupt\\|killed\\|terminated\\)\\(?:.*with code \\([0-9]+\\)\\)?.*"
- (0 '(face nil message nil help-echo nil mouse-face nil) t)
+ (0 '(face nil compilation-message nil help-echo nil mouse-face nil) t)
(1 grep-error-face)
(2 grep-error-face nil t))
- ("^.+?-[0-9]+-.*\n" (0 grep-context-face))
- ;; Highlight grep matches and delete markers
- ("\\(\033\\[01;31m\\)\\(.*?\\)\\(\033\\[[0-9]*m\\)"
- ;; Refontification does not work after the markers have been
- ;; deleted. So we use the font-lock-face property here as Font
- ;; Lock does not clear that.
- (2 (list 'face nil 'font-lock-face grep-match-face))
- ((lambda (bound))
- (progn
- ;; Delete markers with `replace-match' because it updates
- ;; the match-data, whereas `delete-region' would render it obsolete.
- (replace-match "" t t nil 3)
- (replace-match "" t t nil 1))))
- ("\\(\033\\[[0-9;]*[mK]\\)"
- ;; Delete all remaining escape sequences
- ((lambda (bound))
- (replace-match "" t t nil 1))))
+ ("^.+?-[0-9]+-.*\n" (0 grep-context-face)))
"Additional things to highlight in grep output.
This gets tacked on the end of the generated expressions.")
@@ -433,10 +421,11 @@ This variable's value takes effect when `grep-compute-defaults' is called.")
;;;###autoload
(defvar grep-find-use-xargs nil
- "Non-nil means that `grep-find' uses the `xargs' utility by default.
-If `exec', use `find -exec'.
+ "How to invoke find and grep.
+If `exec', use `find -exec {} ;'.
+If `exec-plus' use `find -exec {} +'.
If `gnu', use `find -print0' and `xargs -0'.
-Any other non-nil value means to use `find -print' and `xargs'.
+Any other value means to use `find -print' and `xargs'.
This variable's value takes effect when `grep-compute-defaults' is called.")
@@ -457,6 +446,8 @@ Set up `compilation-exit-message-function' and run `grep-setup-hook'."
(when (eq grep-highlight-matches 'auto-detect)
(grep-compute-defaults))
(unless (or (eq grep-highlight-matches 'auto-detect)
+ ;; Uses font-lock to parse color escapes. (Bug#8084)
+ (null font-lock-mode)
(null grep-highlight-matches))
;; `setenv' modifies `process-environment' let-bound in `compilation-start'
;; Any TERM except "dumb" allows GNU grep to use `--color=auto'
@@ -481,6 +472,22 @@ Set up `compilation-exit-message-function' and run `grep-setup-hook'."
(cons msg code))))
(run-hooks 'grep-setup-hook))
+(defun grep-filter ()
+ "Handle match highlighting escape sequences inserted by the grep process.
+This function is called from `compilation-filter-hook'."
+ (save-excursion
+ (let ((end (point-marker)))
+ ;; Highlight grep matches and delete marking sequences.
+ (goto-char compilation-filter-start)
+ (while (re-search-forward "\033\\[01;31m\\(.*?\\)\033\\[[0-9]*m" end 1)
+ (replace-match (propertize (match-string 1)
+ 'face nil 'font-lock-face grep-match-face)
+ t t))
+ ;; Delete all remaining escape sequences
+ (goto-char compilation-filter-start)
+ (while (re-search-forward "\033\\[[0-9;]*[mK]" end 1)
+ (replace-match "" t t)))))
+
(defun grep-probe (command args &optional func result)
(let (process-file-side-effects)
(equal (condition-case nil
@@ -552,6 +559,10 @@ Set up `compilation-exit-message-function' and run `grep-setup-hook'."
(unless grep-find-use-xargs
(setq grep-find-use-xargs
(cond
+ ((grep-probe find-program
+ `(nil nil nil ,null-device "-exec" "echo"
+ "{}" "+"))
+ 'exec-plus)
((and
(grep-probe find-program `(nil nil nil ,null-device "-print0"))
(grep-probe xargs-program `(nil nil nil "-0" "-e" "echo")))
@@ -566,13 +577,17 @@ Set up `compilation-exit-message-function' and run `grep-setup-hook'."
;; forward slashes as directory separators.
(format "%s . -type f -print0 | \"%s\" -0 -e %s"
find-program xargs-program grep-command))
- ((eq grep-find-use-xargs 'exec)
+ ((memq grep-find-use-xargs '(exec exec-plus))
(let ((cmd0 (format "%s . -type f -exec %s"
- find-program grep-command)))
+ find-program grep-command))
+ (null (if grep-use-null-device
+ (format "%s " null-device)
+ "")))
(cons
- (format "%s {} %s %s"
- cmd0 null-device
- (shell-quote-argument ";"))
+ (if (eq grep-find-use-xargs 'exec-plus)
+ (format "%s %s{} +" cmd0 null)
+ (format "%s {} %s%s" cmd0 null
+ (shell-quote-argument ";")))
(1+ (length cmd0)))))
(t
(format "%s . -type f -print | \"%s\" %s"
@@ -580,14 +595,20 @@ Set up `compilation-exit-message-function' and run `grep-setup-hook'."
(unless grep-find-template
(setq grep-find-template
(let ((gcmd (format "%s <C> %s <R>"
- grep-program grep-options)))
+ grep-program grep-options))
+ (null (if grep-use-null-device
+ (format "%s " null-device)
+ "")))
(cond ((eq grep-find-use-xargs 'gnu)
(format "%s . <X> -type f <F> -print0 | \"%s\" -0 -e %s"
find-program xargs-program gcmd))
((eq grep-find-use-xargs 'exec)
- (format "%s . <X> -type f <F> -exec %s {} %s %s"
- find-program gcmd null-device
+ (format "%s . <X> -type f <F> -exec %s {} %s%s"
+ find-program gcmd null
(shell-quote-argument ";")))
+ ((eq grep-find-use-xargs 'exec-plus)
+ (format "%s . <X> -type f <F> -exec %s %s{} +"
+ find-program gcmd null))
(t
(format "%s . <X> -type f <F> -print | \"%s\" %s"
find-program xargs-program gcmd))))))))
@@ -673,7 +694,8 @@ Set up `compilation-exit-message-function' and run `grep-setup-hook'."
grep-regexp-alist)
(set (make-local-variable 'compilation-process-setup-function)
'grep-process-setup)
- (set (make-local-variable 'compilation-disable-input) t))
+ (set (make-local-variable 'compilation-disable-input) t)
+ (add-hook 'compilation-filter-hook 'grep-filter nil t))
;;;###autoload
@@ -784,12 +806,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))))
@@ -1040,5 +1067,4 @@ file name to `*.gz', and sets `grep-highlight-matches' to `always'."
(provide 'grep)
-;; arch-tag: 5a5b9169-a79d-4f38-9c38-f69615f39c4d
;;; grep.el ends here
diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el
index 17e2143e041..f45273026b4 100644
--- a/lisp/progmodes/gud.el
+++ b/lisp/progmodes/gud.el
@@ -1,7 +1,6 @@
;;; gud.el --- Grand Unified Debugger mode for running GDB and other debuggers
-;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992-1996, 1998, 2000-2011 Free Software Foundation, Inc.
;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
;; Maintainer: FSF
@@ -43,10 +42,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 +123,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 +176,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 +243,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 +297,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 +321,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 +337,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))
@@ -412,13 +379,13 @@ step (if we're in the GUD buffer).
source file) or the source line number at the last break or step (if
we're in the GUD buffer)."
`(progn
- (defun ,func (arg)
+ (defalias ',func (lambda (arg)
,@(if doc (list doc))
(interactive "p")
(if (not gud-running)
,(if (stringp cmd)
`(gud-call ,cmd arg)
- cmd)))
+ cmd))))
,(if key `(local-set-key ,(concat "\C-c" key) ',func))
,(if key `(global-set-key (vconcat gud-key-prefix ,key) ',func))))
@@ -499,21 +466,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]))
@@ -524,7 +491,7 @@ The value t means that there is no stack, and we are in display-file mode.")
(gud-install-speedbar-variables)
(add-hook 'speedbar-load-hook 'gud-install-speedbar-variables))
-(defun gud-expansion-speedbar-buttons (directory zero)
+(defun gud-expansion-speedbar-buttons (_directory _zero)
"Wrapper for call to `speedbar-add-expansion-list'.
DIRECTORY and ZERO are not used, but are required by the caller."
(gud-speedbar-buttons gud-comint-buffer))
@@ -542,7 +509,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 +599,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,20 +656,16 @@ 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)))
-
- (setq
- ;; Append any text before the marker to the output we're going
- ;; to return - we don't include the marker in this text.
- output (concat output
- (substring gud-marker-acc 0 (match-beginning 0)))
+ (setq
+ ;; Append any text before the marker to the output we're going
+ ;; to return - we don't include the marker in this text.
+ output (concat output
+ (substring gud-marker-acc 0 (match-beginning 0)))
- ;; Set the accumulator to the remaining text.
+ ;; Set the accumulator to the remaining text.
- gud-marker-acc (substring gud-marker-acc (match-end 0)))))
+ gud-marker-acc (substring gud-marker-acc (match-end 0))))
;; Does the remaining text look like it might end with the
;; beginning of another marker? If it does, then keep it in
@@ -754,10 +717,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 +731,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)
@@ -802,7 +765,9 @@ directory and source-file directory for your debugger."
(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)
+ (add-hook 'completion-at-point-functions #'gud-gdb-completion-at-point
+ nil 'local)
+ (local-set-key "\C-i" 'completion-at-point)
(setq comint-prompt-regexp "^(.*gdb[+]?) *")
(setq paragraph-start comint-prompt-regexp)
(setq gdb-first-prompt t)
@@ -826,26 +791,28 @@ directory and source-file directory for your debugger."
;; The completion list is constructed by the process filter.
(defvar gud-gdb-fetched-lines)
-(defun gud-gdb-complete-command (&optional command a b)
- "Perform completion on the GDB command preceding point.
-This is implemented using the GDB `complete' command which isn't
-available with older versions of GDB."
- (interactive)
- (if command
- ;; Used by gud-watch in mini-buffer.
- (setq command (concat "p " command))
- ;; Used in GUD buffer.
- (let ((end (point)))
- (setq command (buffer-substring (comint-line-beginning-position) end))))
- (let* ((command-word
- ;; Find the word break. This match will always succeed.
- (and (string-match "\\(\\`\\| \\)\\([^ ]*\\)\\'" command)
- (substring command (match-beginning 2))))
- (complete-list
- (gud-gdb-run-command-fetch-lines (concat "complete " command)
+(defun gud-gdb-completions (context command)
+ "Completion table for GDB commands.
+COMMAND is the prefix for which we seek completion.
+CONTEXT is the text before COMMAND on the line."
+ (let* ((start (- (point) (field-beginning)))
+ (complete-list
+ (gud-gdb-run-command-fetch-lines (concat "complete " context command)
(current-buffer)
;; From string-match above.
- (match-beginning 2))))
+ (length context))))
+ ;; `gud-gdb-run-command-fetch-lines' has some nasty side-effects on the
+ ;; buffer (via `gud-delete-prompt-marker'): it removes the prompt and then
+ ;; re-adds it later, thus messing up markers and overlays along the way.
+ ;; This is a problem for completion-in-region which uses an overlay to
+ ;; create a field.
+ ;; So we restore completion-in-region's field if needed.
+ ;; FIXME: change gud-gdb-run-command-fetch-lines so it doesn't modify the
+ ;; buffer at all.
+ (when (/= start (- (point) (field-beginning)))
+ (dolist (ol (overlays-at (1- (point))))
+ (when (eq (overlay-get ol 'field) 'completion)
+ (move-overlay ol (- (point) start) (overlay-end ol)))))
;; Protect against old versions of GDB.
(and complete-list
(string-match "^Undefined command: \"complete\"" (car complete-list))
@@ -871,8 +838,27 @@ available with older versions of GDB."
pos (match-end 0)))
(and (= (mod count 2) 1)
(setq complete-list (list (concat str "'"))))))
- ;; Let comint handle the rest.
- (comint-dynamic-simple-complete command-word complete-list)))
+ complete-list))
+
+(defun gud-gdb-completion-at-point ()
+ "Return the data to complete the GDB command before point."
+ (let ((end (point))
+ (start
+ (save-excursion
+ (skip-chars-backward "^ " (comint-line-beginning-position))
+ (point))))
+ (list start end
+ (completion-table-dynamic
+ (apply-partially #'gud-gdb-completions
+ (buffer-substring (comint-line-beginning-position)
+ start))))))
+
+;; (defun gud-gdb-complete-command ()
+;; "Perform completion on the GDB command preceding point.
+;; This is implemented using the GDB `complete' command which isn't
+;; available with older versions of GDB."
+;; (interactive)
+;; (apply #'completion-in-region (gud-gdb-completion-at-point)))
;; The completion process filter is installed temporarily to slurp the
;; output of GDB up to the next prompt and build the completion list.
@@ -896,7 +882,7 @@ It is passed through FILTER before we look at it."
;; gdb speedbar functions
-(defun gud-gdb-goto-stackframe (text token indent)
+(defun gud-gdb-goto-stackframe (_text token _indent)
"Goto the stackframe described by TEXT, TOKEN, and INDENT."
(speedbar-with-attached-buffer
(gud-basic-call (concat "server frame " (nth 1 token)))
@@ -1086,7 +1072,7 @@ containing the executable being debugged."
directory))
:group 'gud)
-(defun gud-dbx-massage-args (file args)
+(defun gud-dbx-massage-args (_file args)
(nconc (let ((directories gud-dbx-directories)
(result nil))
(while directories
@@ -1398,7 +1384,7 @@ containing the executable being debugged."
directory))
:group 'gud)
-(defun gud-xdb-massage-args (file args)
+(defun gud-xdb-massage-args (_file args)
(nconc (let ((directories gud-xdb-directories)
(result nil))
(while directories
@@ -1462,7 +1448,7 @@ directories if your program contains sources from more than one directory."
;; History of argument lists passed to perldb.
(defvar gud-perldb-history nil)
-(defun gud-perldb-massage-args (file args)
+(defun gud-perldb-massage-args (_file args)
"Convert a command line as would be typed normally to run perldb
into one that invokes an Emacs-enabled debugging session.
\"-emacs\" is inserted where it will be $ARGV[0] (see perl5db.pl)."
@@ -2084,7 +2070,7 @@ extension EXTN. Normally EXTN is given as the regular expression
;; Change what was given in the minibuffer to something that can be used to
;; invoke the debugger.
-(defun gud-jdb-massage-args (file args)
+(defun gud-jdb-massage-args (_file args)
;; The jdb executable must have whitespace between "-classpath" and
;; its value while gud-common-init expects all switch values to
;; follow the switch keyword without intervening whitespace. We
@@ -2163,7 +2149,7 @@ relative to a classpath directory."
(setq cplist (cdr cplist)))
(if found-file (concat (car cplist) "/" filename)))))
-(defun gud-jdb-find-source (string)
+(defun gud-jdb-find-source (_string)
"Alias for function used to locate source files.
Set to `gud-jdb-find-source-using-classpath' or `gud-jdb-find-source-file'
during jdb initialization depending on the value of
@@ -2547,7 +2533,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)))
@@ -2567,7 +2553,7 @@ comint mode, which see."
(gud-set-buffer))
(defun gud-set-buffer ()
- (when (eq major-mode 'gud-mode)
+ (when (derived-mode-p 'gud-mode)
(setq gud-comint-buffer (current-buffer))))
(defvar gud-filter-defer-flag nil
@@ -2642,7 +2628,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 +2640,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 +2678,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 +2703,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 +2720,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 +2757,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 +2863,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"))))))))
@@ -3054,10 +3042,8 @@ Link exprs of the form:
(declare-function c-langelem-sym "cc-defs" (langelem))
(declare-function c-langelem-pos "cc-defs" (langelem))
-(declare-function syntax-symbol "gud" (x))
-(declare-function syntax-point "gud" (x))
-(defun gud-find-class (f line)
+(defun gud-find-class (f _line)
"Find fully qualified class in file F at line LINE.
This function uses the `gud-jdb-classpath' (and optional
`gud-jdb-sourcepath') list(s) to derive a file
@@ -3073,13 +3059,13 @@ class of the file (using s to separate nested class ids)."
(save-match-data
(let ((cplist (append gud-jdb-sourcepath gud-jdb-classpath))
(fbuffer (get-file-buffer f))
- syntax-symbol syntax-point class-found)
+ class-found
+ ;; Syntax-symbol returns the symbol of the *first* element
+ ;; in the syntactical analysis result list, syntax-point
+ ;; returns the buffer position of same
+ (syntax-symbol (lambda (x) (c-langelem-sym (car x))))
+ (syntax-point (lambda (x) (c-langelem-pos (car x)))))
(setq f (file-name-sans-extension (file-truename f)))
- ;; Syntax-symbol returns the symbol of the *first* element
- ;; in the syntactical analysis result list, syntax-point
- ;; returns the buffer position of same
- (fset 'syntax-symbol (lambda (x) (c-langelem-sym (car x))))
- (fset 'syntax-point (lambda (x) (c-langelem-pos (car x))))
;; Search through classpath list for an entry that is
;; contained in f
(while (and cplist (not class-found))
@@ -3094,6 +3080,7 @@ class of the file (using s to separate nested class ids)."
;; syntactic information chain and collect any 'inclass
;; symbols until 'topmost-intro is reached to find out if
;; point is within a nested class
+ ;; FIXME: Yuck!!! cc-mode should provide a function instead.
(if (and fbuffer (equal (symbol-file 'java-mode) "cc-mode"))
(with-current-buffer fbuffer
(let ((nclass) (syntax))
@@ -3101,17 +3088,17 @@ class of the file (using s to separate nested class ids)."
;; with the 'topmost-intro symbol, there may be
;; nested classes...
(while (not (eq 'topmost-intro
- (syntax-symbol (c-guess-basic-syntax))))
+ (funcall syntax-symbol (c-guess-basic-syntax))))
;; Check if the current position c-syntactic
;; analysis has 'inclass
(setq syntax (c-guess-basic-syntax))
(while
- (and (not (eq 'inclass (syntax-symbol syntax)))
+ (and (not (eq 'inclass (funcall syntax-symbol syntax)))
(cdr syntax))
(setq syntax (cdr syntax)))
- (if (eq 'inclass (syntax-symbol syntax))
+ (if (eq 'inclass (funcall syntax-symbol syntax))
(progn
- (goto-char (syntax-point syntax))
+ (goto-char (funcall syntax-point syntax))
;; Now we're at the beginning of a class
;; definition. Find class name
(looking-at
@@ -3120,9 +3107,9 @@ class of the file (using s to separate nested class ids)."
(append (list (match-string-no-properties 1))
nclass)))
(setq syntax (c-guess-basic-syntax))
- (while (and (not (syntax-point syntax)) (cdr syntax))
+ (while (and (not (funcall syntax-point syntax)) (cdr syntax))
(setq syntax (cdr syntax)))
- (goto-char (syntax-point syntax))
+ (goto-char (funcall syntax-point syntax))
))
(string-match (concat (car nclass) "$") class-found)
(setq class-found
@@ -3155,10 +3142,14 @@ 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
+ (when (and (> (match-beginning 0) (point-min))
+ (eq 1 (nth 7 (save-excursion
+ (syntax-ppss (1- (match-beginning 0)))))))
;; 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 +3161,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,15 +3239,8 @@ 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"
+(define-derived-mode gdb-script-mode prog-mode "GDB-Script"
"Major mode for editing GDB scripts."
(set (make-local-variable 'comment-start) "#")
(set (make-local-variable 'comment-start-skip) "#+\\s-*")
@@ -3271,10 +3254,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 +3287,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)
@@ -3379,10 +3365,8 @@ only tooltips in the buffer containing the overlay arrow."
ACTIVATEP non-nil means activate mouse motion events."
(if activatep
(progn
- (make-local-variable 'gud-tooltip-mouse-motions-active)
- (setq gud-tooltip-mouse-motions-active t)
- (make-local-variable 'track-mouse)
- (setq track-mouse t))
+ (set (make-local-variable 'gud-tooltip-mouse-motions-active) t)
+ (set (make-local-variable 'track-mouse) t))
(when gud-tooltip-mouse-motions-active
(kill-local-variable 'gud-tooltip-mouse-motions-active)
(kill-local-variable 'track-mouse))))
@@ -3433,8 +3417,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 +3428,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 +3453,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,15 +3476,15 @@ 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 gdb-macro-info
- (gdb-enqueue-input
- (list (concat
- gdb-server-prefix "macro expand " expr "\n")
- `(lambda () (gdb-tooltip-print-1 ,expr))))
- (gdb-enqueue-input
- (list (concat cmd "\n")
- `(lambda () (gdb-tooltip-print ,expr)))))
+ (if (eq gud-minor-mode 'gdbmi)
+ (if gdb-macro-info
+ (gdb-input
+ (list (concat
+ "server macro expand " expr "\n")
+ `(lambda () (gdb-tooltip-print-1 ,expr))))
+ (gdb-input
+ (list (concat cmd "\n")
+ `(lambda () (gdb-tooltip-print ,expr)))))
(setq gud-tooltip-original-filter (process-filter process))
(set-process-filter process 'gud-tooltip-process-output)
(gud-basic-call cmd))
@@ -3508,5 +3492,4 @@ so they have been disabled."))
(provide 'gud)
-;; arch-tag: 6d990948-df65-461a-be39-1c7fb83ac4c4
;;; gud.el ends here
diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el
index 01b406b1a25..48d1ac4b85e 100644
--- a/lisp/progmodes/hideif.el
+++ b/lisp/progmodes/hideif.el
@@ -1,7 +1,6 @@
;;; hideif.el --- hides selected code within ifdef
-;; Copyright (C) 1988, 1994, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1988, 1994, 2001-2011 Free Software Foundation, Inc.
;; Author: Brian Marick
;; Daniel LaLiberte <liberte@holonexus.org>
@@ -413,13 +412,14 @@ that form should be displayed.")
"Pop the next token from token-list into the let variable \"hif-token\"."
(setq hif-token (pop hif-token-list)))
-(defun hif-parse-if-exp (hif-token-list)
+(defun hif-parse-if-exp (token-list)
"Parse the TOKEN-LIST. Return translated list in prefix form."
- (hif-nexttoken)
- (prog1
- (hif-expr)
- (if hif-token ; is there still a token?
- (error "Error: unexpected token: %s" hif-token))))
+ (let ((hif-token-list token-list))
+ (hif-nexttoken)
+ (prog1
+ (hif-expr)
+ (if hif-token ; is there still a token?
+ (error "Error: unexpected token: %s" hif-token)))))
(defun hif-expr ()
"Parse an expression as found in #if.
@@ -508,7 +508,7 @@ that form should be displayed.")
;; Unary plus/minus.
((memq hif-token '(hif-minus hif-plus))
(list (prog1 hif-token (hif-nexttoken)) 0 (hif-factor)))
-
+
(t ; identifier
(let ((ident hif-token))
(if (memq ident '(or and))
@@ -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/hideshow.el b/lisp/progmodes/hideshow.el
index a3bf7e5d179..d07edd5de2f 100644
--- a/lisp/progmodes/hideshow.el
+++ b/lisp/progmodes/hideshow.el
@@ -1,7 +1,6 @@
;;; hideshow.el --- minor mode cmds to selectively display code/comment blocks
-;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-2011 Free Software Foundation, Inc.
;; Author: Thien-Thi Nguyen <ttn@gnu.org>
;; Dan Nicolaescu <dann@ics.uci.edu>
@@ -566,10 +565,9 @@ and then further adjusted to be at the end of the line."
(if comment-reg
(hs-hide-comment-region (car comment-reg) (cadr comment-reg) end)
(when (looking-at hs-block-start-regexp)
- (let* ((mdata (match-data t))
- (header-beg (match-beginning 0))
- (header-end (match-end 0))
- p q ov)
+ (let ((mdata (match-data t))
+ (header-end (match-end 0))
+ p q ov)
;; `p' is the point at the end of the block beginning, which
;; may need to be adjusted
(save-excursion
@@ -690,6 +688,8 @@ Return point, or nil if original point was not in a block."
(point)
;; look backward for the start of a block that contains the cursor
(while (and (re-search-backward hs-block-start-regexp nil t)
+ (save-match-data
+ (not (nth 4 (syntax-ppss)))) ; not inside comments
(not (setq done
(< here (save-excursion
(hs-forward-sexp (match-data t) 1)
@@ -712,10 +712,12 @@ Return point, or nil if original point was not in a block."
(forward-comment (buffer-size))
(and (< (point) maxp)
(re-search-forward hs-block-start-regexp maxp t)))
- (if (> arg 1)
- (hs-hide-level-recursive (1- arg) minp maxp)
- (goto-char (match-beginning hs-block-start-mdata-select))
- (hs-hide-block-at-point t)))
+ (when (save-match-data
+ (not (nth 4 (syntax-ppss)))) ; not inside comments
+ (if (> arg 1)
+ (hs-hide-level-recursive (1- arg) minp maxp)
+ (goto-char (match-beginning hs-block-start-mdata-select))
+ (hs-hide-block-at-point t))))
(goto-char maxp))
(defmacro hs-life-goes-on (&rest body)
@@ -965,5 +967,4 @@ Key bindings:
(provide 'hideshow)
-;; arch-tag: 378b6852-e82a-466a-aee8-d9c73859a65e
;;; hideshow.el ends here
diff --git a/lisp/progmodes/icon.el b/lisp/progmodes/icon.el
index 99e366dba25..5382ce1386d 100644
--- a/lisp/progmodes/icon.el
+++ b/lisp/progmodes/icon.el
@@ -1,7 +1,6 @@
;;; icon.el --- mode for editing Icon code
-;; Copyright (C) 1989, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1989, 2001-2011 Free Software Foundation, Inc.
;; Author: Chris Smith <csmith@convex.com>
;; Created: 15 Feb 89
@@ -131,7 +130,7 @@ when the TAB command is used."
;;;###autoload
-(defun icon-mode ()
+(define-derived-mode icon-mode prog-mode "Icon"
"Major mode for editing Icon code.
Expression and list commands understand all Icon brackets.
Tab indents for Icon code.
@@ -163,49 +162,33 @@ Variables controlling indentation style:
Turning on Icon mode calls the value of the variable `icon-mode-hook'
with no args, if that value is non-nil."
- (interactive)
- (kill-all-local-variables)
- (use-local-map icon-mode-map)
- (setq major-mode 'icon-mode)
- (setq mode-name "Icon")
- (setq local-abbrev-table icon-mode-abbrev-table)
- (set-syntax-table icon-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 'indent-line-function)
- (setq indent-line-function 'icon-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-start-skip)
- (setq comment-start-skip "# *")
- (make-local-variable 'comment-indent-function)
- (setq comment-indent-function 'icon-comment-indent)
+ :abbrev-table icon-mode-abbrev-table
+ (set (make-local-variable 'paragraph-start) (concat "$\\|" page-delimiter))
+ (set (make-local-variable 'paragraph-separate) paragraph-start)
+ (set (make-local-variable 'indent-line-function) #'icon-indent-line)
+ (set (make-local-variable 'comment-start) "# ")
+ (set (make-local-variable 'comment-end) "")
+ (set (make-local-variable 'comment-start-skip) "# *")
+ (set (make-local-variable 'comment-indent-function) 'icon-comment-indent)
(set (make-local-variable 'indent-line-function) 'icon-indent-line)
;; font-lock support
- (setq font-lock-defaults
- '((icon-font-lock-keywords
- icon-font-lock-keywords-1 icon-font-lock-keywords-2)
- nil nil ((?_ . "w")) beginning-of-defun
- ;; Obsoleted by Emacs 19.35 parse-partial-sexp's COMMENTSTOP.
- ;(font-lock-comment-start-regexp . "#")
- (font-lock-mark-block-function . mark-defun)))
+ (set (make-local-variable 'font-lock-defaults)
+ '((icon-font-lock-keywords
+ icon-font-lock-keywords-1 icon-font-lock-keywords-2)
+ nil nil ((?_ . "w")) beginning-of-defun
+ ;; Obsoleted by Emacs 19.35 parse-partial-sexp's COMMENTSTOP.
+ ;;(font-lock-comment-start-regexp . "#")
+ (font-lock-mark-block-function . mark-defun)))
;; imenu support
- (make-local-variable 'imenu-generic-expression)
- (setq imenu-generic-expression icon-imenu-generic-expression)
+ (set (make-local-variable 'imenu-generic-expression)
+ icon-imenu-generic-expression)
;; hideshow support
;; we start from the assertion that `hs-special-modes-alist' is autoloaded.
(unless (assq 'icon-mode hs-special-modes-alist)
(setq hs-special-modes-alist
(cons '(icon-mode "\\<procedure\\>" "\\<end\\>" nil
icon-forward-sexp-function)
- hs-special-modes-alist)))
- (run-mode-hooks 'icon-mode-hook))
+ hs-special-modes-alist))))
;; This is used by indent-for-comment to decide how much to
;; indent a comment in Icon code based on its context.
@@ -501,9 +484,9 @@ Returns nil if line starts inside a string, t if in a comment."
(let ((indent-stack (list nil))
(contain-stack (list (point)))
(case-fold-search nil)
- restart outer-loop-done inner-loop-done state ostate
- this-indent last-sexp last-depth
- at-else at-brace at-do
+ outer-loop-done inner-loop-done state ostate
+ this-indent last-depth
+ at-else at-brace
(opoint (point))
(next-depth 0))
(save-excursion
@@ -523,9 +506,6 @@ Returns nil if line starts inside a string, t if in a comment."
(setq state (parse-partial-sexp (point) (progn (end-of-line) (point))
nil nil state))
(setq next-depth (car state))
- (if (and (car (cdr (cdr state)))
- (>= (car (cdr (cdr state))) 0))
- (setq last-sexp (car (cdr (cdr state)))))
(if (or (nth 4 ostate))
(icon-indent-line))
(if (or (nth 3 state))
@@ -535,8 +515,6 @@ Returns nil if line starts inside a string, t if in a comment."
(setq outer-loop-done t))
(if outer-loop-done
nil
- (if (/= last-depth next-depth)
- (setq last-sexp nil))
(while (> last-depth next-depth)
(setq indent-stack (cdr indent-stack)
contain-stack (cdr contain-stack)
@@ -601,7 +579,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 +665,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 4419c59a495..a967fc03e40 100644
--- a/lisp/progmodes/idlw-complete-structtag.el
+++ b/lisp/progmodes/idlw-complete-structtag.el
@@ -1,12 +1,12 @@
;;; idlw-complete-structtag.el --- Completion of structure tags.
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 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.
@@ -166,7 +166,7 @@ an up-to-date completion list."
(defun idlwave-prepare-structure-tag-completion (var)
"Find and parse the tag list for structure tag completion."
;; This works differently in source buffers and in the shell
- (if (eq major-mode 'idlwave-shell-mode)
+ (if (derived-mode-p 'idlwave-shell-mode)
;; OK, we are in the shell, do it dynamically
(progn
(message "preparing shell tags")
@@ -224,9 +224,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 +234,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 f4095601426..7202d95c8db 100644
--- a/lisp/progmodes/idlw-help.el
+++ b/lisp/progmodes/idlw-help.el
@@ -1,12 +1,12 @@
;;; idlw-help.el --- HTML Help code for IDLWAVE
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 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.
@@ -194,8 +194,7 @@ support."
:type 'string)
(defface idlwave-help-link
- '((((class color)) (:foreground "Blue"))
- (t (:weight bold)))
+ '((t :inherit link))
"Face for highlighting links into IDLWAVE online help."
:group 'idlwave-online-help)
@@ -220,23 +219,24 @@ support."
;; Define the key bindings for the Help application
-(defvar idlwave-help-mode-map (make-sparse-keymap)
+(defvar idlwave-help-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "q" 'idlwave-help-quit)
+ (define-key map "w" 'widen)
+ (define-key map "\C-m" (lambda (arg)
+ (interactive "p")
+ (scroll-up arg)))
+ (define-key map " " 'scroll-up)
+ (define-key map [delete] 'scroll-down)
+ (define-key map "h" 'idlwave-help-find-header)
+ (define-key map "H" 'idlwave-help-find-first-header)
+ (define-key map "." 'idlwave-help-toggle-header-match-and-def)
+ (define-key map "F" 'idlwave-help-fontify)
+ (define-key map "\M-?" 'idlwave-help-return-to-calling-frame)
+ (define-key map "x" 'idlwave-help-return-to-calling-frame)
+ map)
"The keymap used in `idlwave-help-mode'.")
-(define-key idlwave-help-mode-map "q" 'idlwave-help-quit)
-(define-key idlwave-help-mode-map "w" 'widen)
-(define-key idlwave-help-mode-map "\C-m" (lambda (arg)
- (interactive "p")
- (scroll-up arg)))
-(define-key idlwave-help-mode-map " " 'scroll-up)
-(define-key idlwave-help-mode-map [delete] 'scroll-down)
-(define-key idlwave-help-mode-map "h" 'idlwave-help-find-header)
-(define-key idlwave-help-mode-map "H" 'idlwave-help-find-first-header)
-(define-key idlwave-help-mode-map "." 'idlwave-help-toggle-header-match-and-def)
-(define-key idlwave-help-mode-map "F" 'idlwave-help-fontify)
-(define-key idlwave-help-mode-map "\M-?" 'idlwave-help-return-to-calling-frame)
-(define-key idlwave-help-mode-map "x" 'idlwave-help-return-to-calling-frame)
-
;; Define the menu for the Help application
(easy-menu-define
@@ -287,7 +287,7 @@ support."
(declare-function idlwave-what-module-find-class "idlwave")
(declare-function idlwave-where "idlwave")
-(defun idlwave-help-mode ()
+(define-derived-mode idlwave-help-mode special-mode "IDLWAVE Help"
"Major mode for displaying IDL Help.
This is a VIEW mode for the ASCII version of IDL Help files,
@@ -307,11 +307,7 @@ Jump: [h] to function doclib header
Here are all keybindings.
\\{idlwave-help-mode-map}"
- (kill-all-local-variables)
(buffer-disable-undo)
- (setq major-mode 'idlwave-help-mode
- mode-name "IDLWAVE Help")
- (use-local-map idlwave-help-mode-map)
(easy-menu-add idlwave-help-menu idlwave-help-mode-map)
(setq truncate-lines t)
(setq case-fold-search t)
@@ -324,8 +320,7 @@ Here are all keybindings.
(setq buffer-read-only t)
(set (make-local-variable 'idlwave-help-def-pos) nil)
(set (make-local-variable 'idlwave-help-args) nil)
- (set (make-local-variable 'idlwave-help-in-header) nil)
- (run-hooks 'idlwave-help-mode-hook))
+ (set (make-local-variable 'idlwave-help-in-header) nil))
(defun idlwave-html-help-location ()
"Return the help directory where HTML files are, or nil if that is unknown."
@@ -575,13 +570,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 +584,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 +605,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 +626,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 +644,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 +1380,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 b92c14d61fd..93a3bf1b7f5 100644
--- a/lisp/progmodes/idlw-shell.el
+++ b/lisp/progmodes/idlw-shell.el
@@ -1,14 +1,14 @@
;; idlw-shell.el --- run IDL as an inferior process of Emacs.
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Authors: J.D. Smith <jdsmith@as.arizona.edu>
;; 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.
@@ -865,7 +865,7 @@ IDL has currently stepped.")
(defvar idlwave-shell-only-prompt-pattern nil)
(defvar tool-bar-map)
-(defun idlwave-shell-mode ()
+(define-derived-mode idlwave-shell-mode comint-mode "IDL-Shell"
"Major mode for interacting with an inferior IDL process.
1. Shell Interaction
@@ -946,28 +946,23 @@ IDL has currently stepped.")
8. Keybindings
-----------
\\{idlwave-shell-mode-map}"
-
- (interactive)
+ :abbrev-table idlwave-mode-abbrev-table
(idlwave-setup) ; Make sure config files and paths, etc. are available.
(unless (file-name-absolute-p idlwave-shell-command-history-file)
(setq idlwave-shell-command-history-file
(expand-file-name idlwave-shell-command-history-file
idlwave-config-directory)))
- ;; We don't do `kill-all-local-variables' here, because this is done by
- ;; comint
(setq comint-prompt-regexp idlwave-shell-prompt-pattern)
(setq comint-process-echoes t)
;; Can not use history expansion because "!" is used for system variables.
(setq comint-input-autoexpand nil)
-; (setq comint-input-ring-size 64)
- (make-local-variable 'comint-completion-addsuffix)
+ ;; (setq comint-input-ring-size 64)
+
(set (make-local-variable 'completion-ignore-case) t)
- (setq comint-completion-addsuffix '("/" . ""))
+ (set (make-local-variable 'comint-completion-addsuffix) '("/" . ""))
(setq comint-input-ignoredups t)
- (setq major-mode 'idlwave-shell-mode)
- (setq mode-name "IDL-Shell")
(setq idlwave-shell-mode-line-info nil)
(setq mode-line-format
'(""
@@ -1022,7 +1017,6 @@ IDL has currently stepped.")
nil 'local)
(add-hook 'kill-buffer-hook 'idlwave-shell-delete-temp-files nil 'local)
(add-hook 'kill-emacs-hook 'idlwave-shell-delete-temp-files)
- (use-local-map idlwave-shell-mode-map)
(easy-menu-add idlwave-shell-mode-menu idlwave-shell-mode-map)
;; Set the optional comint variables
@@ -1053,10 +1047,7 @@ IDL has currently stepped.")
;; with overlay-arrows.
(remove-hook 'comint-output-filter-functions 'py-pdbtrack-track-stack-file)
-
;; IDLWAVE syntax, and turn on abbreviations
- (setq local-abbrev-table idlwave-mode-abbrev-table)
- (set-syntax-table idlwave-mode-syntax-table)
(set (make-local-variable 'comment-start) ";")
(setq abbrev-mode t)
@@ -1075,8 +1066,6 @@ IDL has currently stepped.")
;; Turn off the non-debug toolbar buttons (open,save,etc.)
(set (make-local-variable 'tool-bar-map) nil)
- ;; Run the hooks.
- (run-mode-hooks 'idlwave-shell-mode-hook)
(idlwave-shell-send-command idlwave-shell-initial-commands nil 'hide)
;; Turn off IDL's ^d interpreting, and define a system
;; variable which knows the version of IDLWAVE
@@ -1457,7 +1446,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 +2168,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 +2177,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 +2199,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 +2208,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 +2386,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 +2579,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 +3631,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))
@@ -3896,7 +3883,7 @@ handled by this command."
(setq overlay-arrow-string nil)
(let (buf)
(cond
- ((eq major-mode 'idlwave-mode)
+ ((derived-mode-p 'idlwave-mode)
(save-buffer)
(setq idlwave-shell-last-save-and-action-file (buffer-file-name)))
(idlwave-shell-last-save-and-action-file
@@ -3998,8 +3985,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
@@ -4085,7 +4071,7 @@ of the form:
(defun idlwave-shell-file-name (name)
"If `idlwave-shell-use-truename' is non-nil, convert file name to true name.
Otherwise, just expand the file name."
- (let ((def-dir (if (eq major-mode 'idlwave-shell-mode)
+ (let ((def-dir (if (derived-mode-p 'idlwave-shell-mode)
default-directory
idlwave-shell-default-directory)))
(if idlwave-shell-use-truename
@@ -4348,7 +4334,7 @@ idlwave-shell-electric-debug-mode-map)
(while (setq buf (pop buffers))
(when (buffer-live-p buf)
(set-buffer buf)
- (when (and (eq major-mode 'idlwave-mode)
+ (when (and (derived-mode-p 'idlwave-mode)
buffer-file-name
idlwave-shell-electric-debug-mode)
(idlwave-shell-electric-debug-mode 0))))))
@@ -4373,51 +4359,51 @@ idlwave-shell-electric-debug-mode-map)
["Electric Debug Mode"
idlwave-shell-electric-debug-mode
:style toggle :selected idlwave-shell-electric-debug-mode
- :included (eq major-mode 'idlwave-mode) :keys "C-c C-d C-v"]
+ :included (derived-mode-p 'idlwave-mode) :keys "C-c C-d C-v"]
"--"
("Compile & Run"
["Save and .RUN" idlwave-shell-save-and-run
- (or (eq major-mode 'idlwave-mode)
+ (or (derived-mode-p 'idlwave-mode)
idlwave-shell-last-save-and-action-file)]
["Save and .COMPILE" idlwave-shell-save-and-compile
- (or (eq major-mode 'idlwave-mode)
+ (or (derived-mode-p 'idlwave-mode)
idlwave-shell-last-save-and-action-file)]
["Save and @Batch" idlwave-shell-save-and-batch
- (or (eq major-mode 'idlwave-mode)
+ (or (derived-mode-p 'idlwave-mode)
idlwave-shell-last-save-and-action-file)]
"--"
["Goto Next Error" idlwave-shell-goto-next-error t]
"--"
["Compile and Run Region" idlwave-shell-run-region
- (eq major-mode 'idlwave-mode)]
+ (derived-mode-p 'idlwave-mode)]
["Evaluate Region" idlwave-shell-evaluate-region
- (eq major-mode 'idlwave-mode)]
+ (derived-mode-p 'idlwave-mode)]
"--"
["Execute Default Cmd" idlwave-shell-execute-default-command-line t]
["Edit Default Cmd" idlwave-shell-edit-default-command-line t])
("Breakpoints"
["Set Breakpoint" idlwave-shell-break-here
- :keys "C-c C-d C-b" :active (eq major-mode 'idlwave-mode)]
+ :keys "C-c C-d C-b" :active (derived-mode-p 'idlwave-mode)]
("Set Special Breakpoint"
["Set After Count Breakpoint"
(progn
(let ((count (string-to-number (read-string "Break after count: "))))
(if (integerp count) (idlwave-shell-break-here count))))
- :active (eq major-mode 'idlwave-mode)]
+ :active (derived-mode-p 'idlwave-mode)]
["Set Condition Breakpoint"
(idlwave-shell-break-here '(4))
- :active (eq major-mode 'idlwave-mode)])
+ :active (derived-mode-p 'idlwave-mode)])
["Break in Module" idlwave-shell-break-in
- :keys "C-c C-d C-i" :active (eq major-mode 'idlwave-mode)]
+ :keys "C-c C-d C-i" :active (derived-mode-p 'idlwave-mode)]
["Break in this Module" idlwave-shell-break-this-module
- :keys "C-c C-d C-j" :active (eq major-mode 'idlwave-mode)]
+ :keys "C-c C-d C-j" :active (derived-mode-p 'idlwave-mode)]
["Clear Breakpoint" idlwave-shell-clear-current-bp t]
["Clear All Breakpoints" idlwave-shell-clear-all-bp t]
["Disable/Enable Breakpoint" idlwave-shell-toggle-enable-current-bp t]
["Goto Previous Breakpoint" idlwave-shell-goto-previous-bp
- :keys "C-c C-d [" :active (eq major-mode 'idlwave-mode)]
+ :keys "C-c C-d [" :active (derived-mode-p 'idlwave-mode)]
["Goto Next Breakpoint" idlwave-shell-goto-next-bp
- :keys "C-c C-d ]" :active (eq major-mode 'idlwave-mode)]
+ :keys "C-c C-d ]" :active (derived-mode-p 'idlwave-mode)]
["List All Breakpoints" idlwave-shell-list-all-bp t]
["Resync Breakpoints" idlwave-shell-bp-query t])
("Continue/Step"
@@ -4429,7 +4415,7 @@ idlwave-shell-electric-debug-mode-map)
["... to End of Subprog" idlwave-shell-return t]
["... to End of Subprog+1" idlwave-shell-out t]
["... to Here (Cursor Line)" idlwave-shell-to-here
- :keys "C-c C-d C-h" :active (eq major-mode 'idlwave-mode)])
+ :keys "C-c C-d C-h" :active (derived-mode-p 'idlwave-mode)])
("Examine Expressions"
["Print expression" idlwave-shell-print t]
["Help on expression" idlwave-shell-help-expression t]
@@ -4514,7 +4500,7 @@ idlwave-shell-electric-debug-mode-map)
(save-current-buffer
(dolist (buf (buffer-list))
(set-buffer buf)
- (if (eq major-mode 'idlwave-mode)
+ (if (derived-mode-p 'idlwave-mode)
(progn
(easy-menu-remove idlwave-mode-debug-menu)
(easy-menu-add idlwave-mode-debug-menu)))))))
@@ -4692,5 +4678,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 c51da854650..d4eddee9722 100644
--- a/lisp/progmodes/idlw-toolbar.el
+++ b/lisp/progmodes/idlw-toolbar.el
@@ -1,12 +1,12 @@
;;; idlw-toolbar.el --- a debugging toolbar for IDLWAVE
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; 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.
@@ -806,7 +806,7 @@ static char * file[] = {
"Goto Next Error"]
[idlwave-toolbar-stop-at-icon
idlwave-shell-break-here
- (eq major-mode 'idlwave-mode)
+ (derived-mode-p 'idlwave-mode)
"Set Breakpoint at selected position"]
[idlwave-toolbar-clear-at-icon
idlwave-shell-clear-current-bp
@@ -818,7 +818,7 @@ static char * file[] = {
"Clear all Breakpoints"]
[idlwave-toolbar-stop-beginning-icon
idlwave-shell-break-this-module
- (eq major-mode 'idlwave-mode)
+ (derived-mode-p 'idlwave-mode)
"Stop at beginning of enclosing Routine"]
[idlwave-toolbar-stop-in-icon
idlwave-shell-break-in
@@ -838,7 +838,7 @@ static char * file[] = {
"Continue Current Program"]
[idlwave-toolbar-to-here-icon
idlwave-shell-to-here
- (eq major-mode 'idlwave-mode)
+ (derived-mode-p 'idlwave-mode)
"Continue to Here (cursor position)"]
[idlwave-toolbar-step-over-icon
idlwave-shell-stepover
@@ -870,7 +870,7 @@ static char * file[] = {
"Reset IDL (RETALL & CLOSE,/ALL and more)"]
[idlwave-toolbar-electric-debug-icon
idlwave-shell-electric-debug-mode
- (eq major-mode 'idlwave-mode)
+ (derived-mode-p 'idlwave-mode)
"Toggle Electric Debug Mode"]
))
@@ -883,8 +883,7 @@ static char * file[] = {
"Add the IDLWAVE toolbar if appropriate."
(if (and (featurep 'xemacs) ; This is a noop on Emacs
(boundp 'idlwave-toolbar-is-possible)
- (or (eq major-mode 'idlwave-mode)
- (eq major-mode 'idlwave-shell-mode)))
+ (derived-mode-p 'idlwave-mode 'idlwave-shell-mode))
(set-specifier default-toolbar (cons (current-buffer)
idlwave-toolbar))))
@@ -892,8 +891,7 @@ static char * file[] = {
"Add the IDLWAVE toolbar if appropriate."
(if (and (featurep 'xemacs) ; This is a noop on Emacs
(boundp 'idlwave-toolbar-is-possible)
- (or (eq major-mode 'idlwave-mode)
- (eq major-mode 'idlwave-shell-mode)))
+ (derived-mode-p 'idlwave-mode 'idlwave-shell-mode))
(remove-specifier default-toolbar (current-buffer))))
(defvar idlwave-shell-mode-map)
@@ -970,5 +968,4 @@ static char * file[] = {
(provide 'idlw-toolbar)
(provide 'idlwave-toolbar)
-;; arch-tag: ec9a3717-c44c-4716-9bda-cdacbe5ddb62
;;; idlw-toolbar.el ends here
diff --git a/lisp/progmodes/idlwave.el b/lisp/progmodes/idlwave.el
index aaedd620e32..8066e1c3a7f 100644
--- a/lisp/progmodes/idlwave.el
+++ b/lisp/progmodes/idlwave.el
@@ -1,13 +1,12 @@
;; idlwave.el --- IDL editing mode for GNU Emacs
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Authors: J.D. Smith <jdsmith@as.arizona.edu>
;; 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 +1369,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.")
@@ -1775,7 +1775,7 @@ If NOPREFIX is non-nil, don't prepend prefix character. Installs into
(defvar idlwave-mode-debug-menu)
;;;###autoload
-(defun idlwave-mode ()
+(define-derived-mode idlwave-mode prog-mode "IDLWAVE"
"Major mode for editing IDL source files (version 6.1_em22).
The main features of this mode are
@@ -1894,21 +1894,15 @@ The main features of this mode are
followed by the key sequence to see what the key sequence does.
\\{idlwave-mode-map}"
-
- (interactive)
- (kill-all-local-variables)
-
+ :abbrev-table idlwave-mode-abbrev-table
(if idlwave-startup-message
(message "Emacs IDLWAVE mode version %s." idlwave-mode-version))
(setq idlwave-startup-message nil)
- (setq local-abbrev-table idlwave-mode-abbrev-table)
- (set-syntax-table idlwave-mode-syntax-table)
-
(set (make-local-variable 'indent-line-function) 'idlwave-indent-and-action)
- (make-local-variable idlwave-comment-indent-function)
- (set idlwave-comment-indent-function 'idlwave-comment-hook)
+ (set (make-local-variable idlwave-comment-indent-function)
+ #'idlwave-comment-hook)
(set (make-local-variable 'comment-start-skip) ";+[ \t]*")
(set (make-local-variable 'comment-start) ";")
@@ -1918,14 +1912,10 @@ The main features of this mode are
(set (make-local-variable 'indent-tabs-mode) nil)
(set (make-local-variable 'completion-ignore-case) t)
- (use-local-map idlwave-mode-map)
-
(when (featurep 'easymenu)
(easy-menu-add idlwave-mode-menu idlwave-mode-map)
(easy-menu-add idlwave-mode-debug-menu idlwave-mode-map))
- (setq mode-name "IDLWAVE")
- (setq major-mode 'idlwave-mode)
(setq abbrev-mode t)
(set (make-local-variable idlwave-fill-function) 'idlwave-auto-fill)
@@ -1990,10 +1980,7 @@ The main features of this mode are
(idlwave-new-buffer-update)
;; Check help location
- (idlwave-help-check-locations)
-
- ;; Run the mode hook
- (run-mode-hooks 'idlwave-mode-hook))
+ (idlwave-help-check-locations))
(defvar idlwave-setup-done nil)
(defun idlwave-setup ()
@@ -2096,7 +2083,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 +2138,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))
@@ -2542,7 +2529,7 @@ Point is placed at the beginning of the line whether or not this is an
actual statement."
(interactive)
(cond
- ((eq major-mode 'idlwave-shell-mode)
+ ((derived-mode-p 'idlwave-shell-mode)
(if (re-search-backward idlwave-shell-prompt-pattern nil t)
(goto-char (match-end 0))))
(t
@@ -3300,10 +3287,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 +3296,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 +3350,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 +3372,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 +3382,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 +3420,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 +3468,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 +3651,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))
@@ -3755,7 +3718,7 @@ expression to enter.
The lines containing S1 and S2 are reindented using `indent-region'
unless the optional second argument NOINDENT is non-nil."
- (if (eq major-mode 'idlwave-shell-mode)
+ (if (derived-mode-p 'idlwave-shell-mode)
;; This is a gross hack to avoit template abbrev expansion
;; in the shell. FIXME: This is a dirty hack.
(if (and (eq this-command 'self-insert-command)
@@ -3766,7 +3729,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))
@@ -5111,7 +5074,7 @@ Cache to disk for quick recovery."
(setq res nil))
(t
;; Just scan this buffer
- (if (eq major-mode 'idlwave-mode)
+ (if (derived-mode-p 'idlwave-mode)
(progn
(message "Scanning current buffer...")
(setq res (idlwave-get-routine-info-from-buffers
@@ -5165,7 +5128,7 @@ Cache to disk for quick recovery."
(defun idlwave-update-current-buffer-info (why)
"Update `idlwave-routines' for current buffer.
Can run from `after-save-hook'."
- (when (and (eq major-mode 'idlwave-mode)
+ (when (and (derived-mode-p 'idlwave-mode)
(or (eq t idlwave-auto-routine-info-updates)
(memq why idlwave-auto-routine-info-updates))
idlwave-scan-all-buffers-for-routine-info
@@ -5211,7 +5174,7 @@ Can run from `after-save-hook'."
(save-excursion
(while (setq buf (pop buffers))
(set-buffer buf)
- (if (and (eq major-mode 'idlwave-mode)
+ (if (and (derived-mode-p 'idlwave-mode)
buffer-file-name)
;; yes, this buffer has the right mode.
(progn (setq res (condition-case nil
@@ -6910,9 +6873,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.
@@ -7052,7 +7016,7 @@ sort the list before displaying."
"Call FUNCTION as a completion chooser and pass ARGS to it."
(let ((completion-ignore-case t)) ; install correct value
(apply function args))
- (if (and (eq major-mode 'idlwave-shell-mode)
+ (if (and (derived-mode-p 'idlwave-shell-mode)
(boundp 'font-lock-mode)
(not font-lock-mode))
;; For the shell, remove the fontification of the word before point
@@ -7104,10 +7068,9 @@ If these don't exist, a letter in the string is automatically selected."
;; No quick reply: Show help
(save-window-excursion
(with-output-to-temp-buffer "*Completions*"
- (mapcar (lambda(x)
- (princ (nth 1 x))
- (princ "\n"))
- keys-alist))
+ (dolist (x keys-alist)
+ (princ (nth 1 x))
+ (princ "\n")))
(setq char (read-char)))
(setq char (read-char)))
(message nil)
@@ -7453,7 +7416,7 @@ class/struct definition."
;; Read the file in temporarily
(set-buffer (get-buffer-create " *IDLWAVE-tmp*"))
(erase-buffer)
- (unless (eq major-mode 'idlwave-mode)
+ (unless (derived-mode-p 'idlwave-mode)
(idlwave-mode))
(insert-file-contents file))
(save-excursion
@@ -7681,8 +7644,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 +7652,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 +7667,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 +7690,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 +7709,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"))))
@@ -8204,8 +8168,7 @@ demand _EXTRA in the keyword list."
;; If this is the OBJ_NEW function, try to figure out the class and use
;; the keywords from the corresponding INIT method.
(if (and (equal (upcase name) "OBJ_NEW")
- (or (eq major-mode 'idlwave-mode)
- (eq major-mode 'idlwave-shell-mode)))
+ (derived-mode-p 'idlwave-mode 'idlwave-shell-mode))
(let* ((bos (save-excursion (idlwave-beginning-of-statement) (point)))
(string (buffer-substring bos (point)))
(case-fold-search t)
@@ -8301,20 +8264,26 @@ If we do not know about MODULE, just return KEYWORD literally."
;; keyword - return it as it is.
keyword))))
-(defvar idlwave-rinfo-mouse-map (make-sparse-keymap))
-(defvar idlwave-rinfo-map (make-sparse-keymap))
-(define-key idlwave-rinfo-mouse-map
- (if (featurep 'xemacs) [button2] [mouse-2])
- 'idlwave-mouse-active-rinfo)
-(define-key idlwave-rinfo-mouse-map
- (if (featurep 'xemacs) [(shift button2)] [(shift mouse-2)])
- 'idlwave-mouse-active-rinfo-shift)
-(define-key idlwave-rinfo-mouse-map
- (if (featurep 'xemacs) [button3] [mouse-3])
- 'idlwave-mouse-active-rinfo-right)
-(define-key idlwave-rinfo-mouse-map " " 'idlwave-active-rinfo-space)
-(define-key idlwave-rinfo-map "q" 'idlwave-quit-help)
-(define-key idlwave-rinfo-mouse-map "q" 'idlwave-quit-help)
+(defvar idlwave-rinfo-mouse-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map
+ (if (featurep 'xemacs) [button2] [mouse-2])
+ 'idlwave-mouse-active-rinfo)
+ (define-key map
+ (if (featurep 'xemacs) [(shift button2)] [(shift mouse-2)])
+ 'idlwave-mouse-active-rinfo-shift)
+ (define-key map
+ (if (featurep 'xemacs) [button3] [mouse-3])
+ 'idlwave-mouse-active-rinfo-right)
+ (define-key map " " 'idlwave-active-rinfo-space)
+ (define-key map "q" 'idlwave-quit-help)
+ map))
+
+(defvar idlwave-rinfo-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "q" 'idlwave-quit-help)
+ map))
+
(defvar idlwave-popup-source nil)
(defvar idlwave-rinfo-marker (make-marker))
@@ -8655,7 +8624,7 @@ was pressed."
"List the load path shadows of all routines defined in current buffer."
(interactive "P")
(idlwave-routines)
- (if (eq major-mode 'idlwave-mode)
+ (if (derived-mode-p 'idlwave-mode)
(idlwave-list-load-path-shadows
nil (idlwave-update-current-buffer-info 'save-buffer)
"in current buffer")
@@ -8825,9 +8794,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 +8838,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 +8870,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 +8885,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 +8927,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 +8951,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
@@ -9340,13 +9312,11 @@ This function was written since `list-abbrevs' looks terrible for IDLWAVE mode."
(princ "================================================\n\n")
(princ (format fmt "KEY" "ACTION" ""))
(princ (format fmt "---" "------" "")))
- (mapcar
- (lambda (list)
- (setq str (car list)
- rpl (nth 1 list)
- func (nth 2 list))
- (princ (format fmt str rpl func)))
- abbrevs)))
+ (dolist (list abbrevs)
+ (setq str (car list)
+ rpl (nth 1 list)
+ func (nth 2 list))
+ (princ (format fmt str rpl func)))))
;; Make sure each abbreviation uses only one display line
(with-current-buffer "*Help*"
(setq truncate-lines t)))
@@ -9363,5 +9333,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 3245b7dfa3e..e4e56054f9d 100644
--- a/lisp/progmodes/inf-lisp.el
+++ b/lisp/progmodes/inf-lisp.el
@@ -1,7 +1,6 @@
;;; inf-lisp.el --- an inferior-lisp mode
-;; Copyright (C) 1988, 1993, 1994, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1988, 1993-1994, 2001-2011 Free Software Foundation, Inc.
;; Author: Olin Shivers <shivers@cs.cmu.edu>
;; Keywords: processes, lisp
@@ -80,19 +79,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.
@@ -218,7 +215,7 @@ buffer with \\[set-variable].")
(put 'inferior-lisp-mode 'mode-class 'special)
-(defun inferior-lisp-mode ()
+(define-derived-mode inferior-lisp-mode comint-mode "Inferior Lisp"
"Major mode for interacting with an inferior Lisp process.
Runs a Lisp interpreter as a subprocess of Emacs, with Lisp I/O through an
Emacs buffer. Variable `inferior-lisp-program' controls which Lisp interpreter
@@ -265,18 +262,11 @@ If `comint-use-prompt-regexp' is nil (the default), \\[comint-insert-input] on o
Paragraphs are separated only by blank lines. Semicolons start comments.
If you accidentally suspend your process, use \\[comint-continue-subjob]
to continue it."
- (interactive)
- (delay-mode-hooks
- (comint-mode))
(setq comint-prompt-regexp inferior-lisp-prompt)
- (setq major-mode 'inferior-lisp-mode)
- (setq mode-name "Inferior Lisp")
(setq mode-line-process '(":%s"))
(lisp-mode-variables t)
- (use-local-map inferior-lisp-mode-map) ;c-c c-k for "kompile" file
(setq comint-get-old-input (function lisp-get-old-input))
- (setq comint-input-filter (function lisp-input-filter))
- (run-mode-hooks 'inferior-lisp-mode-hook))
+ (setq comint-input-filter (function lisp-input-filter)))
(defun lisp-get-old-input ()
"Return a string containing the sexp ending at point."
@@ -602,7 +592,7 @@ See variable `lisp-describe-sym-command'."
;; "Returns the current inferior Lisp process.
;; See variable `inferior-lisp-buffer'."
(defun inferior-lisp-proc ()
- (let ((proc (get-buffer-process (if (eq major-mode 'inferior-lisp-mode)
+ (let ((proc (get-buffer-process (if (derived-mode-p 'inferior-lisp-mode)
(current-buffer)
inferior-lisp-buffer))))
(or proc
@@ -662,5 +652,4 @@ See variable `lisp-describe-sym-command'."
(provide 'inf-lisp)
-;; arch-tag: 5b74abc3-a085-4b91-8ab8-8da6899d3b92
;;; inf-lisp.el ends here
diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el
index 3fb22d85777..a0437ccf9ae 100644
--- a/lisp/progmodes/js.el
+++ b/lisp/progmodes/js.el
@@ -1,13 +1,13 @@
;;; js.el --- Major mode for editing JavaScript
-;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Karl Landstrom <karl.landstrom@brgeight.se>
;; Daniel Colascione <dan.colascione@gmail.com>
;; 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,13 @@
;;; 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 'newcomment)
+(require 'thingatpt) ; forward-symbol etc
+(require 'imenu)
+(require 'moz nil t)
+(require 'json nil t)
(eval-when-compile
(require 'cl)
@@ -431,11 +428,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 +700,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 +722,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 +756,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 +778,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.
@@ -930,7 +934,7 @@ BEG defaults to `point-min', meaning to flush the entire cache."
(setq beg (or beg (save-restriction (widen) (point-min))))
(setq js--cache-end (min js--cache-end beg)))
-(defmacro js--debug (&rest arguments)
+(defmacro js--debug (&rest _arguments)
;; `(message ,@arguments)
)
@@ -1587,10 +1591,9 @@ will be returned."
(save-restriction
(widen)
(js--ensure-cache)
- (let* ((bound (if (eobp) (point) (1+ (point))))
- (pstate (or (save-excursion
- (js--backward-pstate))
- (list js--initial-pitem))))
+ (let ((pstate (or (save-excursion
+ (js--backward-pstate))
+ (list js--initial-pitem))))
;; Loop until we either hit a pitem at BOB or pitem ends after
;; point (or at point if we're at eob)
@@ -1653,18 +1656,18 @@ 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
- "[=(,:]\\(?:\\s-\\|\n\\)*\\(/\\)\\(?:\\\\.\\|[^/*\\]\\)\\(?:\\\\.\\|[^/\\]\\)*\\(/\\)"
+(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 +1772,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 +1790,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"))
@@ -1907,7 +1920,7 @@ the broken-down class name of the item to insert."
(let ((top-name (car name-parts))
(item-ptr items)
- new-items last-new-item new-cons item)
+ new-items last-new-item new-cons)
(js--debug "js--splice-into-items: name-parts: %S items:%S"
name-parts
@@ -2117,7 +2130,7 @@ and each value is a marker giving the location of that symbol."
with imenu-use-markers = t
for buffer being the buffers
for imenu-index = (with-current-buffer buffer
- (when (eq major-mode 'js-mode)
+ (when (derived-mode-p 'js-mode)
(js--imenu-create-index)))
do (js--imenu-to-flat imenu-index "" symbols)
finally return symbols))
@@ -2133,8 +2146,8 @@ initial input INITIAL-INPUT. Return a cons of (SYMBOL-NAME
. LOCATION), where SYMBOL-NAME is a string and LOCATION is a
marker."
(unless ido-mode
- (ido-mode t)
- (ido-mode nil))
+ (ido-mode 1)
+ (ido-mode -1))
(let ((choice (ido-completing-read
prompt
@@ -2153,12 +2166,15 @@ marker."
(setf (car bounds) (point))))
(buffer-substring (car bounds) (cdr bounds)))))
+(defvar find-tag-marker-ring) ; etags
+
(defun js-find-symbol (&optional arg)
"Read a JavaScript symbol and jump to it.
With a prefix argument, restrict symbols to those from the
current buffer. Pushes a mark onto the tag ring just like
`find-tag'."
(interactive "P")
+ (require 'etags)
(let (symbols marker)
(if (not arg)
(setq symbols (js--get-all-known-symbols))
@@ -2938,8 +2954,8 @@ browser, respectively."
;; Prime IDO
(unless ido-mode
- (ido-mode t)
- (ido-mode nil))
+ (ido-mode 1)
+ (ido-mode -1))
(with-js
(lexical-let ((tabs (js--get-tabs)) selected-tab-cname
@@ -3268,15 +3284,9 @@ 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"
- "Major mode for editing JavaScript.
-
-Key bindings:
-
-\\{js-mode-map}"
-
+(define-derived-mode js-mode prog-mode "Javascript"
+ "Major mode for editing JavaScript."
:group 'js
- :syntax-table js-mode-syntax-table
(set (make-local-variable 'indent-line-function) 'js-indent-line)
(set (make-local-variable 'beginning-of-defun-function)
@@ -3286,10 +3296,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)
@@ -3313,9 +3322,6 @@ Key bindings:
(set (make-local-variable 'imenu-create-index-function)
#'js--imenu-create-index)
- (setq major-mode 'js-mode)
- (setq mode-name "Javascript")
-
;; for filling, pretend we're cc-mode
(setq c-comment-prefix-regexp "//+\\|\\**"
c-paragraph-start "$"
@@ -3341,15 +3347,14 @@ Key bindings:
;; Important to fontify the whole buffer syntactically! If we don't,
;; then we might have regular expression literals that aren't marked
;; as strings, which will screw up parse-partial-sexp, scan-lists,
- ;; etc. and and produce maddening "unbalanced parenthesis" errors.
+ ;; etc. and produce maddening "unbalanced parenthesis" errors.
;; When we attempt to find the error and scroll to the portion of
;; the buffer containing the problem, JIT-lock will apply the
;; correct syntax to the regular expresion literal and the problem
;; will mysteriously disappear.
- (font-lock-set-defaults)
-
- (let (font-lock-keywords) ; leaves syntactic keywords intact
- (font-lock-fontify-buffer)))
+ ;; FIXME: We should actually do this fontification lazily by adding
+ ;; calls to syntax-propertize wherever it's really needed.
+ (syntax-propertize (point-max)))
;;;###autoload
(defalias 'javascript-mode 'js-mode)
@@ -3360,5 +3365,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 891aebaf808..8a8112c9655 100644
--- a/lisp/progmodes/ld-script.el
+++ b/lisp/progmodes/ld-script.el
@@ -1,7 +1,6 @@
;;; ld-script.el --- GNU linker script editing mode for Emacs
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;; Author: Masatake YAMATO<jet@gyve.org>
;; Keywords: languages, faces
@@ -76,20 +75,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 +156,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"
@@ -179,5 +166,4 @@
(provide 'ld-script)
-;; arch-tag: 83280b6b-e6fc-4d00-a630-922d7aec5593
;;; ld-script.el ends here
diff --git a/lisp/progmodes/m4-mode.el b/lisp/progmodes/m4-mode.el
index 3ddfca4d0c9..98df1c69468 100644
--- a/lisp/progmodes/m4-mode.el
+++ b/lisp/progmodes/m4-mode.el
@@ -1,7 +1,6 @@
;;; m4-mode.el --- m4 code editing commands for Emacs
-;; Copyright (C) 1996, 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1996-1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Andrew Csillag <drew_csillag@geocities.com>
;; Maintainer: Andrew Csillag <drew_csillag@geocities.com>
@@ -143,27 +142,12 @@
(switch-to-buffer-other-window "*m4-output*"))
;;;###autoload
-(defun m4-mode ()
- "A major mode to edit m4 macro files.
-\\{m4-mode-map}
-"
- (interactive)
- (kill-all-local-variables)
- (use-local-map m4-mode-map)
-
- (make-local-variable 'comment-start)
- (setq comment-start "#")
- (make-local-variable 'parse-sexp-ignore-comments)
- (setq parse-sexp-ignore-comments t)
- (setq local-abbrev-table m4-mode-abbrev-table)
-
- (make-local-variable 'font-lock-defaults)
- (setq major-mode 'm4-mode
- mode-name "m4"
- font-lock-defaults '(m4-font-lock-keywords nil)
- )
- (set-syntax-table m4-mode-syntax-table)
- (run-mode-hooks 'm4-mode-hook))
+(define-derived-mode m4-mode prog-mode "m4"
+ "A major mode to edit m4 macro files."
+ :abbrev-table m4-mode-abbrev-table
+ (set (make-local-variable 'comment-start) "#")
+ (set (make-local-variable 'parse-sexp-ignore-comments) t)
+ (set (make-local-variable 'font-lock-defaults) '(m4-font-lock-keywords nil)))
(provide 'm4-mode)
;;stuff to play with for debugging
@@ -187,5 +171,4 @@
;;; "m4_syscmd" "m4_sysval" "m4_traceoff" "m4_traceon" "m4_translit"
;;; "m4_m4_undefine" "m4_undivert"))
-;; arch-tag: 87811d86-94c1-474b-9666-587f6da74af1
;;; m4-mode.el ends here
diff --git a/lisp/progmodes/make-mode.el b/lisp/progmodes/make-mode.el
index 36130ff2f48..22e5d2f7c5c 100644
--- a/lisp/progmodes/make-mode.el
+++ b/lisp/progmodes/make-mode.el
@@ -1,7 +1,6 @@
;;; make-mode.el --- makefile editing commands for Emacs
-;; Copyright (C) 1992, 1994, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 1994, 1999-2011 Free Software Foundation, Inc.
;; Author: Thomas Neumann <tom@smart.bo.open.de>
;; Eric S. Raymond <esr@snark.thyrsus.com>
@@ -281,8 +280,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
@@ -345,7 +343,7 @@ not be enclosed in { } or ( )."
(defun makefile-make-font-lock-keywords (var keywords space
&optional negation
- &rest font-lock-keywords)
+ &rest fl-keywords)
`(;; Do macro assignments. These get the "variable-name" face.
(,makefile-macroassign-regex
(1 font-lock-variable-name-face)
@@ -395,7 +393,7 @@ not be enclosed in { } or ( )."
;; They can make a tab fail to be effective.
("^\\( +\\)\t" 1 makefile-space)))
- ,@font-lock-keywords
+ ,@fl-keywords
;; Do dependencies.
(makefile-match-dependency
@@ -493,7 +491,7 @@ not be enclosed in { } or ( )."
'("^[ \t]*\\.for[ \t].+[ \t]\\(in\\)\\>" 1 font-lock-keyword-face)))
(defconst makefile-imake-font-lock-keywords
- (append
+ (append
(makefile-make-font-lock-keywords
makefile-var-use-regex
makefile-statements
@@ -506,40 +504,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 +573,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 +702,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 +768,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 +852,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 +865,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 +943,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))))
@@ -1185,7 +1155,6 @@ The context determines which are considered."
(let* ((beg (save-excursion
(skip-chars-backward "^$(){}:#= \t\n")
(point)))
- (try (buffer-substring beg (point)))
(paren nil)
(do-macros
(save-excursion
@@ -1292,7 +1261,7 @@ definition and conveniently use this command."
;; Filling
-(defun makefile-fill-paragraph (arg)
+(defun makefile-fill-paragraph (_arg)
;; Fill comments, backslashed lines, and variable definitions
;; specially.
(save-excursion
@@ -1710,7 +1679,7 @@ Then prompts for all required parameters."
;;; Utility functions
;;; ------------------------------------------------------------
-(defun makefile-match-function-end (end)
+(defun makefile-match-function-end (_end)
"To be called as an anchored matcher by font-lock.
The anchor must have matched the opening parens in the first group."
(let ((s (match-string-no-properties 1)))
@@ -1868,5 +1837,4 @@ If it isn't in one, return nil."
(provide 'make-mode)
-;; arch-tag: bd23545a-de91-44fb-b1b2-feafbb2635a0
;;; make-mode.el ends here
diff --git a/lisp/progmodes/mantemp.el b/lisp/progmodes/mantemp.el
index ea4492053cc..c8963d2a6dd 100644
--- a/lisp/progmodes/mantemp.el
+++ b/lisp/progmodes/mantemp.el
@@ -1,7 +1,6 @@
;;; mantemp.el --- create manual template instantiations from g++ 2.7.2 output
-;; Copyright (C) 1996, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1996, 2001-2011 Free Software Foundation, Inc.
;; Author: Tom Houlder <thoulder@icor.fr>
;; Created: 10 Dec 1996
@@ -202,5 +201,4 @@ but operates on the region."
(provide 'mantemp)
-;; arch-tag: 49794712-3b1b-4baa-9785-39556cb52c94
;;; mantemp.el ends here
diff --git a/lisp/progmodes/meta-mode.el b/lisp/progmodes/meta-mode.el
index 03274746b40..b36104bf49b 100644
--- a/lisp/progmodes/meta-mode.el
+++ b/lisp/progmodes/meta-mode.el
@@ -1,7 +1,6 @@
;;; meta-mode.el --- major mode for editing Metafont or MetaPost sources
-;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Ulrik Vieth <vieth@thphy.uni-duesseldorf.de>
;; Version: 1.0
@@ -474,6 +473,7 @@ If the list was changed, sort the list and remove duplicates first."
(defun meta-complete-symbol ()
"Perform completion on Metafont or MetaPost symbol preceding point."
+ ;; FIXME: Use completion-at-point-functions.
(interactive "*")
(let ((list meta-complete-list)
entry)
@@ -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)
@@ -845,11 +844,10 @@ The environment marked is the one that contains point or follows point."
;;; Syntax table, keymap and menu.
-(defvar meta-mode-abbrev-table nil
+(define-abbrev-table 'meta-mode-abbrev-table ()
"Abbrev table used in Metafont or MetaPost mode.")
-(define-abbrev-table 'meta-mode-abbrev-table ())
-(defvar meta-mode-syntax-table
+(defvar meta-common-mode-syntax-table
(let ((st (make-syntax-table)))
;; underscores are word constituents
(modify-syntax-entry ?_ "w" st)
@@ -886,9 +884,8 @@ The environment marked is the one that contains point or follows point."
st)
"Syntax table used in Metafont or MetaPost mode.")
-(defvar meta-mode-map
+(defvar meta-common-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "\C-m" 'reindent-then-newline-and-indent)
;; Comment Paragraphs:
;; (define-key map "\M-a" 'backward-sentence)
;; (define-key map "\M-e" 'forward-sentence)
@@ -916,10 +913,10 @@ The environment marked is the one that contains point or follows point."
;; (define-key map "\C-c\C-l" 'meta-recenter-output)
map)
"Keymap used in Metafont or MetaPost mode.")
-
+(define-obsolete-variable-alias 'meta-mode-map 'meta-common-mode-map "24.1")
(easy-menu-define
- meta-mode-menu meta-mode-map
+ meta-mode-menu meta-common-mode-map
"Menu used in Metafont or MetaPost mode."
(list "Meta"
["Forward Environment" meta-beginning-of-defun t]
@@ -955,21 +952,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)
@@ -977,106 +974,62 @@ The environment marked is the one that contains point or follows point."
;;; Initialization.
-(defun meta-common-initialization ()
+(define-derived-mode meta-common-mode prog-mode "-Meta-common-"
"Common initialization for Metafont or MetaPost mode."
- (kill-all-local-variables)
-
- (make-local-variable 'paragraph-start)
- (make-local-variable 'paragraph-separate)
- (setq paragraph-start
- (concat page-delimiter "\\|$"))
- (setq paragraph-separate
- (concat page-delimiter "\\|$"))
-
- (make-local-variable 'paragraph-ignore-fill-prefix)
- (setq paragraph-ignore-fill-prefix t)
-
- (make-local-variable 'comment-start-skip)
- (make-local-variable 'comment-start)
- (make-local-variable 'comment-end)
- (make-local-variable 'comment-multi-line)
- (setq comment-start-skip "%+[ \t\f]*")
- (setq comment-start "%")
- (setq comment-end "")
- (setq comment-multi-line nil)
+ :abbrev-table meta-mode-abbrev-table
+ (set (make-local-variable 'paragraph-start)
+ (concat page-delimiter "\\|$"))
+ (set (make-local-variable 'paragraph-separate)
+ (concat page-delimiter "\\|$"))
+
+ (set (make-local-variable 'paragraph-ignore-fill-prefix) t)
+
+ (set (make-local-variable 'comment-start-skip) "%+[ \t\f]*")
+ (set (make-local-variable 'comment-start) "%")
+ (set (make-local-variable 'comment-end) "")
+ (set (make-local-variable 'comment-multi-line) nil)
;; We use `back-to-indentation' but \f is no indentation sign.
(modify-syntax-entry ?\f "_ ")
- (make-local-variable 'parse-sexp-ignore-comments)
- (setq parse-sexp-ignore-comments t)
+ (set (make-local-variable 'parse-sexp-ignore-comments) t)
- (make-local-variable 'comment-indent-function)
- (setq comment-indent-function 'meta-comment-indent)
- (make-local-variable 'indent-line-function)
- (setq indent-line-function 'meta-indent-line)
+ (set (make-local-variable 'comment-indent-function) #'meta-comment-indent)
+ (set (make-local-variable 'indent-line-function) #'meta-indent-line)
;; No need to define a mode-specific 'indent-region-function.
;; Simply use the generic 'indent-region and 'comment-region.
;; Set defaults for font-lock mode.
- (make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults
- '(meta-font-lock-keywords
- nil nil ((?_ . "w")) nil
- (font-lock-comment-start-regexp . "%")))
+ (set (make-local-variable 'font-lock-defaults)
+ '(meta-font-lock-keywords
+ nil nil ((?_ . "w")) nil
+ (font-lock-comment-start-regexp . "%")))
;; Activate syntax table, keymap and menu.
- (setq local-abbrev-table meta-mode-abbrev-table)
- (set-syntax-table meta-mode-syntax-table)
- (use-local-map meta-mode-map)
- (easy-menu-add meta-mode-menu)
- )
+ (easy-menu-add meta-mode-menu))
;;;###autoload
-(defun metafont-mode ()
- "Major mode for editing Metafont sources.
-Special commands:
-\\{meta-mode-map}
-
-Turning on Metafont mode calls the value of the variables
-`meta-common-mode-hook' and `metafont-mode-hook'."
- (interactive)
- (meta-common-initialization)
- (setq mode-name "Metafont")
- (setq major-mode 'metafont-mode)
-
+(define-derived-mode metafont-mode meta-common-mode "Metafont"
+ "Major mode for editing Metafont sources."
;; Set defaults for completion function.
- (make-local-variable 'meta-symbol-list)
- (make-local-variable 'meta-symbol-changed)
- (make-local-variable 'meta-complete-list)
- (setq meta-symbol-list nil)
- (setq meta-symbol-changed nil)
+ (set (make-local-variable 'meta-symbol-list) nil)
+ (set (make-local-variable 'meta-symbol-changed) nil)
(apply 'meta-add-symbols metafont-symbol-list)
- (setq meta-complete-list
+ (set (make-local-variable 'meta-complete-list)
(list (list "\\<\\(\\sw+\\)" 1 'meta-symbol-list)
- (list "" 'ispell-complete-word)))
- (run-mode-hooks 'meta-common-mode-hook 'metafont-mode-hook))
+ (list "" 'ispell-complete-word))))
;;;###autoload
-(defun metapost-mode ()
- "Major mode for editing MetaPost sources.
-Special commands:
-\\{meta-mode-map}
-
-Turning on MetaPost mode calls the value of the variable
-`meta-common-mode-hook' and `metafont-mode-hook'."
- (interactive)
- (meta-common-initialization)
- (setq mode-name "MetaPost")
- (setq major-mode 'metapost-mode)
-
+(define-derived-mode metapost-mode meta-common-mode "MetaPost"
+ "Major mode for editing MetaPost sources."
;; Set defaults for completion function.
- (make-local-variable 'meta-symbol-list)
- (make-local-variable 'meta-symbol-changed)
- (make-local-variable 'meta-complete-list)
- (setq meta-symbol-list nil)
- (setq meta-symbol-changed nil)
+ (set (make-local-variable 'meta-symbol-list) nil)
+ (set (make-local-variable 'meta-symbol-changed) nil)
(apply 'meta-add-symbols metapost-symbol-list)
- (setq meta-complete-list
+ (set (make-local-variable 'meta-complete-list)
(list (list "\\<\\(\\sw+\\)" 1 'meta-symbol-list)
- (list "" 'ispell-complete-word)))
- (run-mode-hooks 'meta-common-mode-hook 'metapost-mode-hook))
+ (list "" 'ispell-complete-word))))
;;; Just in case ...
@@ -1084,5 +1037,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 013cb7a5e69..bf5662cdfa3 100644
--- a/lisp/progmodes/mixal-mode.el
+++ b/lisp/progmodes/mixal-mode.el
@@ -1,13 +1,12 @@
;;; mixal-mode.el --- Major mode for the mix asm language.
-;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2003-2011 Free Software Foundation, Inc.
;; Author: Pieter E.J. Pareit <pieter.pareit@gmail.com>
;; 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 +88,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 +124,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 +1027,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]+\\)"
@@ -1105,27 +1105,18 @@ Assumes that file has been compiled with debugging support."
;;;###autoload
(define-derived-mode mixal-mode fundamental-mode "mixal"
- "Major mode for the mixal asm language.
-\\{mixal-mode-map}"
+ "Major mode for the mixal asm language."
(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 "
- buffer-file-name))
- ;; mixasm will do strange when there is no final newline,
- ;; so let Emacs ensure that it is always there
- (set (make-local-variable 'require-final-newline)
- mode-require-final-newline))
-
-;;;###autoload
-(add-to-list 'auto-mode-alist '("\\.mixal\\'" . mixal-mode))
+ buffer-file-name)))
(provide 'mixal-mode)
-;; arch-tag: be7c128a-bf61-4951-a90e-9398267ce3f3
;;; mixal-mode.el ends here
diff --git a/lisp/progmodes/modula2.el b/lisp/progmodes/modula2.el
index 9d226cefbd4..f0b8f7cbca7 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,21 @@ 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 +408,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 +552,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 ()
@@ -564,5 +613,4 @@ FROM SysStreams IMPORT sysIn, sysOut, sysErr;
(provide 'modula2)
-;; arch-tag: a21df1cb-5ece-4709-9219-1e7cd2d85d90
;;; modula2.el ends here
diff --git a/lisp/progmodes/octave-inf.el b/lisp/progmodes/octave-inf.el
index abd7ca70613..803a542563c 100644
--- a/lisp/progmodes/octave-inf.el
+++ b/lisp/progmodes/octave-inf.el
@@ -1,12 +1,12 @@
;;; octave-inf.el --- running Octave as an inferior Emacs process
-;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Kurt Hornik <Kurt.Hornik@wu-wien.ac.at>
;; 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.
@@ -73,10 +73,7 @@ mode, set this to (\"-q\" \"--traditional\")."
"Keymap used in Inferior Octave mode.")
(defvar inferior-octave-mode-syntax-table
- (let ((table (make-syntax-table)))
- (modify-syntax-entry ?\` "w" table)
- (modify-syntax-entry ?\# "<" table)
- (modify-syntax-entry ?\n ">" table)
+ (let ((table (make-syntax-table octave-mode-syntax-table)))
table)
"Syntax table in use in inferior-octave-mode buffers.")
@@ -115,39 +112,33 @@ the regular expression `comint-prompt-regexp', a buffer local variable."
"Non-nil means that Octave has built-in variables.")
(defvar inferior-octave-dynamic-complete-functions
- '(inferior-octave-complete comint-dynamic-complete-filename)
+ '(inferior-octave-completion-at-point comint-filename-completion)
"List of functions called to perform completion for inferior Octave.
This variable is used to initialize `comint-dynamic-complete-functions'
in the Inferior Octave buffer.")
-(defun inferior-octave-mode ()
+(defvar info-lookup-mode)
+
+(define-derived-mode inferior-octave-mode comint-mode "Inferior Octave"
"Major mode for interacting with an inferior Octave process.
Runs Octave as a subprocess of Emacs, with Octave I/O through an Emacs
buffer.
Entry to this mode successively runs the hooks `comint-mode-hook' and
`inferior-octave-mode-hook'."
- (interactive)
- (delay-mode-hooks (comint-mode))
(setq comint-prompt-regexp inferior-octave-prompt
- major-mode 'inferior-octave-mode
- mode-name "Inferior Octave"
mode-line-process '(":%s")
local-abbrev-table octave-abbrev-table)
- (use-local-map inferior-octave-mode-map)
- (set-syntax-table inferior-octave-mode-syntax-table)
- (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 octave-comment-start-skip)
+ (set (make-local-variable 'comment-start) octave-comment-start)
+ (set (make-local-variable 'comment-end) "")
+ (set (make-local-variable 'comment-column) 32)
+ (set (make-local-variable 'comment-start-skip) octave-comment-start-skip)
- (make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults '(inferior-octave-font-lock-keywords nil nil))
+ (set (make-local-variable 'font-lock-defaults)
+ '(inferior-octave-font-lock-keywords nil nil))
+
+ (set (make-local-variable 'info-lookup-mode) 'octave-mode)
(setq comint-input-ring-file-name
(or (getenv "OCTAVE_HISTFILE") "~/.octave_hist")
@@ -156,9 +147,7 @@ Entry to this mode successively runs the hooks `comint-mode-hook' and
inferior-octave-dynamic-complete-functions)
(add-hook 'comint-input-filter-functions
'inferior-octave-directory-tracker nil t)
- (comint-read-input-ring t)
-
- (run-mode-hooks 'inferior-octave-mode-hook))
+ (comint-read-input-ring t))
;;;###autoload
(defun inferior-octave (&optional arg)
@@ -271,40 +260,38 @@ startup file, `~/.emacs-octave'."
(inferior-octave-resync-dirs)))
+(defun inferior-octave-completion-at-point ()
+ "Return the data to complete the Octave symbol at point."
+ (let* ((end (point))
+ (start
+ (save-excursion
+ (skip-syntax-backward "w_" (comint-line-beginning-position))
+ (point))))
+ (cond (inferior-octave-complete-impossible nil)
+ ((eq start end) nil)
+ (t
+ (list
+ start end
+ (completion-table-dynamic
+ (lambda (command)
+ (inferior-octave-send-list-and-digest
+ (list (concat "completion_matches (\"" command "\");\n")))
+ (sort (delete-dups inferior-octave-output-list)
+ 'string-lessp))))))))
+
(defun inferior-octave-complete ()
"Perform completion on the Octave symbol preceding point.
This is implemented using the Octave command `completion_matches' which
is NOT available with versions of Octave prior to 2.0."
(interactive)
- (let* ((end (point))
- (command
- (save-excursion
- (skip-syntax-backward "w_" (comint-line-beginning-position))
- (buffer-substring-no-properties (point) end)))
- (proc (get-buffer-process inferior-octave-buffer)))
- (cond (inferior-octave-complete-impossible
- (error (concat
- "Your Octave does not have `completion_matches'. "
- "Please upgrade to version 2.X.")))
- ((string-equal command "")
- (message "Cannot complete an empty string"))
- (t
- (inferior-octave-send-list-and-digest
- (list (concat "completion_matches (\"" command "\");\n")))
- ;; Sort the list
- (setq inferior-octave-output-list
- (sort inferior-octave-output-list 'string-lessp))
- ;; Remove duplicates
- (let* ((x inferior-octave-output-list)
- (y (cdr x)))
- (while y
- (if (string-equal (car x) (car y))
- (setcdr x (setq y (cdr y)))
- (setq x y
- y (cdr y)))))
- ;; And let comint handle the rest
- (comint-dynamic-simple-complete
- command inferior-octave-output-list)))))
+ (if inferior-octave-complete-impossible
+ (error (concat
+ "Your Octave does not have `completion_matches'. "
+ "Please upgrade to version 2.X."))
+ (let ((data (inferior-octave-completion-at-point)))
+ (if (null data)
+ (message "Cannot complete an empty string")
+ (apply #'completion-in-region data)))))
(defun inferior-octave-dynamic-list-input-ring ()
"List the buffer's input history in a help buffer."
@@ -348,7 +335,7 @@ Ring Emacs bell if process output starts with an ASCII bell, and pass
the rest to `comint-output-filter'."
(comint-output-filter proc (inferior-octave-strip-ctrl-g string)))
-(defun inferior-octave-output-digest (proc string)
+(defun inferior-octave-output-digest (_proc string)
"Special output filter for the inferior Octave process.
Save all output between newlines into `inferior-octave-output-list', and
the rest to `inferior-octave-output-string'."
@@ -402,5 +389,4 @@ directory and makes this the current buffer's default directory."
(provide 'octave-inf)
-;; arch-tag: bdce0395-24d1-4bb4-bfba-6fb1eeb1a660
;;; octave-inf.el ends here
diff --git a/lisp/progmodes/octave-mod.el b/lisp/progmodes/octave-mod.el
index e467ca08929..39d997e1d5e 100644
--- a/lisp/progmodes/octave-mod.el
+++ b/lisp/progmodes/octave-mod.el
@@ -1,10 +1,9 @@
;;; octave-mod.el --- editing Octave source files under Emacs
-;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2001-2011 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 +91,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.")
@@ -151,8 +150,8 @@ All Octave abbrevs start with a grave accent (`)."
"Builtin variables in Octave.")
(defvar octave-function-header-regexp
- (concat "^\\s-*\\<\\(function\\)\\>"
- "\\([^=;\n]*=[ \t]*\\|[ \t]*\\)\\(\\w+\\)\\>")
+ (concat "^\\s-*\\_<\\(function\\)\\_>"
+ "\\([^=;\n]*=[ \t]*\\|[ \t]*\\)\\(\\(?:\\w\\|\\s_\\)+\\)\\_>")
"Regexp to match an Octave function header.
The string `function' and its name are given by the first and third
parenthetical grouping.")
@@ -160,10 +159,10 @@ parenthetical grouping.")
(defvar octave-font-lock-keywords
(list
;; Fontify all builtin keywords.
- (cons (concat "\\<\\("
- (mapconcat 'identity octave-reserved-words "\\|")
- (mapconcat 'identity octave-text-functions "\\|")
- "\\)\\>")
+ (cons (concat "\\_<\\("
+ (regexp-opt (append octave-reserved-words
+ octave-text-functions))
+ "\\)\\_>")
'font-lock-keyword-face)
;; Fontify all builtin operators.
(cons "\\(&\\||\\|<=\\|>=\\|==\\|<\\|>\\|!=\\|!\\)"
@@ -171,9 +170,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 +178,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,31 +211,19 @@ 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-h" 'info-lookup-symbol)
(define-key map "\C-c\C-il" 'octave-send-line)
(define-key map "\C-c\C-ib" 'octave-send-block)
(define-key map "\C-c\C-if" 'octave-send-defun)
@@ -234,7 +242,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 +253,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 +269,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)))
@@ -295,64 +299,34 @@ parenthetical grouping.")
;; Was "w" for abbrevs, but now that it's not necessary any more,
(modify-syntax-entry ?\` "." table)
(modify-syntax-entry ?\" "\"" table)
- (modify-syntax-entry ?. "w" table)
- (modify-syntax-entry ?_ "w" table)
- (modify-syntax-entry ?\% "<" table)
- (modify-syntax-entry ?\# "<" 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 +335,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 +377,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 +553,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,56 +600,63 @@ 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)
- (octave-initialize-completions)
- (run-mode-hooks 'octave-mode-hook))
+
+ (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))
+
+(defvar info-lookup-mode)
(defun octave-help ()
"Get help on Octave symbols from the Octave info files.
@@ -542,74 +665,26 @@ 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
- (nth 4 (parse-partial-sexp (line-beginning-position) (point)))))
+ (nth 4 (syntax-ppss)))
(defsubst octave-in-string-p ()
"Return t if point is inside an Octave string."
- (interactive)
- (save-excursion
- (nth 3 (parse-partial-sexp (line-beginning-position) (point)))))
+ (nth 3 (syntax-ppss)))
(defsubst octave-not-in-string-or-comment-p ()
"Return t if point is not inside an Octave string or comment."
- (let ((pps (parse-partial-sexp (line-beginning-position) (point))))
+ (let ((pps (syntax-ppss)))
(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
@@ -618,148 +693,8 @@ the end keyword."
nil
(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 +710,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 +796,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 +830,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 ()
@@ -1152,82 +893,74 @@ otherwise."
(setq give-up t))))
(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)))
+(defun octave-fill-paragraph (&optional _arg)
+ "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 +969,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 (skip-syntax-backward "w_") (point)))
+ (end (point)))
+ (if (< beg (point))
+ ;; Extend region past point, if applicable.
+ (save-excursion (skip-syntax-forward "w_")
+ (setq 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 +1012,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 +1099,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 +1148,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 +1161,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 9a2813cd0fb..e28bb14bb9a 100644
--- a/lisp/progmodes/pascal.el
+++ b/lisp/progmodes/pascal.el
@@ -1,8 +1,6 @@
-;;; pascal.el --- major mode for editing pascal source in Emacs
+;;; pascal.el --- major mode for editing pascal source in Emacs -*- lexical-binding: t -*-
-;; Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1993-2011 Free Software Foundation, Inc.
;; Author: Espen Skoglund <esk@gnu.org>
;; Keywords: languages
@@ -78,8 +76,9 @@
(define-key map ":" 'electric-pascal-colon)
(define-key map "=" 'electric-pascal-equal)
(define-key map "#" 'electric-pascal-hash)
- (define-key map "\r" 'electric-pascal-terminate-line)
- (define-key map "\t" 'electric-pascal-tab)
+ ;; These are user preferences, so not to set by default.
+ ;;(define-key map "\r" 'electric-pascal-terminate-line)
+ ;;(define-key map "\t" 'electric-pascal-tab)
(define-key map "\M-\t" 'pascal-complete-word)
(define-key map "\M-?" 'pascal-show-completions)
(define-key map "\177" 'backward-delete-char-untabify)
@@ -223,7 +222,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 +273,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 +287,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 +295,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 +322,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 +395,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 +714,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 +986,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 +1033,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 +1060,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 +1124,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 +1141,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 +1193,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 +1251,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 +1451,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 +1464,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 +1472,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 +1518,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 +1540,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 d954dc7278e..8ca8c690f92 100644
--- a/lisp/progmodes/perl-mode.el
+++ b/lisp/progmodes/perl-mode.el
@@ -1,7 +1,6 @@
;;; perl-mode.el --- Perl code editing commands for GNU Emacs
-;; Copyright (C) 1990, 1994, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990, 1994, 2001-2011 Free Software Foundation, Inc.
;; Author: William F. Mann
;; Maintainer: FSF
@@ -167,7 +166,7 @@ The expansion is entirely correct because it uses the C preprocessor."
'(;; Functions
(nil "^sub\\s-+\\([-A-Za-z0-9+_:]+\\)" 1)
;;Variables
- ("Variables" "^\\([$@%][-A-Za-z0-9+_:]+\\)\\s-*=" 1)
+ ("Variables" "^\\(?:my\\|our\\)\\s-+\\([$@%][-A-Za-z0-9+_:]+\\)\\s-*=" 1)
("Packages" "^package\\s-+\\([-A-Za-z0-9+_:]+\\);" 1)
("Doc sections" "^=head[0-9][ \t]+\\(.*\\)" 1))
"Imenu generic expression for Perl mode. See `imenu-generic-expression'.")
@@ -250,59 +249,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 +342,125 @@ 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 ((startpos (point))
+ (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)
+ ;; In case of error, make sure we don't move backward.
+ (scan-error (goto-char startpos) 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."
@@ -495,7 +546,7 @@ create a new comment."
"Normal hook to run when entering Perl mode.")
;;;###autoload
-(defun perl-mode ()
+(define-derived-mode perl-mode prog-mode "Perl"
"Major mode for editing Perl code.
Expression and list commands understand all Perl brackets.
Tab indents for Perl code.
@@ -542,49 +593,34 @@ Various indentation styles: K&R BSD BLK GNU LW
perl-label-offset -5 -8 -2 -2 -2
Turning on Perl mode runs the normal hook `perl-mode-hook'."
- (interactive)
- (kill-all-local-variables)
- (use-local-map perl-mode-map)
- (setq major-mode 'perl-mode)
- (setq mode-name "Perl")
- (setq local-abbrev-table perl-mode-abbrev-table)
- (set-syntax-table perl-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 'perl-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-start-skip)
- (setq comment-start-skip "\\(^\\|\\s-\\);?#+ *")
- (make-local-variable 'comment-indent-function)
- (setq comment-indent-function 'perl-comment-indent)
- (make-local-variable 'parse-sexp-ignore-comments)
- (setq parse-sexp-ignore-comments t)
+ :abbrev-table perl-mode-abbrev-table
+ (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 'indent-line-function) #'perl-indent-line)
+ (set (make-local-variable 'comment-start) "# ")
+ (set (make-local-variable 'comment-end) "")
+ (set (make-local-variable 'comment-start-skip) "\\(^\\|\\s-\\);?#+ *")
+ (set (make-local-variable 'comment-indent-function) #'perl-comment-indent)
+ (set (make-local-variable 'parse-sexp-ignore-comments) t)
;; Tell font-lock.el how to handle Perl.
(setq font-lock-defaults '((perl-font-lock-keywords
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)
(setq imenu-case-fold-search nil)
;; Setup outline-minor-mode.
(set (make-local-variable 'outline-regexp) perl-outline-regexp)
- (set (make-local-variable 'outline-level) 'perl-outline-level)
- (run-mode-hooks 'perl-mode-hook))
+ (set (make-local-variable 'outline-level) 'perl-outline-level))
;; This is used by indent-for-comment
;; to decide how much to indent a comment in Perl code
@@ -826,7 +862,7 @@ Optional argument PARSE-START should be the position of `beginning-of-defun'."
;; );
(progn
(skip-syntax-backward "(")
- (condition-case err
+ (condition-case nil
(while (save-excursion
(skip-syntax-backward " ") (not (bolp)))
(forward-sexp -1))
@@ -867,9 +903,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 +963,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 +1061,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 5c96253f6be..283919c131e 100644
--- a/lisp/progmodes/prolog.el
+++ b/lisp/progmodes/prolog.el
@@ -1,10 +1,17 @@
-;;; prolog.el --- major mode for editing and running Prolog under Emacs
+;;; prolog.el --- major mode for editing and running Prolog (and Mercury) code
-;; Copyright (C) 1986, 1987, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1986-1987, 1997-1999, 2002-2003, 2011
+;; Free Software Foundation, Inc.
-;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp>
-;; Keywords: languages
+;; Authors: Emil strm <emil_astrom(at)hotmail(dot)com>
+;; Milan Zamazal <pdm(at)freesoft(dot)cz>
+;; Stefan Bruda <stefan(at)bruda(dot)ca>
+;; * See below for more details
+;; Maintainer: Stefan Bruda <stefan(at)bruda(dot)ca>
+;; Keywords: prolog major mode sicstus swi mercury
+
+(defvar prolog-mode-version "1.22"
+ "Prolog mode version number.")
;; This file is part of GNU Emacs.
@@ -21,395 +28,4127 @@
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+;; Original author: Masanobu UMEDA <umerin(at)mse(dot)kyutech(dot)ac(dot)jp>
+;; Parts of this file was taken from a modified version of the original
+;; by Johan Andersson, Peter Olin, Mats Carlsson, Johan Bevemyr, Stefan
+;; Andersson, and Per Danielsson (all SICS people), and Henrik Bkman
+;; at Uppsala University, Sweden.
+;;
+;; Some ideas and also a few lines of code have been borrowed (not stolen ;-)
+;; from Oz.el, the Emacs major mode for the Oz programming language,
+;; Copyright (C) 1993 DFKI GmbH, Germany, with permission.
+;; Authors: Ralf Scheidhauer and Michael Mehl ([scheidhr|mehl](at)dfki(dot)uni-sb(dot)de)
+;;
+;; More ideas and code have been taken from the SICStus debugger mode
+;; (http://www.csd.uu.se/~perm/source_debug/index.shtml -- broken link
+;; as of Mon May 5 08:23:48 EDT 2003) by Per Mildner.
+;;
+;; Additions for ECLiPSe and other helpful suggestions: Stephan Heuel
+;; <heuel(at)ipb(dot)uni-bonn(dot)de>
+
;;; Commentary:
+;;
+;; This package provides a major mode for editing Prolog code, with
+;; all the bells and whistles one would expect, including syntax
+;; highlighting and auto indentation. It can also send regions to an
+;; inferior Prolog process.
+;;
+;; The code requires the comint, easymenu, info, imenu, and font-lock
+;; libraries. These are normally distributed with GNU Emacs and
+;; XEmacs.
+
+;;; Installation:
+;;
+;; Insert the following lines in your init file--typically ~/.emacs
+;; (GNU Emacs and XEmacs <21.4), or ~/.xemacs/init.el (XEmacs
+;; 21.4)--to use this mode when editing Prolog files under Emacs:
+;;
+;; (setq load-path (cons "/usr/lib/xemacs/site-lisp" load-path))
+;; (autoload 'run-prolog "prolog" "Start a Prolog sub-process." t)
+;; (autoload 'prolog-mode "prolog" "Major mode for editing Prolog programs." t)
+;; (autoload 'mercury-mode "prolog" "Major mode for editing Mercury programs." t)
+;; (setq prolog-system 'swi) ; optional, the system you are using;
+;; ; see `prolog-system' below for possible values
+;; (setq auto-mode-alist (append '(("\\.pl$" . prolog-mode)
+;; ("\\.m$" . mercury-mode))
+;; auto-mode-alist))
+;;
+;; where the path in the first line is the file system path to this file.
+;; MSDOS paths can be written like "d:/programs/emacs-19.34/site-lisp".
+;; Note: In XEmacs, either `/usr/lib/xemacs/site-lisp' (RPM default in
+;; Red Hat-based distributions) or `/usr/local/lib/xemacs/site-lisp'
+;; (default when compiling from sources) are automatically added to
+;; `load-path', so the first line is not necessary provided that you
+;; put this file in the appropriate place.
+;;
+;; The last s-expression above makes sure that files ending with .pl
+;; are assumed to be Prolog files and not Perl, which is the default
+;; Emacs setting. If this is not wanted, remove this line. It is then
+;; necessary to either
+;;
+;; o insert in your Prolog files the following comment as the first line:
+;;
+;; % -*- Mode: Prolog -*-
+;;
+;; and then the file will be open in Prolog mode no matter its
+;; extension, or
+;;
+;; o manually switch to prolog mode after opening a Prolog file, by typing
+;; M-x prolog-mode.
+;;
+;; If the command to start the prolog process ('sicstus', 'pl' or
+;; 'swipl' for SWI prolog, etc.) is not available in the default path,
+;; then it is necessary to set the value of the environment variable
+;; EPROLOG to a shell command to invoke the prolog process. In XEmacs
+;; and Emacs 20+ you can also customize the variable
+;; `prolog-program-name' (in the group `prolog-inferior') and provide
+;; a full path for your Prolog system (swi, scitus, etc.).
+;;
+;; Note: I (Stefan, the current maintainer) work under XEmacs. Future
+;; developments will thus be biased towards XEmacs (OK, I admit it,
+;; I am biased towards XEmacs in general), though I will do my best
+;; to keep the GNU Emacs compatibility. So if you work under Emacs
+;; and see something that does not work do drop me a line, as I have
+;; a smaller chance to notice this kind of bugs otherwise.
+
+;; Changelog:
+
+;; Version 1.22:
+;; o Allowed both 'swipl' and 'pl' as names for the SWI Prolog
+;; interpreter.
+;; o Atoms that start a line are not blindly coloured as
+;; predicates. Instead we check that they are followed by ( or
+;; :- first. Patch suggested by Guy Wiener.
+;; Version 1.21:
+;; o Cleaned up the code that defines faces. The missing face
+;; warnings on some Emacsen should disappear.
+;; Version 1.20:
+;; o Improved the handling of clause start detection and multi-line
+;; comments: `prolog-clause-start' no longer finds non-predicate
+;; (e.g., capitalized strings) beginning of clauses.
+;; `prolog-tokenize' recognizes when the end point is within a
+;; multi-line comment.
+;; Version 1.19:
+;; o Minimal changes for Aquamacs inclusion and in general for
+;; better coping with finding the Prolog executable. Patch
+;; provided by David Reitter
+;; Version 1.18:
+;; o Fixed syntax highlighting for clause heads that do not begin at
+;; the beginning of the line.
+;; o Fixed compilation warnings under Emacs.
+;; o Updated the email address of the current maintainer.
+;; Version 1.17:
+;; o Minor indentation fix (patch by Markus Triska)
+;; o `prolog-underscore-wordchar-flag' defaults now to nil (more
+;; consistent to other Emacs modes)
+;; Version 1.16:
+;; o Eliminated a possible compilation warning.
+;; Version 1.15:
+;; o Introduced three new customizable variables: electric colon
+;; (`prolog-electric-colon-flag', default nil), electric dash
+;; (`prolog-electric-dash-flag', default nil), and a possibility
+;; to prevent the predicate template insertion from adding commata
+;; (`prolog-electric-dot-full-predicate-template', defaults to t
+;; since it seems quicker to me to just type those commata). A
+;; trivial adaptation of a patch by Markus Triska.
+;; o Improved the behaviour of electric if-then-else to only skip
+;; forward if the parenthesis/semicolon is preceded by
+;; whitespace. Once more a trivial adaptation of a patch by
+;; Markus Triska.
+;; Version 1.14:
+;; o Cleaned up align code. `prolog-align-flag' is eliminated (since
+;; on a second thought it does not do anything useful). Added key
+;; binding (C-c C-a) and menu entry for alignment.
+;; o Condensed regular expressions for lower and upper case
+;; characters (GNU Emacs seems to go over the regexp length limit
+;; with the original form). My code on the matter was improved
+;; considerably by Markus Triska.
+;; o Fixed `prolog-insert-spaces-after-paren' (which used an
+;; unitialized variable).
+;; o Minor changes to clean up the code and avoid some implicit
+;; package requirements.
+;; Version 1.13:
+;; o Removed the use of `map-char-table' in `prolog-build-case-strings'
+;; which appears to cause prblems in (at least) Emacs 23.0.0.1.
+;; o Added if-then-else indentation + corresponding electric
+;; characters. New customization: `prolog-electric-if-then-else-flag'
+;; o Align support (requires `align'). New customization:
+;; `prolog-align-flag'.
+;; o Temporary consult files have now the same name throughout the
+;; session. This prevents issues with reconsulting a buffer
+;; (this event is no longer passed to Prolog as a request to
+;; consult a new file).
+;; o Adaptive fill mode is now turned on. Comment indentation is
+;; still worse than it could be though, I am working on it.
+;; o Improved filling and auto-filling capabilities. Now block
+;; comments should be [auto-]filled correctly most of the time;
+;; the following pattern in particular is worth noting as being
+;; filled correctly:
+;; <some code here> % some comment here that goes beyond the
+;; % rightmost column, possibly combined with
+;; % subsequent comment lines
+;; o `prolog-char-quote-workaround' now defaults to nil.
+;; o Note: Many of the above improvements have been suggested by
+;; Markus Triska, who also provided useful patches on the matter
+;; when he realized that I was slow in responding. Many thanks.
+;; Version 1.11 / 1.12
+;; o GNU Emacs compatibility fix for paragraph filling (fixed
+;; incorrectly in 1.11, fix fixed in 1.12).
+;; Version 1.10
+;; o Added paragraph filling in comment blocks and also correct auto
+;; filling for comments.
+;; o Fixed the possible "Regular expression too big" error in
+;; `prolog-electric-dot'.
+;; Version 1.9
+;; o Parenthesis expressions are now indented by default so that
+;; components go one underneath the other, just as for compound
+;; terms. You can use the old style (the second and subsequent
+;; lines being indented to the right in a parenthesis expression)
+;; by setting the customizable variable `prolog-paren-indent-p'
+;; (group "Prolog Indentation") to t.
+;; o (Somehow awkward) handling of the 0' character escape
+;; sequence. I am looking into a better way of doing it but
+;; prospects look bleak. If this breaks things for you please let
+;; me know and also set the `prolog-char-quote-workaround' (group
+;; "Prolog Other") to nil.
+;; Version 1.8
+;; o Key binding fix.
+;; Version 1.7
+;; o Fixed a number of issues with the syntax of single quotes,
+;; including Debian bug #324520.
+;; Version 1.6
+;; o Fixed mercury mode menu initialization (Debian bug #226121).
+;; o Fixed (i.e., eliminated) Delete remapping (Debian bug #229636).
+;; o Corrected indentation for clauses defining quoted atoms.
+;; Version 1.5:
+;; o Keywords fontifying should work in console mode so this is
+;; enabled everywhere.
+;; Version 1.4:
+;; o Now supports GNU Prolog--minor adaptation of a patch by Stefan
+;; Moeding.
+;; Version 1.3:
+;; o Info-follow-nearest-node now called correctly under Emacs too
+;; (thanks to Nicolas Pelletier). Should be implemented more
+;; elegantly (i.e., without compilation warnings) in the future.
+;; Version 1.2:
+;; o Another prompt fix, still in SWI mode (people seem to have
+;; changed the prompt of SWI Prolog).
+;; Version 1.1:
+;; o Fixed dots in the end of line comments causing indentation
+;; problems. The following code is now correctly indented (note
+;; the dot terminating the comment):
+;; a(X) :- b(X),
+;; c(X). % comment here.
+;; a(X).
+;; and so is this (and variants):
+;; a(X) :- b(X),
+;; c(X). /* comment here. */
+;; a(X).
+;; Version 1.0:
+;; o Revamped the menu system.
+;; o Yet another prompt recognition fix (SWI mode).
+;; o This is more of a renumbering than a new edition. I promoted
+;; the mode to version 1.0 to emphasize the fact that it is now
+;; mature and stable enough to be considered production (in my
+;; opinion anyway).
+;; Version 0.1.41:
+;; o GNU Emacs compatibility fixes.
+;; Version 0.1.40:
+;; o prolog-get-predspec is now suitable to be called as
+;; imenu-extract-index-name-function. The predicate index works.
+;; o Since imenu works now as advertised, prolog-imenu-flag is t
+;; by default.
+;; o Eliminated prolog-create-predicate-index since the imenu
+;; utilities now work well. Actually, this function is also
+;; buggy, and I see no reason to fix it since we do not need it
+;; anyway.
+;; o Fixed prolog-pred-start, prolog-clause-start, prolog-clause-info.
+;; o Fix for prolog-build-case-strings; now prolog-upper-case-string
+;; and prolog-lower-case-string are correctly initialized,
+;; o Various font-lock changes; most importantly, block comments (/*
+;; ... */) are now correctly fontified in XEmacs even when they
+;; extend on multiple lines.
+;; Version 0.1.36:
+;; o The debug prompt of SWI Prolog is now correctly recognized.
+;; Version 0.1.35:
+;; o Minor font-lock bug fixes.
-;; This package provides a major mode for editing Prolog. It knows
-;; about Prolog syntax and comments, and can send regions to an inferior
-;; Prolog interpreter process. Font locking is tuned towards GNU Prolog.
+;;; TODO:
+;; Replace ":type 'sexp" with more precise Custom types.
+
;;; Code:
-(defvar comint-prompt-regexp)
-(defvar comint-process-echoes)
+(eval-when-compile
+ (require 'font-lock)
+ ;; We need imenu everywhere because of the predicate index!
+ (require 'imenu)
+ ;)
+ (require 'info)
+ (require 'shell)
+ )
+
+(require 'comint)
+(require 'easymenu)
+(require 'align)
+
(defgroup prolog nil
- "Major mode for editing and running Prolog under Emacs."
- :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces)
+ "Major modes for editing and running Prolog and Mercury files."
:group 'languages)
+(defgroup prolog-faces nil
+ "Prolog mode specific faces."
+ :group 'font-lock)
-(defcustom prolog-program-name
- (let ((names '("prolog" "gprolog" "swipl")))
- (while (and names
- (not (executable-find (car names))))
- (setq names (cdr names)))
- (or (car names) "prolog"))
- "Program name for invoking an inferior Prolog with `run-prolog'."
- :type 'string
+(defgroup prolog-indentation nil
+ "Prolog mode indentation configuration."
:group 'prolog)
-(defcustom prolog-consult-string "reconsult(user).\n"
- "(Re)Consult mode (for C-Prolog and Quintus Prolog). "
- :type 'string
+(defgroup prolog-font-lock nil
+ "Prolog mode font locking patterns."
:group 'prolog)
-(defcustom prolog-compile-string "compile(user).\n"
- "Compile mode (for Quintus Prolog)."
- :type 'string
+(defgroup prolog-keyboard nil
+ "Prolog mode keyboard flags."
:group 'prolog)
-(defcustom prolog-eof-string "end_of_file.\n"
- "String that represents end of file for Prolog.
-When nil, send actual operating system end of file."
- :type 'string
+(defgroup prolog-inferior nil
+ "Inferior Prolog mode options."
:group 'prolog)
-(defcustom prolog-indent-width 4
- "Level of indentation in Prolog buffers."
- :type 'integer
+(defgroup prolog-other nil
+ "Other Prolog mode options."
:group 'prolog)
-(defvar prolog-font-lock-keywords
- '(("\\(#[<=]=>\\|:-\\)\\|\\(#=\\)\\|\\(#[#<>\\/][=\\/]*\\|!\\)"
- 0 font-lock-keyword-face)
- ("\\<\\(is\\|write\\|nl\\|read_\\sw+\\)\\>"
- 1 font-lock-keyword-face)
- ("^\\(\\sw+\\)\\s-*\\((\\(.+\\))\\)*"
- (1 font-lock-function-name-face)
- (3 font-lock-variable-name-face)))
- "Font-lock keywords for Prolog mode.")
+
+;;-------------------------------------------------------------------
+;; User configurable variables
+;;-------------------------------------------------------------------
+
+;; General configuration
+
+(defcustom prolog-system nil
+ "*Prolog interpreter/compiler used.
+The value of this variable is nil or a symbol.
+If it is a symbol, it determines default values of other configuration
+variables with respect to properties of the specified Prolog
+interpreter/compiler.
+
+Currently recognized symbol values are:
+eclipse - Eclipse Prolog
+mercury - Mercury
+sicstus - SICStus Prolog
+swi - SWI Prolog
+gnu - GNU Prolog"
+ :group 'prolog
+ :type '(choice (const :tag "SICStus" :value sicstus)
+ (const :tag "SWI Prolog" :value swi)
+ (const :tag "GNU Prolog" :value gnu)
+ (const :tag "ECLiPSe Prolog" :value eclipse)
+ ;; Mercury shouldn't be needed since we have a separate
+ ;; major mode for it.
+ (const :tag "Default" :value nil)))
+(make-variable-buffer-local 'prolog-system)
+
+;; NB: This alist can not be processed in prolog-mode-variables to
+;; create a prolog-system-version-i variable since it is needed
+;; prior to the call to prolog-mode-variables.
+(defcustom prolog-system-version
+ '((sicstus (3 . 6))
+ (swi (0 . 0))
+ (mercury (0 . 0))
+ (eclipse (3 . 7))
+ (gnu (0 . 0)))
+ ;; FIXME: This should be auto-detected instead of user-provided.
+ "*Alist of Prolog system versions.
+The version numbers are of the format (Major . Minor)."
+ :group 'prolog)
+
+;; Indentation
+
+(defcustom prolog-indent-width 4
+ "*The indentation width used by the editing buffer."
+ :group 'prolog-indentation
+ :type 'integer)
+
+(defcustom prolog-align-comments-flag t
+ "*Non-nil means automatically align comments when indenting."
+ :group 'prolog-indentation
+ :type 'boolean)
+
+(defcustom prolog-indent-mline-comments-flag t
+ "*Non-nil means indent contents of /* */ comments.
+Otherwise leave such lines as they are."
+ :group 'prolog-indentation
+ :type 'boolean)
+
+(defcustom prolog-object-end-to-0-flag t
+ "*Non-nil means indent closing '}' in SICStus object definitions to level 0.
+Otherwise indent to `prolog-indent-width'."
+ :group 'prolog-indentation
+ :type 'boolean)
+
+(defcustom prolog-left-indent-regexp "\\(;\\|\\*?->\\)"
+ "*Regexp for character sequences after which next line is indented.
+Next line after such a regexp is indented to the opening paranthesis level."
+ :group 'prolog-indentation
+ :type 'regexp)
+
+(defcustom prolog-paren-indent-p nil
+ "*If non-nil, increase indentation for parenthesis expressions.
+The second and subsequent line in a parenthesis expression other than
+a compound term can either be indented `prolog-paren-indent' to the
+right (if this variable is non-nil) or in the same way as for compound
+terms (if this variable is nil, default)."
+ :group 'prolog-indentation
+ :type 'boolean)
+
+(defcustom prolog-paren-indent 4
+ "*The indentation increase for parenthesis expressions.
+Only used in ( If -> Then ; Else) and ( Disj1 ; Disj2 ) style expressions."
+ :group 'prolog-indentation
+ :type 'integer)
+
+(defcustom prolog-parse-mode 'beg-of-clause
+ "*The parse mode used (decides from which point parsing is done).
+Legal values:
+'beg-of-line - starts parsing at the beginning of a line, unless the
+ previous line ends with a backslash. Fast, but has
+ problems detecting multiline /* */ comments.
+'beg-of-clause - starts parsing at the beginning of the current clause.
+ Slow, but copes better with /* */ comments."
+ :group 'prolog-indentation
+ :type '(choice (const :value beg-of-line)
+ (const :value beg-of-clause)))
+
+;; Font locking
+
+(defcustom prolog-keywords
+ '((eclipse
+ ("use_module" "begin_module" "module_interface" "dynamic"
+ "external" "export" "dbgcomp" "nodbgcomp" "compile"))
+ (mercury
+ ("all" "else" "end_module" "equality" "external" "fail" "func" "if"
+ "implementation" "import_module" "include_module" "inst" "instance"
+ "interface" "mode" "module" "not" "pragma" "pred" "some" "then" "true"
+ "type" "typeclass" "use_module" "where"))
+ (sicstus
+ ("block" "dynamic" "mode" "module" "multifile" "meta_predicate"
+ "parallel" "public" "sequential" "volatile"))
+ (swi
+ ("discontiguous" "dynamic" "ensure_loaded" "export" "export_list" "import"
+ "meta_predicate" "module" "module_transparent" "multifile" "require"
+ "use_module" "volatile"))
+ (gnu
+ ("built_in" "char_conversion" "discontiguous" "dynamic" "ensure_linked"
+ "ensure_loaded" "foreign" "include" "initialization" "multifile" "op"
+ "public" "set_prolog_flag"))
+ (t
+ ;; FIXME: Shouldn't we just use the union of all the above here?
+ ("dynamic" "module")))
+ "*Alist of Prolog keywords which is used for font locking of directives."
+ :group 'prolog-font-lock
+ :type 'sexp)
+
+(defcustom prolog-types
+ '((mercury
+ ("char" "float" "int" "io__state" "string" "univ"))
+ (t nil))
+ "*Alist of Prolog types used by font locking."
+ :group 'prolog-font-lock
+ :type 'sexp)
+
+(defcustom prolog-mode-specificators
+ '((mercury
+ ("bound" "di" "free" "ground" "in" "mdi" "mui" "muo" "out" "ui" "uo"))
+ (t nil))
+ "*Alist of Prolog mode specificators used by font locking."
+ :group 'prolog-font-lock
+ :type 'sexp)
+
+(defcustom prolog-determinism-specificators
+ '((mercury
+ ("cc_multi" "cc_nondet" "det" "erroneous" "failure" "multi" "nondet"
+ "semidet"))
+ (t nil))
+ "*Alist of Prolog determinism specificators used by font locking."
+ :group 'prolog-font-lock
+ :type 'sexp)
+
+(defcustom prolog-directives
+ '((mercury
+ ("^#[0-9]+"))
+ (t nil))
+ "*Alist of Prolog source code directives used by font locking."
+ :group 'prolog-font-lock
+ :type 'sexp)
+
+
+;; Keyboard
+
+(defcustom prolog-electric-newline-flag (not (fboundp 'electric-indent-mode))
+ "*Non-nil means automatically indent the next line when the user types RET."
+ :group 'prolog-keyboard
+ :type 'boolean)
+
+(defcustom prolog-hungry-delete-key-flag nil
+ "*Non-nil means delete key consumes all preceding spaces."
+ :group 'prolog-keyboard
+ :type 'boolean)
+
+(defcustom prolog-electric-dot-flag nil
+ "*Non-nil means make dot key electric.
+Electric dot appends newline or inserts head of a new clause.
+If dot is pressed at the end of a line where at least one white space
+precedes the point, it inserts a recursive call to the current predicate.
+If dot is pressed at the beginning of an empty line, it inserts the head
+of a new clause for the current predicate. It does not apply in strings
+and comments.
+It does not apply in strings and comments."
+ :group 'prolog-keyboard
+ :type 'boolean)
+
+(defcustom prolog-electric-dot-full-predicate-template nil
+ "*If nil, electric dot inserts only the current predicate's name and `('
+for recursive calls or new clause heads. Non-nil means to also
+insert enough commata to cover the predicate's arity and `)',
+and dot and newline for recursive calls."
+ :group 'prolog-keyboard
+ :type 'boolean)
+
+(defcustom prolog-electric-underscore-flag nil
+ "*Non-nil means make underscore key electric.
+Electric underscore replaces the current variable with underscore.
+If underscore is pressed not on a variable then it behaves as usual."
+ :group 'prolog-keyboard
+ :type 'boolean)
+
+(defcustom prolog-electric-tab-flag nil
+ "*Non-nil means make TAB key electric.
+Electric TAB inserts spaces after parentheses, ->, and ;
+in ( If -> Then ; Else) and ( Disj1 ; Disj2 ) style expressions."
+ :group 'prolog-keyboard
+ :type 'boolean)
+
+(defcustom prolog-electric-if-then-else-flag nil
+ "*Non-nil makes `(', `>' and `;' electric
+to automatically indent if-then-else constructs."
+ :group 'prolog-keyboard
+ :type 'boolean)
+
+(defcustom prolog-electric-colon-flag nil
+ "*Makes `:' electric (inserts `:-' on a new line).
+If non-nil, pressing `:' at the end of a line that starts in
+the first column (i.e., clause heads) inserts ` :-' and newline."
+ :group 'prolog-keyboard
+ :type 'boolean)
+
+(defcustom prolog-electric-dash-flag nil
+ "*Makes `-' electric (inserts a `-->' on a new line).
+If non-nil, pressing `-' at the end of a line that starts in
+the first column (i.e., DCG heads) inserts ` -->' and newline."
+ :group 'prolog-keyboard
+ :type 'boolean)
+
+(defcustom prolog-old-sicstus-keys-flag nil
+ "*Non-nil means old SICStus Prolog mode keybindings are used."
+ :group 'prolog-keyboard
+ :type 'boolean)
+
+;; Inferior mode
+
+(defcustom prolog-program-name
+ `(((getenv "EPROLOG") (eval (getenv "EPROLOG")))
+ (eclipse "eclipse")
+ (mercury nil)
+ (sicstus "sicstus")
+ (swi ,(if (not (executable-find "swipl")) "pl" "swipl"))
+ (gnu "gprolog")
+ (t ,(let ((names '("prolog" "gprolog" "swipl" "pl")))
+ (while (and names
+ (not (executable-find (car names))))
+ (setq names (cdr names)))
+ (or (car names) "prolog"))))
+ "*Alist of program names for invoking an inferior Prolog with `run-prolog'."
+ :group 'prolog-inferior
+ :type 'sexp)
+(defun prolog-program-name ()
+ (prolog-find-value-by-system prolog-program-name))
+
+(defcustom prolog-program-switches
+ '((sicstus ("-i"))
+ (t nil))
+ "*Alist of switches given to inferior Prolog run with `run-prolog'."
+ :group 'prolog-inferior
+ :type 'sexp)
+(defun prolog-program-switches ()
+ (prolog-find-value-by-system prolog-program-switches))
+
+(defcustom prolog-consult-string
+ '((eclipse "[%f].")
+ (mercury nil)
+ (sicstus (eval (if (prolog-atleast-version '(3 . 7))
+ "prolog:zap_file(%m,%b,consult,%l)."
+ "prolog:zap_file(%m,%b,consult).")))
+ (swi "[%f].")
+ (gnu "[%f].")
+ (t "reconsult(%f)."))
+ "*Alist of strings defining predicate for reconsulting.
+
+Some parts of the string are replaced:
+`%f' by the name of the consulted file (can be a temporary file)
+`%b' by the file name of the buffer to consult
+`%m' by the module name and name of the consulted file separated by colon
+`%l' by the line offset into the file. This is 0 unless consulting a
+ region of a buffer, in which case it is the number of lines before
+ the region."
+ :group 'prolog-inferior
+ :type 'sexp)
+(defun prolog-consult-string ()
+ (prolog-find-value-by-system prolog-consult-string))
+
+(defcustom prolog-compile-string
+ '((eclipse "[%f].")
+ (mercury "mmake ")
+ (sicstus (eval (if (prolog-atleast-version '(3 . 7))
+ "prolog:zap_file(%m,%b,compile,%l)."
+ "prolog:zap_file(%m,%b,compile).")))
+ (swi "[%f].")
+ (t "compile(%f)."))
+ "*Alist of strings and lists defining predicate for recompilation.
+
+Some parts of the string are replaced:
+`%f' by the name of the compiled file (can be a temporary file)
+`%b' by the file name of the buffer to compile
+`%m' by the module name and name of the compiled file separated by colon
+`%l' by the line offset into the file. This is 0 unless compiling a
+ region of a buffer, in which case it is the number of lines before
+ the region.
+
+If `prolog-program-name' is non-nil, it is a string sent to a Prolog process.
+If `prolog-program-name' is nil, it is an argument to the `compile' function."
+ :group 'prolog-inferior
+ :type 'sexp)
+(defun prolog-compile-string ()
+ (prolog-find-value-by-system prolog-compile-string))
+
+(defcustom prolog-eof-string "end_of_file.\n"
+ "*Alist of strings that represent end of file for prolog.
+nil means send actual operating system end of file."
+ :group 'prolog-inferior
+ :type 'sexp)
+
+(defcustom prolog-prompt-regexp
+ '((eclipse "^[a-zA-Z0-9()]* *\\?- \\|^\\[[a-zA-Z]* [0-9]*\\]:")
+ (sicstus "| [ ?][- ] *")
+ (swi "^\\(\\[[a-zA-Z]*\\] \\)?[1-9]?[0-9]*[ ]?\\?- \\|^| +")
+ (gnu "^| \\?-")
+ (t "^|? *\\?-"))
+ "*Alist of prompts of the prolog system command line."
+ :group 'prolog-inferior
+ :type 'sexp)
+(defun prolog-prompt-regexp ()
+ (prolog-find-value-by-system prolog-prompt-regexp))
+
+;; (defcustom prolog-continued-prompt-regexp
+;; '((sicstus "^\\(| +\\| +\\)")
+;; (t "^|: +"))
+;; "*Alist of regexps matching the prompt when consulting `user'."
+;; :group 'prolog-inferior
+;; :type 'sexp)
+
+(defcustom prolog-debug-on-string "debug.\n"
+ "*Predicate for enabling debug mode."
+ :group 'prolog-inferior
+ :type 'string)
+
+(defcustom prolog-debug-off-string "nodebug.\n"
+ "*Predicate for disabling debug mode."
+ :group 'prolog-inferior
+ :type 'string)
+
+(defcustom prolog-trace-on-string "trace.\n"
+ "*Predicate for enabling tracing."
+ :group 'prolog-inferior
+ :type 'string)
+
+(defcustom prolog-trace-off-string "notrace.\n"
+ "*Predicate for disabling tracing."
+ :group 'prolog-inferior
+ :type 'string)
+
+(defcustom prolog-zip-on-string "zip.\n"
+ "*Predicate for enabling zip mode for SICStus."
+ :group 'prolog-inferior
+ :type 'string)
+
+(defcustom prolog-zip-off-string "nozip.\n"
+ "*Predicate for disabling zip mode for SICStus."
+ :group 'prolog-inferior
+ :type 'string)
+
+(defcustom prolog-use-standard-consult-compile-method-flag t
+ "*Non-nil means use the standard compilation method.
+Otherwise the new compilation method will be used. This
+utilises a special compilation buffer with the associated
+features such as parsing of error messages and automatically
+jumping to the source code responsible for the error.
+
+Warning: the new method is so far only experimental and
+does contain bugs. The recommended setting for the novice user
+is non-nil for this variable."
+ :group 'prolog-inferior
+ :type 'boolean)
+
+
+;; Miscellaneous
+
+(defcustom prolog-use-prolog-tokenizer-flag
+ (not (fboundp 'syntax-propertize-rules))
+ "*Non-nil means use the internal prolog tokenizer for indentation etc.
+Otherwise use `parse-partial-sexp' which is faster but sometimes incorrect."
+ :group 'prolog-other
+ :type 'boolean)
+
+(defcustom prolog-imenu-flag t
+ "*Non-nil means add a clause index menu for all prolog files."
+ :group 'prolog-other
+ :type 'boolean)
+
+(defcustom prolog-imenu-max-lines 3000
+ "*The maximum number of lines of the file for imenu to be enabled.
+Relevant only when `prolog-imenu-flag' is non-nil."
+ :group 'prolog-other
+ :type 'integer)
+
+(defcustom prolog-info-predicate-index
+ "(sicstus)Predicate Index"
+ "*The info node for the SICStus predicate index."
+ :group 'prolog-other
+ :type 'string)
+
+(defcustom prolog-underscore-wordchar-flag nil
+ "*Non-nil means underscore (_) is a word-constituent character."
+ :group 'prolog-other
+ :type 'boolean)
+
+(defcustom prolog-use-sicstus-sd nil
+ "*If non-nil, use the source level debugger of SICStus 3#7 and later."
+ :group 'prolog-other
+ :type 'boolean)
+
+(defcustom prolog-char-quote-workaround nil
+ "*If non-nil, declare 0 as a quote character to handle 0'<char>.
+This is really kludgy, and unneeded (i.e. obsolete) in Emacs>=24."
+ :group 'prolog-other
+ :type 'boolean)
+
+
+;;-------------------------------------------------------------------
+;; Internal variables
+;;-------------------------------------------------------------------
+
+;;(defvar prolog-temp-filename "") ; Later set by `prolog-temporary-file'
(defvar prolog-mode-syntax-table
+ ;; The syntax accepted varies depending on the implementation used.
+ ;; Here are some of the differences:
+ ;; - SWI-Prolog accepts nested /*..*/ comments.
+ ;; - Edinburgh-style Prologs take <radix>'<number> for non-decimal number,
+ ;; whereas ISO-style Prologs use 0[obx]<number> instead.
+ ;; - In atoms \x<hex> sometimes needs a terminating \ (ISO-style)
+ ;; and sometimes not.
(let ((table (make-syntax-table)))
- (modify-syntax-entry ?_ "w" table)
- (modify-syntax-entry ?\\ "\\" table)
- (modify-syntax-entry ?/ ". 14" table)
- (modify-syntax-entry ?* ". 23" table)
+ (if prolog-underscore-wordchar-flag
+ (modify-syntax-entry ?_ "w" table)
+ (modify-syntax-entry ?_ "_" table))
+
(modify-syntax-entry ?+ "." table)
(modify-syntax-entry ?- "." table)
(modify-syntax-entry ?= "." table)
- (modify-syntax-entry ?% "<" table)
- (modify-syntax-entry ?\n ">" table)
(modify-syntax-entry ?< "." table)
(modify-syntax-entry ?> "." table)
+ (modify-syntax-entry ?| "." table)
(modify-syntax-entry ?\' "\"" table)
- table))
+ ;; Any better way to handle the 0'<char> construct?!?
+ (when prolog-char-quote-workaround
+ (modify-syntax-entry ?0 "\\" table))
+
+ (modify-syntax-entry ?% "<" table)
+ (modify-syntax-entry ?\n ">" table)
+ (if (featurep 'xemacs)
+ (progn
+ (modify-syntax-entry ?* ". 67" table)
+ (modify-syntax-entry ?/ ". 58" table)
+ )
+ ;; Emacs wants to see this it seems:
+ (modify-syntax-entry ?* ". 23b" table)
+ (modify-syntax-entry ?/ ". 14" table)
+ )
+ table))
(defvar prolog-mode-abbrev-table nil)
+(defvar prolog-upper-case-string ""
+ "A string containing all upper case characters.
+Set by prolog-build-case-strings.")
+(defvar prolog-lower-case-string ""
+ "A string containing all lower case characters.
+Set by prolog-build-case-strings.")
+
+(defvar prolog-atom-char-regexp ""
+ "Set by prolog-set-atom-regexps.")
+;; "Regexp specifying characters which constitute atoms without quoting.")
+(defvar prolog-atom-regexp ""
+ "Set by prolog-set-atom-regexps.")
+
+(defconst prolog-left-paren "[[({]" ;FIXME: Why not \\s(?
+ "The characters used as left parentheses for the indentation code.")
+(defconst prolog-right-paren "[])}]" ;FIXME: Why not \\s)?
+ "The characters used as right parentheses for the indentation code.")
+
+(defconst prolog-quoted-atom-regexp
+ "\\(^\\|[^0-9]\\)\\('\\([^\n']\\|\\\\'\\)*'\\)"
+ "Regexp matching a quoted atom.")
+(defconst prolog-string-regexp
+ "\\(\"\\([^\n\"]\\|\\\\\"\\)*\"\\)"
+ "Regexp matching a string.")
+(defconst prolog-head-delimiter "\\(:-\\|\\+:\\|-:\\|\\+\\?\\|-\\?\\|-->\\)"
+ "A regexp for matching on the end delimiter of a head (e.g. \":-\").")
+
+(defvar prolog-compilation-buffer "*prolog-compilation*"
+ "Name of the output buffer for Prolog compilation/consulting.")
+
+(defvar prolog-temporary-file-name nil)
+(defvar prolog-keywords-i nil)
+(defvar prolog-types-i nil)
+(defvar prolog-mode-specificators-i nil)
+(defvar prolog-determinism-specificators-i nil)
+(defvar prolog-directives-i nil)
+(defvar prolog-eof-string-i nil)
+;; (defvar prolog-continued-prompt-regexp-i nil)
+(defvar prolog-help-function-i nil)
+
+(defvar prolog-align-rules
+ (eval-when-compile
+ (mapcar
+ (lambda (x)
+ (let ((name (car x))
+ (sym (cdr x)))
+ `(,(intern (format "prolog-%s" name))
+ (regexp . ,(format "\\(\\s-*\\)%s\\(\\s-*\\)" sym))
+ (tab-stop . nil)
+ (modes . '(prolog-mode))
+ (group . (1 2)))))
+ '(("dcg" . "-->") ("rule" . ":-") ("simplification" . "<=>")
+ ("propagation" . "==>")))))
+
+
+
+;;-------------------------------------------------------------------
+;; Prolog mode
+;;-------------------------------------------------------------------
+
+;; Example: (prolog-atleast-version '(3 . 6))
+(defun prolog-atleast-version (version)
+ "Return t if the version of the current prolog system is VERSION or later.
+VERSION is of the format (Major . Minor)"
+ ;; Version.major < major or
+ ;; Version.major = major and Version.minor <= minor
+ (let* ((thisversion (prolog-find-value-by-system prolog-system-version))
+ (thismajor (car thisversion))
+ (thisminor (cdr thisversion)))
+ (or (< (car version) thismajor)
+ (and (= (car version) thismajor)
+ (<= (cdr version) thisminor)))
+ ))
+
(define-abbrev-table 'prolog-mode-abbrev-table ())
+(defun prolog-find-value-by-system (alist)
+ "Get value from ALIST according to `prolog-system'."
+ (let ((system (or prolog-system
+ (buffer-local-value 'prolog-system
+ (prolog-inferior-buffer 'dont-run)))))
+ (if (listp alist)
+ (let (result
+ id)
+ (while alist
+ (setq id (car (car alist)))
+ (if (or (eq id system)
+ (eq id t)
+ (and (listp id)
+ (eval id)))
+ (progn
+ (setq result (car (cdr (car alist))))
+ (if (and (listp result)
+ (eq (car result) 'eval))
+ (setq result (eval (car (cdr result)))))
+ (setq alist nil))
+ (setq alist (cdr alist))))
+ result)
+ alist)))
+
+(defconst prolog-syntax-propertize-function
+ (when (fboundp 'syntax-propertize-rules)
+ (syntax-propertize-rules
+ ;; GNU Prolog only accepts 0'\' rather than 0'', but the only
+ ;; possible meaning of 0'' is rather clear.
+ ("\\<0\\(''?\\)"
+ (1 (unless (save-excursion (nth 8 (syntax-ppss (match-beginning 0))))
+ (string-to-syntax "_"))))
+ ;; We could check that we're not inside an atom, but I don't think
+ ;; that 'foo 8'z could be a valid syntax anyway, so why bother?
+ ("\\<[1-9][0-9]*\\('\\)[0-9a-zA-Z]" (1 "_"))
+ ;; Supposedly, ISO-Prolog wants \NNN\ for octal and \xNNN\ for hexadecimal
+ ;; escape sequences in atoms, so be careful not to let the terminating \
+ ;; escape a subsequent quote.
+ ("\\\\[x0-7][0-9a-fA-F]*\\(\\\\\\)" (1 "_"))
+ )))
+
(defun prolog-mode-variables ()
- (make-local-variable 'paragraph-separate)
- (setq paragraph-separate (concat "%%\\|$\\|" page-delimiter)) ;'%%..'
- (make-local-variable 'paragraph-ignore-fill-prefix)
- (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)
- (make-local-variable 'comment-start)
- (setq comment-start "%")
- (make-local-variable 'comment-start-skip)
- (setq comment-start-skip "\\(?:%+\\|/\\*+\\)[ \t]*")
- (make-local-variable 'comment-end-skip)
- (setq comment-end-skip "[ \t]*\\(\n\\|\\*+/\\)")
- (make-local-variable 'comment-column)
- (setq comment-column 48))
+ "Set some common variables to Prolog code specific values."
+ (setq local-abbrev-table prolog-mode-abbrev-table)
+ (set (make-local-variable 'paragraph-start)
+ (concat "[ \t]*$\\|" page-delimiter)) ;'%%..'
+ (set (make-local-variable 'paragraph-separate) paragraph-start)
+ (set (make-local-variable 'paragraph-ignore-fill-prefix) t)
+ (set (make-local-variable 'normal-auto-fill-function) 'prolog-do-auto-fill)
+ (set (make-local-variable 'indent-line-function) 'prolog-indent-line)
+ (set (make-local-variable 'comment-start) "%")
+ (set (make-local-variable 'comment-end) "")
+ (set (make-local-variable 'comment-add) 1)
+ (set (make-local-variable 'comment-start-skip)
+ ;; This complex regexp makes sure that comments cannot start
+ ;; inside quoted atoms or strings
+ (format "^\\(\\(%s\\|%s\\|[^\n\'\"%%]\\)*\\)\\(/\\*+ *\\|%%+ *\\)"
+ prolog-quoted-atom-regexp prolog-string-regexp))
+ (set (make-local-variable 'comment-indent-function) 'prolog-comment-indent)
+ (set (make-local-variable 'parens-require-spaces) nil)
+ ;; Initialize Prolog system specific variables
+ (dolist (var '(prolog-keywords prolog-types prolog-mode-specificators
+ prolog-determinism-specificators prolog-directives
+ prolog-eof-string
+ ;; prolog-continued-prompt-regexp
+ prolog-help-function))
+ (set (intern (concat (symbol-name var) "-i"))
+ (prolog-find-value-by-system (symbol-value var))))
+ (when (null (prolog-program-name))
+ (set (make-local-variable 'compile-command) (prolog-compile-string)))
+ (set (make-local-variable 'font-lock-defaults)
+ '(prolog-font-lock-keywords nil nil ((?_ . "w"))))
+ (set (make-local-variable 'syntax-propertize-function)
+ prolog-syntax-propertize-function)
+ )
+
+(defun prolog-mode-keybindings-common (map)
+ "Define keybindings common to both Prolog modes in MAP."
+ (define-key map "\C-c?" 'prolog-help-on-predicate)
+ (define-key map "\C-c/" 'prolog-help-apropos)
+ (define-key map "\C-c\C-d" 'prolog-debug-on)
+ (define-key map "\C-c\C-t" 'prolog-trace-on)
+ (define-key map "\C-c\C-z" 'prolog-zip-on)
+ (define-key map "\C-c\r" 'run-prolog))
+
+(defun prolog-mode-keybindings-edit (map)
+ "Define keybindings for Prolog mode in MAP."
+ (define-key map "\M-a" 'prolog-beginning-of-clause)
+ (define-key map "\M-e" 'prolog-end-of-clause)
+ (define-key map "\M-q" 'prolog-fill-paragraph)
+ (define-key map "\C-c\C-a" 'align)
+ (define-key map "\C-\M-a" 'prolog-beginning-of-predicate)
+ (define-key map "\C-\M-e" 'prolog-end-of-predicate)
+ (define-key map "\M-\C-c" 'prolog-mark-clause)
+ (define-key map "\M-\C-h" 'prolog-mark-predicate)
+ (define-key map "\M-\C-n" 'prolog-forward-list)
+ (define-key map "\M-\C-p" 'prolog-backward-list)
+ (define-key map "\C-c\C-n" 'prolog-insert-predicate-template)
+ (define-key map "\C-c\C-s" 'prolog-insert-predspec)
+ (define-key map "\M-\r" 'prolog-insert-next-clause)
+ (define-key map "\C-c\C-va" 'prolog-variables-to-anonymous)
+ (define-key map "\C-c\C-v\C-s" 'prolog-view-predspec)
+
+ (define-key map [Backspace] 'prolog-electric-delete)
+ (define-key map "." 'prolog-electric-dot)
+ (define-key map "_" 'prolog-electric-underscore)
+ (define-key map "(" 'prolog-electric-if-then-else)
+ (define-key map ";" 'prolog-electric-if-then-else)
+ (define-key map ">" 'prolog-electric-if-then-else)
+ (define-key map ":" 'prolog-electric-colon)
+ (define-key map "-" 'prolog-electric-dash)
+ (if prolog-electric-newline-flag
+ (define-key map "\r" 'newline-and-indent))
+
+ ;; If we're running SICStus, then map C-c C-c e/d to enabling
+ ;; and disabling of the source-level debugging facilities.
+ ;(if (and (eq prolog-system 'sicstus)
+ ; (prolog-atleast-version '(3 . 7)))
+ ; (progn
+ ; (define-key map "\C-c\C-ce" 'prolog-enable-sicstus-sd)
+ ; (define-key map "\C-c\C-cd" 'prolog-disable-sicstus-sd)
+ ; ))
+
+ (if prolog-old-sicstus-keys-flag
+ (progn
+ (define-key map "\C-c\C-c" 'prolog-consult-predicate)
+ (define-key map "\C-cc" 'prolog-consult-region)
+ (define-key map "\C-cC" 'prolog-consult-buffer)
+ (define-key map "\C-c\C-k" 'prolog-compile-predicate)
+ (define-key map "\C-ck" 'prolog-compile-region)
+ (define-key map "\C-cK" 'prolog-compile-buffer))
+ (define-key map "\C-c\C-p" 'prolog-consult-predicate)
+ (define-key map "\C-c\C-r" 'prolog-consult-region)
+ (define-key map "\C-c\C-b" 'prolog-consult-buffer)
+ (define-key map "\C-c\C-f" 'prolog-consult-file)
+ (define-key map "\C-c\C-cp" 'prolog-compile-predicate)
+ (define-key map "\C-c\C-cr" 'prolog-compile-region)
+ (define-key map "\C-c\C-cb" 'prolog-compile-buffer)
+ (define-key map "\C-c\C-cf" 'prolog-compile-file))
+
+ ;; Inherited from the old prolog.el.
+ (define-key map "\e\C-x" 'prolog-consult-region)
+ (define-key map "\C-c\C-l" 'prolog-consult-file)
+ (define-key map "\C-c\C-z" 'switch-to-prolog))
+
+(defun prolog-mode-keybindings-inferior (_map)
+ "Define keybindings for inferior Prolog mode in MAP."
+ ;; No inferior mode specific keybindings now.
+ )
(defvar prolog-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "\e\C-x" 'prolog-consult-region)
- (define-key map "\C-c\C-l" 'inferior-prolog-load-file)
- (define-key map "\C-c\C-z" 'switch-to-prolog)
+ (prolog-mode-keybindings-common map)
+ (prolog-mode-keybindings-edit map)
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.
- '("Prolog"
- ["Indent line" indent-according-to-mode t]
- ["Indent region" indent-region t]
- ["Comment region" comment-region t]
- ["Uncomment region" uncomment-region t]
- "--"
- ["Run interactive Prolog session" run-prolog t]
- ))
+
+(defvar prolog-mode-hook nil
+ "List of functions to call after the prolog mode has initialised.")
+
+(unless (fboundp 'prog-mode)
+ (defalias 'prog-mode 'fundamental-mode))
;;;###autoload
-(defun prolog-mode ()
- "Major mode for editing Prolog code for Prologs.
-Blank lines and `%%...' separate paragraphs. `%'s start comments.
+(define-derived-mode prolog-mode prog-mode "Prolog"
+ "Major mode for editing Prolog code.
+
+Blank lines and `%%...' separate paragraphs. `%'s starts a comment
+line and comments can also be enclosed in /* ... */.
+
+If an optional argument SYSTEM is non-nil, set up mode for the given system.
+
+To find out what version of Prolog mode you are running, enter
+`\\[prolog-mode-version]'.
+
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")
+ (setq mode-name (concat "Prolog"
+ (cond
+ ((eq prolog-system 'eclipse) "[ECLiPSe]")
+ ((eq prolog-system 'sicstus) "[SICStus]")
+ ((eq prolog-system 'swi) "[SWI]")
+ ((eq prolog-system 'gnu) "[GNU]")
+ (t ""))))
(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))
+ (prolog-build-case-strings)
+ (prolog-set-atom-regexps)
+ (dolist (ar prolog-align-rules) (add-to-list 'align-rules-list ar))
-(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)))))
+ ;; imenu entry moved to the appropriate hook for consistency
-(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
- )))
- )))
+ ;; Load SICStus debugger if suitable
+ (if (and (eq prolog-system 'sicstus)
+ (prolog-atleast-version '(3 . 7))
+ prolog-use-sicstus-sd)
+ (prolog-enable-sicstus-sd))
+
+ (prolog-menu))
+
+(defvar mercury-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map prolog-mode-map)
+ map))
+
+;;;###autoload
+(define-derived-mode mercury-mode prolog-mode "Prolog[Mercury]"
+ "Major mode for editing Mercury programs.
+Actually this is just customized `prolog-mode'."
+ (set (make-local-variable 'prolog-system) 'mercury))
-(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))))
- (if (re-search-forward comment-start-skip eolpos 'move)
- (goto-char (match-beginning 0)))
- (skip-chars-backward " \t")))
-;;;
-;;; Inferior prolog mode
-;;;
-(defvar inferior-prolog-mode-map
+;;-------------------------------------------------------------------
+;; Inferior prolog mode
+;;-------------------------------------------------------------------
+
+(defvar prolog-inferior-mode-map
(let ((map (make-sparse-keymap)))
- ;; This map will inherit from `comint-mode-map' when entering
- ;; inferior-prolog-mode.
+ (prolog-mode-keybindings-common map)
+ (prolog-mode-keybindings-inferior map)
(define-key map [remap self-insert-command]
- 'inferior-prolog-self-insert-command)
+ 'prolog-inferior-self-insert-command)
map))
-(defvar inferior-prolog-mode-syntax-table prolog-mode-syntax-table)
-(defvar inferior-prolog-mode-abbrev-table prolog-mode-abbrev-table)
+(defvar prolog-inferior-mode-hook nil
+ "List of functions to call after the inferior prolog mode has initialised.")
-(defvar inferior-prolog-error-regexp-alist
- ;; GNU Prolog used to not follow the GNU standard format.
- '(("^\\(.*?\\):\\([0-9]+\\) error: .*(char:\\([0-9]+\\)" 1 2 3)
+(defvar prolog-inferior-error-regexp-alist
+ '(;; GNU Prolog used to not follow the GNU standard format.
+ ;; ("^\\(.*?\\):\\([0-9]+\\) error: .*(char:\\([0-9]+\\)" 1 2 3)
+ ;; SWI-Prolog.
+ ("^\\(?:\\?- *\\)?\\(\\(?:ERROR\\|\\(W\\)arning\\): *\\(.*?\\):\\([1-9][0-9]*\\):\\(?:\\([0-9]*\\):\\)?\\)\\(?:$\\| \\)"
+ 3 4 5 (2 . nil) 1)
+ ;; GNU-Prolog now uses the GNU standard format.
gnu))
-(declare-function comint-mode "comint")
-(declare-function comint-send-string "comint" (process string))
-(declare-function comint-send-region "comint" (process start end))
-(declare-function comint-send-eof "comint" ())
+(defun prolog-inferior-self-insert-command ()
+ "Insert the char in the buffer or pass it directly to the process."
+ (interactive)
+ (let* ((proc (get-buffer-process (current-buffer)))
+ (pmark (and proc (marker-position (process-mark proc)))))
+ ;; FIXME: the same treatment would be needed for SWI-Prolog, but I can't
+ ;; seem to find any way for Emacs to figure out when to use it because
+ ;; SWI doesn't include a " ? " or some such recognizable marker.
+ (if (and (eq prolog-system 'gnu)
+ pmark
+ (null current-prefix-arg)
+ (eobp)
+ (eq (point) pmark)
+ (save-excursion
+ (goto-char (- pmark 3))
+ ;; FIXME: check this comes from the process's output, maybe?
+ (looking-at " \\? ")))
+ ;; This is GNU prolog waiting to know whether you want more answers
+ ;; or not (or abort, etc...). The answer is a single char, not
+ ;; a line, so pass this char directly rather than wait for RET to
+ ;; send a whole line.
+ (comint-send-string proc (string last-command-event))
+ (call-interactively 'self-insert-command))))
+
+(declare-function 'compilation-shell-minor-mode "compile" (&optional arg))
(defvar compilation-error-regexp-alist)
-(define-derived-mode inferior-prolog-mode comint-mode "Inferior Prolog"
+(define-derived-mode prolog-inferior-mode comint-mode "Inferior Prolog"
"Major mode for interacting with an inferior Prolog process.
The following commands are available:
-\\{inferior-prolog-mode-map}
+\\{prolog-inferior-mode-map}
Entry to this mode calls the value of `prolog-mode-hook' with no arguments,
if that value is non-nil. Likewise with the value of `comint-mode-hook'.
`prolog-mode-hook' is called after `comint-mode-hook'.
-You can send text to the inferior Prolog from other buffers using the commands
-`process-send-region', `process-send-string' and \\[prolog-consult-region].
+You can send text to the inferior Prolog from other buffers
+using the commands `send-region', `send-string' and \\[prolog-consult-region].
Commands:
Tab indents for Prolog; with argument, shifts rest
of expression rigidly with the current line.
-Paragraphs are separated only by blank lines and '%%'.
-'%'s start comments.
+Paragraphs are separated only by blank lines and '%%'. '%'s start comments.
Return at end of buffer sends line as input.
Return not at end copies rest of line to end and sends it.
-\\[comint-kill-input] and \\[backward-kill-word] are kill commands, imitating normal Unix input editing.
+\\[comint-delchar-or-maybe-eof] sends end-of-file as input.
+\\[comint-kill-input] and \\[backward-kill-word] are kill commands,
+imitating normal Unix input editing.
\\[comint-interrupt-subjob] interrupts the shell or its current subjob if any.
-\\[comint-stop-subjob] stops. \\[comint-quit-subjob] sends quit signal."
- (setq comint-prompt-regexp "^| [ ?][- ] *")
+\\[comint-stop-subjob] stops, likewise.
+\\[comint-quit-subjob] sends quit signal, likewise.
+
+To find out what version of Prolog mode you are running, enter
+`\\[prolog-mode-version]'."
+ (require 'compile)
+ (setq comint-input-filter 'prolog-input-filter)
+ (setq mode-line-process '(": %s"))
+ (prolog-mode-variables)
+ (setq comint-prompt-regexp (prolog-prompt-regexp))
+ (set (make-local-variable 'shell-dirstack-query) "pwd.")
(set (make-local-variable 'compilation-error-regexp-alist)
- inferior-prolog-error-regexp-alist)
+ prolog-inferior-error-regexp-alist)
(compilation-shell-minor-mode)
- (prolog-mode-variables))
-
-(defvar inferior-prolog-buffer nil)
-
-(defvar inferior-prolog-flavor 'unknown
- "Either a symbol or a buffer position offset by one.
-If a buffer position, the flavor has not been determined yet and
-it is expected that the process's output has been or will
-be inserted at that position plus one.")
-
-(defun inferior-prolog-run (&optional name)
- (with-current-buffer (make-comint "prolog" (or name prolog-program-name))
- (inferior-prolog-mode)
- (setq-default inferior-prolog-buffer (current-buffer))
- (make-local-variable 'inferior-prolog-buffer)
- (when (and name (not (equal name prolog-program-name)))
- (set (make-local-variable 'prolog-program-name) name))
- (set (make-local-variable 'inferior-prolog-flavor)
- ;; Force re-detection.
- (let* ((proc (get-buffer-process (current-buffer)))
- (pmark (and proc (marker-position (process-mark proc)))))
- (cond
- ((null pmark) (1- (point-min)))
- ;; The use of insert-before-markers in comint.el together with
- ;; the potential use of comint-truncate-buffer in the output
- ;; filter, means that it's difficult to reliably keep track of
- ;; the buffer position where the process's output started.
- ;; If possible we use a marker at "start - 1", so that
- ;; insert-before-marker at `start' won't shift it. And if not,
- ;; we fall back on using a plain integer.
- ((> pmark (point-min)) (copy-marker (1- pmark)))
- (t (1- pmark)))))
- (add-hook 'comint-output-filter-functions
- 'inferior-prolog-guess-flavor nil t)))
-
-(defun inferior-prolog-process (&optional dontstart)
- (or (and (buffer-live-p inferior-prolog-buffer)
- (get-buffer-process inferior-prolog-buffer))
- (unless dontstart
- (inferior-prolog-run)
- ;; Try again.
- (inferior-prolog-process))))
-
-(defun inferior-prolog-guess-flavor (&optional ignored)
- (save-excursion
- (goto-char (1+ inferior-prolog-flavor))
- (setq inferior-prolog-flavor
- (cond
- ((looking-at "GNU Prolog") 'gnu)
- ((looking-at "Welcome to SWI-Prolog") 'swi)
- ((looking-at ".*\n") 'unknown) ;There's at least one line.
- (t inferior-prolog-flavor))))
- (when (symbolp inferior-prolog-flavor)
- (remove-hook 'comint-output-filter-functions
- 'inferior-prolog-guess-flavor t)
- (if (eq inferior-prolog-flavor 'gnu)
- (set (make-local-variable 'comint-process-echoes) t))))
+ (prolog-inferior-menu))
+
+(defun prolog-input-filter (str)
+ (cond ((string-match "\\`\\s *\\'" str) nil) ;whitespace
+ ((not (derived-mode-p 'prolog-inferior-mode)) t)
+ ((= (length str) 1) nil) ;one character
+ ((string-match "\\`[rf] *[0-9]*\\'" str) nil) ;r(edo) or f(ail)
+ (t t)))
;;;###autoload
-(defalias 'run-prolog 'switch-to-prolog)
-;;;###autoload
-(defun switch-to-prolog (&optional name)
+(defun run-prolog (arg)
"Run an inferior Prolog process, input and output via buffer *prolog*.
-With prefix argument \\[universal-prefix], prompt for the program to use."
- (interactive
- (list (when current-prefix-arg
- (let ((proc (inferior-prolog-process 'dontstart)))
- (if proc
- (if (yes-or-no-p "Kill current process before starting new one? ")
- (kill-process proc)
- (error "Abort")))
- (read-string "Run Prolog: " prolog-program-name)))))
- (unless (inferior-prolog-process 'dontstart)
- (inferior-prolog-run name))
- (pop-to-buffer inferior-prolog-buffer))
-
-(defun inferior-prolog-self-insert-command ()
- "Insert the char in the buffer or pass it directly to the process."
+With prefix argument ARG, restart the Prolog process if running before."
+ (interactive "P")
+ ;; FIXME: It should be possible to interactively specify the command to use
+ ;; to run prolog.
+ (if (and arg (get-process "prolog"))
+ (progn
+ (process-send-string "prolog" "halt.\n")
+ (while (get-process "prolog") (sit-for 0.1))))
+ (let ((buff (buffer-name)))
+ (if (not (string= buff "*prolog*"))
+ (prolog-goto-prolog-process-buffer))
+ ;; Load SICStus debugger if suitable
+ (if (and (eq prolog-system 'sicstus)
+ (prolog-atleast-version '(3 . 7))
+ prolog-use-sicstus-sd)
+ (prolog-enable-sicstus-sd))
+ (prolog-mode-variables)
+ (prolog-ensure-process)
+ ))
+
+(defun prolog-inferior-guess-flavor (&optional ignored)
+ (setq prolog-system
+ (when (or (numberp prolog-system) (markerp prolog-system))
+ (save-excursion
+ (goto-char (1+ prolog-system))
+ (cond
+ ((looking-at "GNU Prolog") 'gnu)
+ ((looking-at "Welcome to SWI-Prolog\\|%.*\\<swi_") 'swi)
+ ((looking-at ".*\n") nil) ;There's at least one line.
+ (t prolog-system)))))
+ (when (symbolp prolog-system)
+ (remove-hook 'comint-output-filter-functions
+ 'prolog-inferior-guess-flavor t)
+ (when prolog-system
+ (setq comint-prompt-regexp (prolog-prompt-regexp))
+ (if (eq prolog-system 'gnu)
+ (set (make-local-variable 'comint-process-echoes) t)))))
+
+(defun prolog-ensure-process (&optional wait)
+ "If Prolog process is not running, run it.
+If the optional argument WAIT is non-nil, wait for Prolog prompt specified by
+the variable `prolog-prompt-regexp'."
+ (if (null (prolog-program-name))
+ (error "This Prolog system has defined no interpreter."))
+ (if (comint-check-proc "*prolog*")
+ ()
+ (with-current-buffer (get-buffer-create "*prolog*")
+ (prolog-inferior-mode)
+ (apply 'make-comint-in-buffer "prolog" (current-buffer)
+ (prolog-program-name) nil (prolog-program-switches))
+ (unless prolog-system
+ ;; Setup auto-detection.
+ (set (make-local-variable 'prolog-system)
+ ;; Force re-detection.
+ (let* ((proc (get-buffer-process (current-buffer)))
+ (pmark (and proc (marker-position (process-mark proc)))))
+ (cond
+ ((null pmark) (1- (point-min)))
+ ;; The use of insert-before-markers in comint.el together with
+ ;; the potential use of comint-truncate-buffer in the output
+ ;; filter, means that it's difficult to reliably keep track of
+ ;; the buffer position where the process's output started.
+ ;; If possible we use a marker at "start - 1", so that
+ ;; insert-before-marker at `start' won't shift it. And if not,
+ ;; we fall back on using a plain integer.
+ ((> pmark (point-min)) (copy-marker (1- pmark)))
+ (t (1- pmark)))))
+ (add-hook 'comint-output-filter-functions
+ 'prolog-inferior-guess-flavor nil t))
+ (if wait
+ (progn
+ (goto-char (point-max))
+ (while
+ (save-excursion
+ (not
+ (re-search-backward
+ (concat "\\(" (prolog-prompt-regexp) "\\)" "\\=")
+ nil t)))
+ (sit-for 0.1)))))))
+
+(defun prolog-inferior-buffer (&optional dont-run)
+ (or (get-buffer "*prolog*")
+ (unless dont-run
+ (prolog-ensure-process)
+ (get-buffer "*prolog*"))))
+
+(defun prolog-process-insert-string (process string)
+ "Insert STRING into inferior Prolog buffer running PROCESS."
+ ;; Copied from elisp manual, greek to me
+ (with-current-buffer (process-buffer process)
+ ;; FIXME: Use window-point-insertion-type instead.
+ (let ((moving (= (point) (process-mark process))))
+ (save-excursion
+ ;; Insert the text, moving the process-marker.
+ (goto-char (process-mark process))
+ (insert string)
+ (set-marker (process-mark process) (point)))
+ (if moving (goto-char (process-mark process))))))
+
+;;------------------------------------------------------------
+;; Old consulting and compiling functions
+;;------------------------------------------------------------
+
+(declare-function compilation-forget-errors "compile" ())
+(declare-function compilation-fake-loc "compile"
+ (marker file &optional line col))
+
+(defun prolog-old-process-region (compilep start end)
+ "Process the region limited by START and END positions.
+If COMPILEP is non-nil then use compilation, otherwise consulting."
+ (prolog-ensure-process)
+ ;(let ((tmpfile prolog-temp-filename)
+ (let ((tmpfile (prolog-temporary-file))
+ ;(process (get-process "prolog"))
+ (first-line (1+ (count-lines
+ (point-min)
+ (save-excursion
+ (goto-char start)
+ (point))))))
+ (write-region start end tmpfile)
+ (setq start (copy-marker start))
+ (with-current-buffer (prolog-inferior-buffer)
+ (compilation-forget-errors)
+ (compilation-fake-loc start tmpfile))
+ (process-send-string
+ "prolog" (prolog-build-prolog-command
+ compilep tmpfile (prolog-bsts buffer-file-name)
+ first-line))
+ (prolog-goto-prolog-process-buffer)))
+
+(defun prolog-old-process-predicate (compilep)
+ "Process the predicate around point.
+If COMPILEP is non-nil then use compilation, otherwise consulting."
+ (prolog-old-process-region
+ compilep (prolog-pred-start) (prolog-pred-end)))
+
+(defun prolog-old-process-buffer (compilep)
+ "Process the entire buffer.
+If COMPILEP is non-nil then use compilation, otherwise consulting."
+ (prolog-old-process-region compilep (point-min) (point-max)))
+
+(defun prolog-old-process-file (compilep)
+ "Process the file of the current buffer.
+If COMPILEP is non-nil then use compilation, otherwise consulting."
+ (save-some-buffers)
+ (prolog-ensure-process)
+ (with-current-buffer (prolog-inferior-buffer)
+ (compilation-forget-errors))
+ (process-send-string
+ "prolog" (prolog-build-prolog-command
+ compilep buffer-file-name
+ (prolog-bsts buffer-file-name)))
+ (prolog-goto-prolog-process-buffer))
+
+
+;;------------------------------------------------------------
+;; Consulting and compiling
+;;------------------------------------------------------------
+
+;; Interactive interface functions, used by both the standard
+;; and the experimental consultation and compilation functions
+(defun prolog-consult-file ()
+ "Consult file of current buffer."
(interactive)
- (let* ((proc (get-buffer-process (current-buffer)))
- (pmark (and proc (marker-position (process-mark proc)))))
- (if (and (eq inferior-prolog-flavor 'gnu)
- pmark
- (null current-prefix-arg)
- (eobp)
- (eq (point) pmark)
+ (if prolog-use-standard-consult-compile-method-flag
+ (prolog-old-process-file nil)
+ (prolog-consult-compile-file nil)))
+
+(defun prolog-consult-buffer ()
+ "Consult buffer."
+ (interactive)
+ (if prolog-use-standard-consult-compile-method-flag
+ (prolog-old-process-buffer nil)
+ (prolog-consult-compile-buffer nil)))
+
+(defun prolog-consult-region (beg end)
+ "Consult region between BEG and END."
+ (interactive "r")
+ (if prolog-use-standard-consult-compile-method-flag
+ (prolog-old-process-region nil beg end)
+ (prolog-consult-compile-region nil beg end)))
+
+(defun prolog-consult-predicate ()
+ "Consult the predicate around current point."
+ (interactive)
+ (if prolog-use-standard-consult-compile-method-flag
+ (prolog-old-process-predicate nil)
+ (prolog-consult-compile-predicate nil)))
+
+(defun prolog-compile-file ()
+ "Compile file of current buffer."
+ (interactive)
+ (if prolog-use-standard-consult-compile-method-flag
+ (prolog-old-process-file t)
+ (prolog-consult-compile-file t)))
+
+(defun prolog-compile-buffer ()
+ "Compile buffer."
+ (interactive)
+ (if prolog-use-standard-consult-compile-method-flag
+ (prolog-old-process-buffer t)
+ (prolog-consult-compile-buffer t)))
+
+(defun prolog-compile-region (beg end)
+ "Compile region between BEG and END."
+ (interactive "r")
+ (if prolog-use-standard-consult-compile-method-flag
+ (prolog-old-process-region t beg end)
+ (prolog-consult-compile-region t beg end)))
+
+(defun prolog-compile-predicate ()
+ "Compile the predicate around current point."
+ (interactive)
+ (if prolog-use-standard-consult-compile-method-flag
+ (prolog-old-process-predicate t)
+ (prolog-consult-compile-predicate t)))
+
+(defun prolog-buffer-module ()
+ "Select Prolog module name appropriate for current buffer.
+Bases decision on buffer contents (-*- line)."
+ ;; Look for -*- ... module: MODULENAME; ... -*-
+ (let (beg end)
+ (save-excursion
+ (goto-char (point-min))
+ (skip-chars-forward " \t")
+ (and (search-forward "-*-" (line-end-position) t)
+ (progn
+ (skip-chars-forward " \t")
+ (setq beg (point))
+ (search-forward "-*-" (line-end-position) t))
+ (progn
+ (forward-char -3)
+ (skip-chars-backward " \t")
+ (setq end (point))
+ (goto-char beg)
+ (and (let ((case-fold-search t))
+ (search-forward "module:" end t))
+ (progn
+ (skip-chars-forward " \t")
+ (setq beg (point))
+ (if (search-forward ";" end t)
+ (forward-char -1)
+ (goto-char end))
+ (skip-chars-backward " \t")
+ (buffer-substring beg (point)))))))))
+
+(defun prolog-build-prolog-command (compilep file buffername
+ &optional first-line)
+ "Make Prolog command for FILE compilation/consulting.
+If COMPILEP is non-nil, consider compilation, otherwise consulting."
+ (let* ((compile-string
+ ;; FIXME: If the process is not running yet, the auto-detection of
+ ;; prolog-system won't help here, so we should make sure
+ ;; we first run Prolog and then build the command.
+ (if compilep (prolog-compile-string) (prolog-consult-string)))
+ (module (prolog-buffer-module))
+ (file-name (concat "'" (prolog-bsts file) "'"))
+ (module-name (if module (concat "'" module "'")))
+ (module-file (if module
+ (concat module-name ":" file-name)
+ file-name))
+ strbeg strend
+ (lineoffset (if first-line
+ (- first-line 1)
+ 0)))
+
+ ;; Assure that there is a buffer name
+ (if (not buffername)
+ (error "The buffer is not saved"))
+
+ (if (not (string-match "\\`'.*'\\'" buffername)) ; Add quotes
+ (setq buffername (concat "'" buffername "'")))
+ (while (string-match "%m" compile-string)
+ (setq strbeg (substring compile-string 0 (match-beginning 0)))
+ (setq strend (substring compile-string (match-end 0)))
+ (setq compile-string (concat strbeg module-file strend)))
+ ;; FIXME: The code below will %-expand any %[fbl] that appears in
+ ;; module-file.
+ (while (string-match "%f" compile-string)
+ (setq strbeg (substring compile-string 0 (match-beginning 0)))
+ (setq strend (substring compile-string (match-end 0)))
+ (setq compile-string (concat strbeg file-name strend)))
+ (while (string-match "%b" compile-string)
+ (setq strbeg (substring compile-string 0 (match-beginning 0)))
+ (setq strend (substring compile-string (match-end 0)))
+ (setq compile-string (concat strbeg buffername strend)))
+ (while (string-match "%l" compile-string)
+ (setq strbeg (substring compile-string 0 (match-beginning 0)))
+ (setq strend (substring compile-string (match-end 0)))
+ (setq compile-string (concat strbeg (format "%d" lineoffset) strend)))
+ (concat compile-string "\n")))
+
+;; The rest of this page is experimental code!
+
+;; Global variables for process filter function
+(defvar prolog-process-flag nil
+ "Non-nil means that a prolog task (i.e. a consultation or compilation job)
+is running.")
+(defvar prolog-consult-compile-output ""
+ "Hold the unprocessed output from the current prolog task.")
+(defvar prolog-consult-compile-first-line 1
+ "The number of the first line of the file to consult/compile.
+Used for temporary files.")
+(defvar prolog-consult-compile-file nil
+ "The file to compile/consult (can be a temporary file).")
+(defvar prolog-consult-compile-real-file nil
+ "The file name of the buffer to compile/consult.")
+
+(defvar compilation-parse-errors-function)
+
+(defun prolog-consult-compile (compilep file &optional first-line)
+ "Consult/compile FILE.
+If COMPILEP is non-nil, perform compilation, otherwise perform CONSULTING.
+COMMAND is a string described by the variables `prolog-consult-string'
+and `prolog-compile-string'.
+Optional argument FIRST-LINE is the number of the first line in the compiled
+region.
+
+This function must be called from the source code buffer."
+ (if prolog-process-flag
+ (error "Another Prolog task is running."))
+ (prolog-ensure-process t)
+ (let* ((buffer (get-buffer-create prolog-compilation-buffer))
+ (real-file buffer-file-name)
+ (command-string (prolog-build-prolog-command compilep file
+ real-file first-line))
+ (process (get-process "prolog"))
+ (old-filter (process-filter process)))
+ (with-current-buffer buffer
+ (delete-region (point-min) (point-max))
+ ;; FIXME: Wasn't this supposed to use prolog-inferior-mode?
+ (compilation-mode)
+ ;; FIXME: This doesn't seem to cooperate well with new(ish) compile.el.
+ ;; Setting up font-locking for this buffer
+ (set (make-local-variable 'font-lock-defaults)
+ '(prolog-font-lock-keywords nil nil ((?_ . "w"))))
+ (if (eq prolog-system 'sicstus)
+ ;; FIXME: This looks really problematic: not only is this using
+ ;; the old compilation-parse-errors-function, but
+ ;; prolog-parse-sicstus-compilation-errors only accepts one argument
+ ;; whereas compile.el calls it with 2 (and did so at least since
+ ;; Emacs-20).
+ (set (make-local-variable 'compilation-parse-errors-function)
+ 'prolog-parse-sicstus-compilation-errors))
+ (toggle-read-only 0)
+ (insert command-string "\n"))
+ (save-selected-window
+ (pop-to-buffer buffer))
+ (setq prolog-process-flag t
+ prolog-consult-compile-output ""
+ prolog-consult-compile-first-line (if first-line (1- first-line) 0)
+ prolog-consult-compile-file file
+ prolog-consult-compile-real-file (if (string=
+ file buffer-file-name)
+ nil
+ real-file))
+ (with-current-buffer buffer
+ (goto-char (point-max))
+ (set-process-filter process 'prolog-consult-compile-filter)
+ (process-send-string "prolog" command-string)
+ ;; (prolog-build-prolog-command compilep file real-file first-line))
+ (while (and prolog-process-flag
+ (accept-process-output process 10)) ; 10 secs is ok?
+ (sit-for 0.1)
+ (unless (get-process "prolog")
+ (setq prolog-process-flag nil)))
+ (insert (if compilep
+ "\nCompilation finished.\n"
+ "\nConsulted.\n"))
+ (set-process-filter process old-filter))))
+
+(defvar compilation-error-list)
+
+(defun prolog-parse-sicstus-compilation-errors (limit)
+ "Parse the prolog compilation buffer for errors.
+Argument LIMIT is a buffer position limiting searching.
+For use with the `compilation-parse-errors-function' variable."
+ (setq compilation-error-list nil)
+ (message "Parsing SICStus error messages...")
+ (let (filepath dir file errorline)
+ (while
+ (re-search-backward
+ "{\\([a-zA-Z ]* ERROR\\|Warning\\):.* in line[s ]*\\([0-9]+\\)"
+ limit t)
+ (setq errorline (string-to-number (match-string 2)))
+ (save-excursion
+ (re-search-backward
+ "{\\(consulting\\|compiling\\|processing\\) \\(.*\\)\\.\\.\\.}"
+ limit t)
+ (setq filepath (match-string 2)))
+
+ ;; ###### Does this work with SICStus under Windows (i.e. backslahes and stuff?)
+ (if (string-match "\\(.*/\\)\\([^/]*\\)$" filepath)
+ (progn
+ (setq dir (match-string 1 filepath))
+ (setq file (match-string 2 filepath))))
+
+ (setq compilation-error-list
+ (cons
+ (cons (save-excursion
+ (beginning-of-line)
+ (point-marker))
+ (list (list file dir) errorline))
+ compilation-error-list)
+ ))
+ ))
+
+(defun prolog-consult-compile-filter (process output)
+ "Filter function for Prolog compilation PROCESS.
+Argument OUTPUT is a name of the output file."
+ ;;(message "start")
+ (setq prolog-consult-compile-output
+ (concat prolog-consult-compile-output output))
+ ;;(message "pccf1: %s" prolog-consult-compile-output)
+ ;; Iterate through the lines of prolog-consult-compile-output
+ (let (outputtype)
+ (while (and prolog-process-flag
+ (or
+ ;; Trace question
+ (progn
+ (setq outputtype 'trace)
+ (and (eq prolog-system 'sicstus)
+ (string-match
+ "^[ \t]*[0-9]+[ \t]*[0-9]+[ \t]*Call:.*? "
+ prolog-consult-compile-output)))
+
+ ;; Match anything
+ (progn
+ (setq outputtype 'normal)
+ (string-match "^.*\n" prolog-consult-compile-output))
+ ))
+ ;;(message "outputtype: %s" outputtype)
+
+ (setq output (match-string 0 prolog-consult-compile-output))
+ ;; remove the text in output from prolog-consult-compile-output
+ (setq prolog-consult-compile-output
+ (substring prolog-consult-compile-output (length output)))
+ ;;(message "pccf2: %s" prolog-consult-compile-output)
+
+ ;; If temporary files were used, then we change the error
+ ;; messages to point to the original source file.
+ ;; FIXME: Use compilation-fake-loc instead.
+ (cond
+
+ ;; If the prolog process was in trace mode then it requires
+ ;; user input
+ ((and (eq prolog-system 'sicstus)
+ (eq outputtype 'trace))
+ (let ((input (concat (read-string output) "\n")))
+ (process-send-string process input)
+ (setq output (concat output input))))
+
+ ((eq prolog-system 'sicstus)
+ (if (and prolog-consult-compile-real-file
+ (string-match
+ "\\({.*:.* in line[s ]*\\)\\([0-9]+\\)-\\([0-9]+\\)" output))
+ (setq output (replace-match
+ ;; Adds a {processing ...} line so that
+ ;; `prolog-parse-sicstus-compilation-errors'
+ ;; finds the real file instead of the temporary one.
+ ;; Also fixes the line numbers.
+ (format "Added by Emacs: {processing %s...}\n%s%d-%d"
+ prolog-consult-compile-real-file
+ (match-string 1 output)
+ (+ prolog-consult-compile-first-line
+ (string-to-number
+ (match-string 2 output)))
+ (+ prolog-consult-compile-first-line
+ (string-to-number
+ (match-string 3 output))))
+ t t output)))
+ )
+
+ ((eq prolog-system 'swi)
+ (if (and prolog-consult-compile-real-file
+ (string-match (format
+ "%s\\([ \t]*:[ \t]*\\)\\([0-9]+\\)"
+ prolog-consult-compile-file)
+ output))
+ (setq output (replace-match
+ ;; Real filename + text + fixed linenum
+ (format "%s%s%d"
+ prolog-consult-compile-real-file
+ (match-string 1 output)
+ (+ prolog-consult-compile-first-line
+ (string-to-number
+ (match-string 2 output))))
+ t t output)))
+ )
+
+ (t ())
+ )
+ ;; Write the output in the *prolog-compilation* buffer
+ (insert output)))
+
+ ;; If the prompt is visible, then the task is finished
+ (if (string-match (prolog-prompt-regexp) prolog-consult-compile-output)
+ (setq prolog-process-flag nil)))
+
+(defun prolog-consult-compile-file (compilep)
+ "Consult/compile file of current buffer.
+If COMPILEP is non-nil, compile, otherwise consult."
+ (let ((file buffer-file-name))
+ (if file
+ (progn
+ (save-some-buffers)
+ (prolog-consult-compile compilep file))
+ (prolog-consult-compile-region compilep (point-min) (point-max)))))
+
+(defun prolog-consult-compile-buffer (compilep)
+ "Consult/compile current buffer.
+If COMPILEP is non-nil, compile, otherwise consult."
+ (prolog-consult-compile-region compilep (point-min) (point-max)))
+
+(defun prolog-consult-compile-region (compilep beg end)
+ "Consult/compile region between BEG and END.
+If COMPILEP is non-nil, compile, otherwise consult."
+ ;(let ((file prolog-temp-filename)
+ (let ((file (prolog-bsts (prolog-temporary-file)))
+ (lines (count-lines 1 beg)))
+ (write-region beg end file nil 'no-message)
+ (write-region "\n" nil file t 'no-message)
+ (prolog-consult-compile compilep file
+ (if (bolp) (1+ lines) lines))
+ (delete-file file)))
+
+(defun prolog-consult-compile-predicate (compilep)
+ "Consult/compile the predicate around current point.
+If COMPILEP is non-nil, compile, otherwise consult."
+ (prolog-consult-compile-region
+ compilep (prolog-pred-start) (prolog-pred-end)))
+
+
+;;-------------------------------------------------------------------
+;; Font-lock stuff
+;;-------------------------------------------------------------------
+
+;; Auxiliary functions
+(defun prolog-make-keywords-regexp (keywords &optional protect)
+ "Create regexp from the list of strings KEYWORDS.
+If PROTECT is non-nil, surround the result regexp by word breaks."
+ (let ((regexp
+ (if (fboundp 'regexp-opt)
+ ;; Emacs 20
+ ;; Avoid compile warnings under earlier versions by using eval
+ (eval '(regexp-opt keywords))
+ ;; Older Emacsen
+ (concat (mapconcat 'regexp-quote keywords "\\|")))
+ ))
+ (if protect
+ (concat "\\<\\(" regexp "\\)\\>")
+ regexp)))
+
+(defun prolog-font-lock-object-matcher (bound)
+ "Find SICStus objects method name for font lock.
+Argument BOUND is a buffer position limiting searching."
+ (let (point
+ (case-fold-search nil))
+ (while (and (not point)
+ (re-search-forward "\\(::[ \t\n]*{\\|&\\)[ \t]*"
+ bound t))
+ (while (or (re-search-forward "\\=\n[ \t]*" bound t)
+ (re-search-forward "\\=%.*" bound t)
+ (and (re-search-forward "\\=/\\*" bound t)
+ (re-search-forward "\\*/[ \t]*" bound t))))
+ (setq point (re-search-forward
+ (format "\\=\\(%s\\)" prolog-atom-regexp)
+ bound t)))
+ point))
+
+(defsubst prolog-face-name-p (facename)
+ ;; Return t if FACENAME is the name of a face. This method is
+ ;; necessary since facep in XEmacs only returns t for the actual
+ ;; face objects (while it's only their names that are used just
+ ;; about anywhere else) without providing a predicate that tests
+ ;; face names. This function (including the above commentary) is
+ ;; borrowed from cc-mode.
+ (memq facename (face-list)))
+
+;; Set everything up
+(defun prolog-font-lock-keywords ()
+ "Set up font lock keywords for the current Prolog system."
+ ;(when window-system
+ (require 'font-lock)
+
+ ;; Define Prolog faces
+ (defface prolog-redo-face
+ '((((class grayscale)) (:italic t))
+ (((class color)) (:foreground "darkorchid"))
+ (t (:italic t)))
+ "Prolog mode face for highlighting redo trace lines."
+ :group 'prolog-faces)
+ (defface prolog-exit-face
+ '((((class grayscale)) (:underline t))
+ (((class color) (background dark)) (:foreground "green"))
+ (((class color) (background light)) (:foreground "ForestGreen"))
+ (t (:underline t)))
+ "Prolog mode face for highlighting exit trace lines."
+ :group 'prolog-faces)
+ (defface prolog-exception-face
+ '((((class grayscale)) (:bold t :italic t :underline t))
+ (((class color)) (:bold t :foreground "black" :background "Khaki"))
+ (t (:bold t :italic t :underline t)))
+ "Prolog mode face for highlighting exception trace lines."
+ :group 'prolog-faces)
+ (defface prolog-warning-face
+ '((((class grayscale)) (:underline t))
+ (((class color) (background dark)) (:foreground "blue"))
+ (((class color) (background light)) (:foreground "MidnightBlue"))
+ (t (:underline t)))
+ "Face name to use for compiler warnings."
+ :group 'prolog-faces)
+ (defface prolog-builtin-face
+ '((((class color) (background light)) (:foreground "Purple"))
+ (((class color) (background dark)) (:foreground "Cyan"))
+ (((class grayscale) (background light)) (:foreground "LightGray" :bold t))
+ (((class grayscale) (background dark)) (:foreground "DimGray" :bold t))
+ (t (:bold t)))
+ "Face name to use for compiler warnings."
+ :group 'prolog-faces)
+ (defvar prolog-warning-face
+ (if (prolog-face-name-p 'font-lock-warning-face)
+ 'font-lock-warning-face
+ 'prolog-warning-face)
+ "Face name to use for built in predicates.")
+ (defvar prolog-builtin-face
+ (if (prolog-face-name-p 'font-lock-builtin-face)
+ 'font-lock-builtin-face
+ 'prolog-builtin-face)
+ "Face name to use for built in predicates.")
+ (defvar prolog-redo-face 'prolog-redo-face
+ "Face name to use for redo trace lines.")
+ (defvar prolog-exit-face 'prolog-exit-face
+ "Face name to use for exit trace lines.")
+ (defvar prolog-exception-face 'prolog-exception-face
+ "Face name to use for exception trace lines.")
+
+ ;; Font Lock Patterns
+ (let (
+ ;; "Native" Prolog patterns
+ (head-predicates
+ (list (format "^\\(%s\\)\\((\\|[ \t]*:-\\)" prolog-atom-regexp)
+ 1 font-lock-function-name-face))
+ ;(list (format "^%s" prolog-atom-regexp)
+ ; 0 font-lock-function-name-face))
+ (head-predicates-1
+ (list (format "\\.[ \t]*\\(%s\\)" prolog-atom-regexp)
+ 1 font-lock-function-name-face) )
+ (variables
+ '("\\<\\([_A-Z][a-zA-Z0-9_]*\\)"
+ 1 font-lock-variable-name-face))
+ (important-elements
+ (list (if (eq prolog-system 'mercury)
+ "[][}{;|]\\|\\\\[+=]\\|<?=>?"
+ "[][}{!;|]\\|\\*->")
+ 0 'font-lock-keyword-face))
+ (important-elements-1
+ '("[^-*]\\(->\\)" 1 font-lock-keyword-face))
+ (predspecs ; module:predicate/cardinality
+ (list (format "\\<\\(%s:\\|\\)%s/[0-9]+"
+ prolog-atom-regexp prolog-atom-regexp)
+ 0 font-lock-function-name-face 'prepend))
+ (keywords ; directives (queries)
+ (list
+ (if (eq prolog-system 'mercury)
+ (concat
+ "\\<\\("
+ (prolog-make-keywords-regexp prolog-keywords-i)
+ "\\|"
+ (prolog-make-keywords-regexp
+ prolog-determinism-specificators-i)
+ "\\)\\>")
+ (concat
+ "^[?:]- *\\("
+ (prolog-make-keywords-regexp prolog-keywords-i)
+ "\\)\\>"))
+ 1 prolog-builtin-face))
+ (quoted_atom (list prolog-quoted-atom-regexp
+ 2 'font-lock-string-face 'append))
+ (string (list prolog-string-regexp
+ 1 'font-lock-string-face 'append))
+ ;; SICStus specific patterns
+ (sicstus-object-methods
+ (if (eq prolog-system 'sicstus)
+ '(prolog-font-lock-object-matcher
+ 1 font-lock-function-name-face)))
+ ;; Mercury specific patterns
+ (types
+ (if (eq prolog-system 'mercury)
+ (list
+ (prolog-make-keywords-regexp prolog-types-i t)
+ 0 'font-lock-type-face)))
+ (modes
+ (if (eq prolog-system 'mercury)
+ (list
+ (prolog-make-keywords-regexp prolog-mode-specificators-i t)
+ 0 'font-lock-reference-face)))
+ (directives
+ (if (eq prolog-system 'mercury)
+ (list
+ (prolog-make-keywords-regexp prolog-directives-i t)
+ 0 'prolog-warning-face)))
+ ;; Inferior mode specific patterns
+ (prompt
+ ;; FIXME: Should be handled by comint already.
+ (list (prolog-prompt-regexp) 0 'font-lock-keyword-face))
+ (trace-exit
+ ;; FIXME: Add to compilation-error-regexp-alist instead.
+ (cond
+ ((eq prolog-system 'sicstus)
+ '("[ \t]*[0-9]+[ \t]+[0-9]+[ \t]*\\(Exit\\):"
+ 1 prolog-exit-face))
+ ((eq prolog-system 'swi)
+ '("[ \t]*\\(Exit\\):[ \t]*([ \t0-9]*)" 1 prolog-exit-face))
+ (t nil)))
+ (trace-fail
+ ;; FIXME: Add to compilation-error-regexp-alist instead.
+ (cond
+ ((eq prolog-system 'sicstus)
+ '("[ \t]*[0-9]+[ \t]+[0-9]+[ \t]*\\(Fail\\):"
+ 1 prolog-warning-face))
+ ((eq prolog-system 'swi)
+ '("[ \t]*\\(Fail\\):[ \t]*([ \t0-9]*)" 1 prolog-warning-face))
+ (t nil)))
+ (trace-redo
+ ;; FIXME: Add to compilation-error-regexp-alist instead.
+ (cond
+ ((eq prolog-system 'sicstus)
+ '("[ \t]*[0-9]+[ \t]+[0-9]+[ \t]*\\(Redo\\):"
+ 1 prolog-redo-face))
+ ((eq prolog-system 'swi)
+ '("[ \t]*\\(Redo\\):[ \t]*([ \t0-9]*)" 1 prolog-redo-face))
+ (t nil)))
+ (trace-call
+ ;; FIXME: Add to compilation-error-regexp-alist instead.
+ (cond
+ ((eq prolog-system 'sicstus)
+ '("[ \t]*[0-9]+[ \t]+[0-9]+[ \t]*\\(Call\\):"
+ 1 font-lock-function-name-face))
+ ((eq prolog-system 'swi)
+ '("[ \t]*\\(Call\\):[ \t]*([ \t0-9]*)"
+ 1 font-lock-function-name-face))
+ (t nil)))
+ (trace-exception
+ ;; FIXME: Add to compilation-error-regexp-alist instead.
+ (cond
+ ((eq prolog-system 'sicstus)
+ '("[ \t]*[0-9]+[ \t]+[0-9]+[ \t]*\\(Exception\\):"
+ 1 prolog-exception-face))
+ ((eq prolog-system 'swi)
+ '("[ \t]*\\(Exception\\):[ \t]*([ \t0-9]*)"
+ 1 prolog-exception-face))
+ (t nil)))
+ (error-message-identifier
+ ;; FIXME: Add to compilation-error-regexp-alist instead.
+ (cond
+ ((eq prolog-system 'sicstus)
+ '("{\\([A-Z]* ?ERROR:\\)" 1 prolog-exception-face prepend))
+ ((eq prolog-system 'swi)
+ '("^[[]\\(WARNING:\\)" 1 prolog-builtin-face prepend))
+ (t nil)))
+ (error-whole-messages
+ ;; FIXME: Add to compilation-error-regexp-alist instead.
+ (cond
+ ((eq prolog-system 'sicstus)
+ '("{\\([A-Z]* ?ERROR:.*\\)}[ \t]*$"
+ 1 font-lock-comment-face append))
+ ((eq prolog-system 'swi)
+ '("^[[]WARNING:[^]]*[]]$" 0 font-lock-comment-face append))
+ (t nil)))
+ (error-warning-messages
+ ;; FIXME: Add to compilation-error-regexp-alist instead.
+ ;; Mostly errors that SICStus asks the user about how to solve,
+ ;; such as "NAME CLASH:" for example.
+ (cond
+ ((eq prolog-system 'sicstus)
+ '("^[A-Z ]*[A-Z]+:" 0 prolog-warning-face))
+ (t nil)))
+ (warning-messages
+ ;; FIXME: Add to compilation-error-regexp-alist instead.
+ (cond
+ ((eq prolog-system 'sicstus)
+ '("\\({ ?\\(Warning\\|WARNING\\) ?:.*}\\)[ \t]*$"
+ 2 prolog-warning-face prepend))
+ (t nil))))
+
+ ;; Make font lock list
+ (delq
+ nil
+ (cond
+ ((eq major-mode 'prolog-mode)
+ (list
+ head-predicates
+ head-predicates-1
+ quoted_atom
+ string
+ variables
+ important-elements
+ important-elements-1
+ predspecs
+ keywords
+ sicstus-object-methods
+ types
+ modes
+ directives))
+ ((eq major-mode 'prolog-inferior-mode)
+ (list
+ prompt
+ error-message-identifier
+ error-whole-messages
+ error-warning-messages
+ warning-messages
+ predspecs
+ trace-exit
+ trace-fail
+ trace-redo
+ trace-call
+ trace-exception))
+ ((eq major-mode 'compilation-mode)
+ (list
+ error-message-identifier
+ error-whole-messages
+ error-warning-messages
+ warning-messages
+ predspecs))))
+ ))
+
+
+;;-------------------------------------------------------------------
+;; Indentation stuff
+;;-------------------------------------------------------------------
+
+;; NB: This function *MUST* have this optional argument since XEmacs
+;; assumes it. This does not mean we have to use it...
+(defun prolog-indent-line (&optional _whole-exp)
+ "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)
+ (skip-chars-forward " \t")
+ (indent-line-to indent)
+ (if (> (- (point-max) pos) (point))
+ (goto-char (- (point-max) pos)))
+
+ ;; Align comments
+ (if (and prolog-align-comments-flag
(save-excursion
- (goto-char (- pmark 3))
- (looking-at " \\? ")))
- ;; This is GNU prolog waiting to know whether you want more answers
- ;; or not (or abort, etc...). The answer is a single char, not
- ;; a line, so pass this char directly rather than wait for RET to
- ;; send a whole line.
- (comint-send-string proc (string last-command-event))
- (call-interactively 'self-insert-command))))
+ (line-beginning-position)
+ ;; (let ((start (comment-search-forward (line-end-position) t)))
+ ;; (and start ;There's a comment to indent.
+ ;; ;; If it's first on the line, we've indented it already
+ ;; ;; and prolog-goto-comment-column would inf-loop.
+ ;; (progn (goto-char start) (skip-chars-backward " \t")
+ ;; (not (bolp)))))))
+ (and (looking-at comment-start-skip)
+ ;; The definition of comment-start-skip used in this
+ ;; mode is unusual in that it only matches at BOL.
+ (progn (skip-chars-forward " \t")
+ (not (eq (point) (match-end 1)))))))
+ (save-excursion
+ (prolog-goto-comment-column t)))
-(defun prolog-consult-region (compile beg end)
- "Send the region to the Prolog process made by \"M-x run-prolog\".
-If COMPILE (prefix arg) is not nil, use compile mode rather than consult mode."
- (interactive "P\nr")
- (let ((proc (inferior-prolog-process)))
- (comint-send-string proc
- (if compile prolog-compile-string
- prolog-consult-string))
- (comint-send-region proc beg end)
- (comint-send-string proc "\n") ;May be unnecessary
- (if prolog-eof-string
- (comint-send-string proc prolog-eof-string)
- (with-current-buffer (process-buffer proc)
- (comint-send-eof))))) ;Send eof to prolog process.
-
-(defun prolog-consult-region-and-go (compile beg end)
- "Send the region to the inferior Prolog, and switch to *prolog* buffer.
-If COMPILE (prefix arg) is not nil, use compile mode rather than consult mode."
- (interactive "P\nr")
- (prolog-consult-region compile beg end)
- (pop-to-buffer inferior-prolog-buffer))
-
-;; inferior-prolog-mode uses the autoloaded compilation-shell-minor-mode.
-(declare-function compilation-forget-errors "compile" ())
+ ;; Insert spaces if needed
+ (if (or prolog-electric-tab-flag prolog-electric-if-then-else-flag)
+ (prolog-insert-spaces-after-paren))
+ ))
+
+(defun prolog-comment-indent ()
+ "Compute prolog comment indentation."
+ ;; FIXME: Only difference with default behavior is that %%% is not
+ ;; flushed to column 0 but just left where the user put it.
+ (cond ((looking-at "%%%") (prolog-indentation-level-of-line))
+ ((looking-at "%%") (prolog-indent-level))
+ (t
+ (save-excursion
+ (skip-chars-backward " \t")
+ ;; Insert one space at least, except at left margin.
+ (max (+ (current-column) (if (bolp) 0 1))
+ comment-column)))
+ ))
+
+(defun prolog-indent-level ()
+ "Compute prolog indentation level."
+ (save-excursion
+ (beginning-of-line)
+ (let ((totbal (prolog-region-paren-balance
+ (prolog-clause-start t) (point)))
+ (oldpoint (point)))
+ (skip-chars-forward " \t")
+ (cond
+ ((looking-at "%%%") (prolog-indentation-level-of-line))
+ ;Large comment starts
+ ((looking-at "%[^%]") comment-column) ;Small comment starts
+ ((bobp) 0) ;Beginning of buffer
+
+ ;; If we found '}' then we must check if it's the
+ ;; end of an object declaration or something else.
+ ((and (looking-at "}")
+ (save-excursion
+ (forward-char 1)
+ ;; Goto to matching {
+ (if prolog-use-prolog-tokenizer-flag
+ (prolog-backward-list)
+ (backward-list))
+ (skip-chars-backward " \t")
+ (backward-char 2)
+ (looking-at "::")))
+ ;; It was an object
+ (if prolog-object-end-to-0-flag
+ 0
+ prolog-indent-width))
+
+ ;;End of /* */ comment
+ ((looking-at "\\*/")
+ (save-excursion
+ (prolog-find-start-of-mline-comment)
+ (skip-chars-backward " \t")
+ (- (current-column) 2)))
+
+ ;; Here we check if the current line is within a /* */ pair
+ ((and (looking-at "[^%/]")
+ (eq (prolog-in-string-or-comment) 'cmt))
+ (if prolog-indent-mline-comments-flag
+ (prolog-find-start-of-mline-comment)
+ ;; Same as before
+ (prolog-indentation-level-of-line)))
+
+ (t
+ (let ((empty t) ind linebal)
+ ;; See previous indentation
+ (while empty
+ (forward-line -1)
+ (beginning-of-line)
+ (if (bobp)
+ (setq empty nil)
+ (skip-chars-forward " \t")
+ (if (not (or (not (member (prolog-in-string-or-comment)
+ '(nil txt)))
+ (looking-at "%")
+ (looking-at "\n")))
+ (setq empty nil))))
+
+ ;; Store this line's indentation
+ (setq ind (if (bobp)
+ 0 ;Beginning of buffer.
+ (current-column))) ;Beginning of clause.
+
+ ;; Compute the balance of the line
+ (setq linebal (prolog-paren-balance))
+ ;;(message "bal of previous line %d totbal %d" linebal totbal)
+ (if (< linebal 0)
+ (progn
+ ;; Add 'indent-level' mode to find-unmatched-paren instead?
+ (end-of-line)
+ (setq ind (prolog-find-indent-of-matching-paren))))
+
+ ;;(message "ind %d" ind)
+ (beginning-of-line)
+
+ ;; Check if the line ends with ":-", ".", ":: {", "}" (might be
+ ;; unnecessary), "&" or ")" (The last four concerns SICStus objects)
+ (cond
+ ;; If the last char of the line is a '&' then set the indent level
+ ;; to prolog-indent-width (used in SICStus objects)
+ ((and (eq prolog-system 'sicstus)
+ (looking-at ".+&[ \t]*\\(%.*\\|\\)$"))
+ (setq ind prolog-indent-width))
+
+ ;; Increase indentation if the previous line was the head of a rule
+ ;; and does not contain a '.'
+ ((and (looking-at (format ".*%s[^\\.]*[ \t]*\\(%%.*\\|\\)$"
+ prolog-head-delimiter))
+ ;; We must check that the match is at a paren balance of 0.
+ (save-excursion
+ (let ((p (point)))
+ (re-search-forward prolog-head-delimiter)
+ (>= 0 (prolog-region-paren-balance p (point))))))
+ (let ((headindent
+ (if (< (prolog-paren-balance) 0)
+ (save-excursion
+ (end-of-line)
+ (prolog-find-indent-of-matching-paren))
+ (prolog-indentation-level-of-line))))
+ (setq ind (+ headindent prolog-indent-width))))
+
+ ;; The previous line was the head of an object
+ ((looking-at ".+ *::.*{[ \t]*$")
+ (setq ind prolog-indent-width))
+
+ ;; If a '.' is found at the end of the previous line, then
+ ;; decrease the indentation. (The \\(%.*\\|\\) part of the
+ ;; regexp is for comments at the end of the line)
+ ((and (looking-at "^.+\\.[ \t]*\\(%.*\\|\\)$")
+ ;; Make sure that the '.' found is not in a comment or string
+ (save-excursion
+ (end-of-line)
+ (re-search-backward "\\.[ \t]*\\(%.*\\|\\)$" (point-min))
+ ;; Guard against the real '.' being followed by a
+ ;; commented '.'.
+ (if (eq (prolog-in-string-or-comment) 'cmt)
+ ;; commented out '.'
+ (let ((here (line-beginning-position)))
+ (end-of-line)
+ (re-search-backward "\\.[ \t]*%.*$" here t))
+ (not (prolog-in-string-or-comment))
+ )
+ ))
+ (setq ind 0))
+
+ ;; If a '.' is found at the end of the previous line, then
+ ;; decrease the indentation. (The /\\*.*\\*/ part of the
+ ;; regexp is for C-like comments at the end of the
+ ;; line--can we merge with the case above?).
+ ((and (looking-at "^.+\\.[ \t]*\\(/\\*.*\\|\\)$")
+ ;; Make sure that the '.' found is not in a comment or string
+ (save-excursion
+ (end-of-line)
+ (re-search-backward "\\.[ \t]*\\(/\\*.*\\|\\)$" (point-min))
+ ;; Guard against the real '.' being followed by a
+ ;; commented '.'.
+ (if (eq (prolog-in-string-or-comment) 'cmt)
+ ;; commented out '.'
+ (let ((here (line-beginning-position)))
+ (end-of-line)
+ (re-search-backward "\\.[ \t]*/\\*.*$" here t))
+ (not (prolog-in-string-or-comment))
+ )
+ ))
+ (setq ind 0))
+
+ )
+
+ ;; If the last non comment char is a ',' or left paren or a left-
+ ;; indent-regexp then indent to open parenthesis level
+ (if (and
+ (> totbal 0)
+ ;; SICStus objects have special syntax rules if point is
+ ;; not inside additional parens (objects are defined
+ ;; within {...})
+ (not (and (eq prolog-system 'sicstus)
+ (= totbal 1)
+ (prolog-in-object))))
+ (if (looking-at
+ (format "\\(%s\\|%s\\|0'.\\|[0-9]+'[0-9a-zA-Z]+\\|[^\n\'\"%%]\\)*\\(,\\|%s\\|%s\\)\[ \t]*\\(%%.*\\|\\)$"
+ prolog-quoted-atom-regexp prolog-string-regexp
+ prolog-left-paren prolog-left-indent-regexp))
+ (progn
+ (goto-char oldpoint)
+ (setq ind (prolog-find-unmatched-paren
+ (if prolog-paren-indent-p
+ 'termdependent
+ 'skipwhite)))
+ ;;(setq ind (prolog-find-unmatched-paren 'termdependent))
+ )
+ (goto-char oldpoint)
+ (setq ind (prolog-find-unmatched-paren nil))
+ ))
+
+
+ ;; Return the indentation level
+ ind
+ ))))))
+
+(defun prolog-find-indent-of-matching-paren ()
+ "Find the indentation level based on the matching parenthesis.
+Indentation level is set to the one the point is after when the function is
+called."
+ (save-excursion
+ ;; Go to the matching paren
+ (if prolog-use-prolog-tokenizer-flag
+ (prolog-backward-list)
+ (backward-list))
+
+ ;; If this was the first paren on the line then return this line's
+ ;; indentation level
+ (if (prolog-paren-is-the-first-on-line-p)
+ (prolog-indentation-level-of-line)
+ ;; It was not the first one
+ (progn
+ ;; Find the next paren
+ (prolog-goto-next-paren 0)
+
+ ;; If this paren is a left one then use its column as indent level,
+ ;; if not then recurse this function
+ (if (looking-at prolog-left-paren)
+ (+ (current-column) 1)
+ (progn
+ (forward-char 1)
+ (prolog-find-indent-of-matching-paren)))
+ ))
+ ))
+
+(defun prolog-indentation-level-of-line ()
+ "Return the indentation level of the current line."
+ (save-excursion
+ (beginning-of-line)
+ (skip-chars-forward " \t")
+ (current-column)))
+
+(defun prolog-paren-is-the-first-on-line-p ()
+ "Return t if the parenthesis under the point is the first one on the line.
+Return nil otherwise.
+Note: does not check if the point is actually at a parenthesis!"
+ (save-excursion
+ (let ((begofline (line-beginning-position)))
+ (if (= begofline (point))
+ t
+ (if (prolog-goto-next-paren begofline)
+ nil
+ t)))))
+
+(defun prolog-find-unmatched-paren (&optional mode)
+ "Return the column of the last unmatched left parenthesis.
+If MODE is `skipwhite' then any white space after the parenthesis is added to
+the answer.
+If MODE is `plusone' then the parenthesis' column +1 is returned.
+If MODE is `termdependent' then if the unmatched parenthesis is part of
+a compound term the function will work as `skipwhite', otherwise
+it will return the column paren plus the value of `prolog-paren-indent'.
+If MODE is nil or not set then the parenthesis' exact column is returned."
+ (save-excursion
+ ;; If the next paren we find is a left one we're finished, if it's
+ ;; a right one then we go back one step and recurse
+ (prolog-goto-next-paren 0)
+
+ (let ((roundparen (looking-at "(")))
+ (if (looking-at prolog-left-paren)
+ (let ((not-part-of-term
+ (save-excursion
+ (backward-char 1)
+ (looking-at "[ \t]"))))
+ (if (eq mode nil)
+ (current-column)
+ (if (and roundparen
+ (eq mode 'termdependent)
+ not-part-of-term)
+ (+ (current-column)
+ (if prolog-electric-tab-flag
+ ;; Electric TAB
+ prolog-paren-indent
+ ;; Not electric TAB
+ (if (looking-at ".[ \t]*$")
+ 2
+ prolog-paren-indent))
+ )
+
+ (forward-char 1)
+ (if (or (eq mode 'skipwhite) (eq mode 'termdependent) )
+ (skip-chars-forward " \t"))
+ (current-column))))
+ ;; Not looking at left paren
+ (progn
+ (forward-char 1)
+ ;; Go to the matching paren. When we get there we have a total
+ ;; balance of 0.
+ (if prolog-use-prolog-tokenizer-flag
+ (prolog-backward-list)
+ (backward-list))
+ (prolog-find-unmatched-paren mode)))
+ )))
+
+
+(defun prolog-paren-balance ()
+ "Return the parenthesis balance of the current line.
+A return value of n means n more left parentheses than right ones."
+ (save-excursion
+ (end-of-line)
+ (prolog-region-paren-balance (line-beginning-position) (point))))
+
+(defun prolog-region-paren-balance (beg end)
+ "Return the summed parenthesis balance in the region.
+The region is limited by BEG and END positions."
+ (save-excursion
+ (let ((state (if prolog-use-prolog-tokenizer-flag
+ (prolog-tokenize beg end)
+ (parse-partial-sexp beg end))))
+ (nth 0 state))))
+
+(defun prolog-goto-next-paren (limit-pos)
+ "Move the point to the next parenthesis earlier in the buffer.
+Return t if a match was found before LIMIT-POS. Return nil otherwise."
+ (let ((retval (re-search-backward
+ (concat prolog-left-paren "\\|" prolog-right-paren)
+ limit-pos t)))
+
+ ;; If a match was found but it was in a string or comment, then recurse
+ (if (and retval (prolog-in-string-or-comment))
+ (prolog-goto-next-paren limit-pos)
+ retval)
+ ))
+
+(defun prolog-in-string-or-comment ()
+ "Check whether string, atom, or comment is under current point.
+Return:
+ `txt' if the point is in a string, atom, or character code expression
+ `cmt' if the point is in a comment
+ nil otherwise."
+ (save-excursion
+ (let* ((start
+ (if (eq prolog-parse-mode 'beg-of-line)
+ ;; 'beg-of-line
+ (save-excursion
+ (let (safepoint)
+ (beginning-of-line)
+ (setq safepoint (point))
+ (while (and (> (point) (point-min))
+ (progn
+ (forward-line -1)
+ (end-of-line)
+ (if (not (bobp))
+ (backward-char 1))
+ (looking-at "\\\\"))
+ )
+ (beginning-of-line)
+ (setq safepoint (point)))
+ safepoint))
+ ;; 'beg-of-clause
+ (prolog-clause-start)))
+ (end (point))
+ (state (if prolog-use-prolog-tokenizer-flag
+ (prolog-tokenize start end)
+ (if (fboundp 'syntax-ppss)
+ (syntax-ppss)
+ (parse-partial-sexp start end)))))
+ (cond
+ ((nth 3 state) 'txt) ; String
+ ((nth 4 state) 'cmt) ; Comment
+ (t
+ (cond
+ ((looking-at "%") 'cmt) ; Start of a comment
+ ((looking-at "/\\*") 'cmt) ; Start of a comment
+ ((looking-at "\'") 'txt) ; Start of an atom
+ ((looking-at "\"") 'txt) ; Start of a string
+ (t nil)
+ ))))
+ ))
+
+(defun prolog-find-start-of-mline-comment ()
+ "Return the start column of a /* */ comment.
+This assumes that the point is inside a comment."
+ (re-search-backward "/\\*" (point-min) t)
+ (forward-char 2)
+ (skip-chars-forward " \t")
+ (current-column))
+
+(defun prolog-insert-spaces-after-paren ()
+ "Insert spaces after the opening parenthesis, \"then\" (->) and \"else\" (;) branches.
+Spaces are inserted if all preceding objects on the line are
+whitespace characters, parentheses, or then/else branches."
+ (save-excursion
+ (let ((regexp (concat "(\\|" prolog-left-indent-regexp))
+ level)
+ (beginning-of-line)
+ (skip-chars-forward " \t")
+ (when (looking-at regexp)
+ ;; Treat "( If -> " lines specially.
+ ;;(setq incr (if (looking-at "(.*->")
+ ;; 2
+ ;; prolog-paren-indent))
+
+ ;; work on all subsequent "->", "(", ";"
+ (while (looking-at regexp)
+ (goto-char (match-end 0))
+ (setq level (+ (prolog-find-unmatched-paren) prolog-paren-indent))
+
+ ;; Remove old white space
+ (let ((start (point)))
+ (skip-chars-forward " \t")
+ (delete-region start (point)))
+ (indent-to level)
+ (skip-chars-forward " \t"))
+ )))
+ (when (save-excursion
+ (backward-char 2)
+ (looking-at "\\s ;\\|\\s (\\|->")) ; (looking-at "\\s \\((\\|;\\)"))
+ (skip-chars-forward " \t"))
+ )
+
+;;;; Comment filling
+
+(defun prolog-comment-limits ()
+ "Return the current comment limits plus the comment type (block or line).
+The comment limits are the range of a block comment or the range that
+contains all adjacent line comments (i.e. all comments that starts in
+the same column with no empty lines or non-whitespace characters
+between them)."
+ (let ((here (point))
+ lit-limits-b lit-limits-e lit-type beg end
+ )
+ (save-restriction
+ ;; Widen to catch comment limits correctly.
+ (widen)
+ (setq end (line-end-position)
+ beg (line-beginning-position))
+ (save-excursion
+ (beginning-of-line)
+ (setq lit-type (if (search-forward-regexp "%" end t) 'line 'block))
+ ; (setq lit-type 'line)
+ ;(if (search-forward-regexp "^[ \t]*%" end t)
+ ; (setq lit-type 'line)
+ ; (if (not (search-forward-regexp "%" end t))
+ ; (setq lit-type 'block)
+ ; (if (not (= (forward-line 1) 0))
+ ; (setq lit-type 'block)
+ ; (setq done t
+ ; ret (prolog-comment-limits)))
+ ; ))
+ (if (eq lit-type 'block)
+ (progn
+ (goto-char here)
+ (when (looking-at "/\\*") (forward-char 2))
+ (when (and (looking-at "\\*") (> (point) (point-min))
+ (forward-char -1) (looking-at "/"))
+ (forward-char 1))
+ (when (save-excursion (search-backward "/*" nil t))
+ (list (save-excursion (search-backward "/*") (point))
+ (or (search-forward "*/" nil t) (point-max)) lit-type)))
+ ;; line comment
+ (setq lit-limits-b (- (point) 1)
+ lit-limits-e end)
+ (condition-case nil
+ (if (progn (goto-char lit-limits-b)
+ (looking-at "%"))
+ (let ((col (current-column)) done)
+ (setq beg (point)
+ end lit-limits-e)
+ ;; Always at the beginning of the comment
+ ;; Go backward now
+ (beginning-of-line)
+ (while (and (zerop (setq done (forward-line -1)))
+ (search-forward-regexp "^[ \t]*%"
+ (line-end-position) t)
+ (= (+ 1 col) (current-column)))
+ (setq beg (- (point) 1)))
+ (when (= done 0)
+ (forward-line 1))
+ ;; We may have a line with code above...
+ (when (and (zerop (setq done (forward-line -1)))
+ (search-forward "%" (line-end-position) t)
+ (= (+ 1 col) (current-column)))
+ (setq beg (- (point) 1)))
+ (when (= done 0)
+ (forward-line 1))
+ ;; Go forward
+ (goto-char lit-limits-b)
+ (beginning-of-line)
+ (while (and (zerop (forward-line 1))
+ (search-forward-regexp "^[ \t]*%"
+ (line-end-position) t)
+ (= (+ 1 col) (current-column)))
+ (setq end (line-end-position)))
+ (list beg end lit-type))
+ (list lit-limits-b lit-limits-e lit-type)
+ )
+ (error (list lit-limits-b lit-limits-e lit-type))))
+ ))))
+
+(defun prolog-guess-fill-prefix ()
+ ;; fill 'txt entities?
+ (when (save-excursion
+ (end-of-line)
+ (equal (prolog-in-string-or-comment) 'cmt))
+ (let* ((bounds (prolog-comment-limits))
+ (cbeg (car bounds))
+ (type (nth 2 bounds))
+ beg end)
+ (save-excursion
+ (end-of-line)
+ (setq end (point))
+ (beginning-of-line)
+ (setq beg (point))
+ (if (and (eq type 'line)
+ (> cbeg beg)
+ (save-excursion (not (search-forward-regexp "^[ \t]*%"
+ cbeg t))))
+ (progn
+ (goto-char cbeg)
+ (search-forward-regexp "%+[ \t]*" end t)
+ (prolog-replace-in-string (buffer-substring beg (point))
+ "[^ \t%]" " "))
+ ;(goto-char beg)
+ (if (search-forward-regexp "^[ \t]*\\(%+\\|\\*+\\|/\\*+\\)[ \t]*"
+ end t)
+ (prolog-replace-in-string (buffer-substring beg (point)) "/" " ")
+ (beginning-of-line)
+ (when (search-forward-regexp "^[ \t]+" end t)
+ (buffer-substring beg (point)))))))))
+
+(defun prolog-fill-paragraph ()
+ "Fill paragraph comment at or after point."
+ (interactive)
+ (let* ((bounds (prolog-comment-limits))
+ (type (nth 2 bounds)))
+ (if (eq type 'line)
+ (let ((fill-prefix (prolog-guess-fill-prefix)))
+ (fill-paragraph nil))
+ (save-excursion
+ (save-restriction
+ ;; exclude surrounding lines that delimit a multiline comment
+ ;; and don't contain alphabetic characters, like "/*******",
+ ;; "- - - */" etc.
+ (save-excursion
+ (backward-paragraph)
+ (unless (bobp) (forward-line))
+ (if (string-match "^/\\*[^a-zA-Z]*$" (thing-at-point 'line))
+ (narrow-to-region (point-at-eol) (point-max))))
+ (save-excursion
+ (forward-paragraph)
+ (forward-line -1)
+ (if (string-match "^[^a-zA-Z]*\\*/$" (thing-at-point 'line))
+ (narrow-to-region (point-min) (point-at-bol))))
+ (let ((fill-prefix (prolog-guess-fill-prefix)))
+ (fill-paragraph nil))))
+ )))
+
+(defun prolog-do-auto-fill ()
+ "Carry out Auto Fill for Prolog mode.
+In effect it sets the `fill-prefix' when inside comments and then calls
+`do-auto-fill'."
+ (let ((fill-prefix (prolog-guess-fill-prefix)))
+ (do-auto-fill)
+ ))
+
+(defalias 'prolog-replace-in-string
+ (if (fboundp 'replace-in-string)
+ #'replace-in-string
+ (lambda (str regexp newtext &optional literal)
+ (replace-regexp-in-string regexp newtext str nil literal))))
+
+;;-------------------------------------------------------------------
+;; The tokenizer
+;;-------------------------------------------------------------------
+
+(defconst prolog-tokenize-searchkey
+ (concat "[0-9]+'"
+ "\\|"
+ "['\"]"
+ "\\|"
+ prolog-left-paren
+ "\\|"
+ prolog-right-paren
+ "\\|"
+ "%"
+ "\\|"
+ "/\\*"
+ ))
+
+(defun prolog-tokenize (beg end &optional stopcond)
+ "Tokenize a region of prolog code between BEG and END.
+STOPCOND decides the stop condition of the parsing. Valid values
+are 'zerodepth which stops the parsing at the first right parenthesis
+where the parenthesis depth is zero, 'skipover which skips over
+the current entity (e.g. a list, a string, etc.) and nil.
+
+The function returns a list with the following information:
+ 0. parenthesis depth
+ 3. 'atm if END is inside an atom
+ 'str if END is inside a string
+ 'chr if END is in a character code expression (0'x)
+ nil otherwise
+ 4. non-nil if END is inside a comment
+ 5. end position (always equal to END if STOPCOND is nil)
+The rest of the elements are undefined."
+ (save-excursion
+ (let* ((end2 (1+ end))
+ oldp
+ (depth 0)
+ (quoted nil)
+ inside_cmt
+ (endpos end2)
+ skiptype ; The type of entity we'll skip over
+ )
+ (goto-char beg)
+
+ (if (and (eq stopcond 'skipover)
+ (looking-at "[^[({'\"]"))
+ (setq endpos (point)) ; Stay where we are
+ (while (and
+ (re-search-forward prolog-tokenize-searchkey end2 t)
+ (< (point) end2))
+ (progn
+ (setq oldp (point))
+ (goto-char (match-beginning 0))
+ (cond
+ ;; Atoms and strings
+ ((looking-at "'")
+ ;; Find end of atom
+ (if (re-search-forward "[^\\]'" end2 'limit)
+ ;; Found end of atom
+ (progn
+ (setq oldp end2)
+ (if (and (eq stopcond 'skipover)
+ (not skiptype))
+ (setq endpos (point))
+ (setq oldp (point)))) ; Continue tokenizing
+ (setq quoted 'atm)))
+
+ ((looking-at "\"")
+ ;; Find end of string
+ (if (re-search-forward "[^\\]\"" end2 'limit)
+ ;; Found end of string
+ (progn
+ (setq oldp end2)
+ (if (and (eq stopcond 'skipover)
+ (not skiptype))
+ (setq endpos (point))
+ (setq oldp (point)))) ; Continue tokenizing
+ (setq quoted 'str)))
+
+ ;; Paren stuff
+ ((looking-at prolog-left-paren)
+ (setq depth (1+ depth))
+ (setq skiptype 'paren))
+
+ ((looking-at prolog-right-paren)
+ (setq depth (1- depth))
+ (if (and
+ (or (eq stopcond 'zerodepth)
+ (and (eq stopcond 'skipover)
+ (eq skiptype 'paren)))
+ (= depth 0))
+ (progn
+ (setq endpos (1+ (point)))
+ (setq oldp end2))))
+
+ ;; Comment stuff
+ ((looking-at comment-start)
+ (end-of-line)
+ ;; (if (>= (point) end2)
+ (if (>= (point) end)
+ (progn
+ (setq inside_cmt t)
+ (setq oldp end2))
+ (setq oldp (point))))
+
+ ((looking-at "/\\*")
+ (if (re-search-forward "\\*/" end2 'limit)
+ (setq oldp (point))
+ (setq inside_cmt t)
+ (setq oldp end2)))
+
+ ;; 0'char
+ ((looking-at "0'")
+ (setq oldp (1+ (match-end 0)))
+ (if (> oldp end)
+ (setq quoted 'chr)))
+
+ ;; base'number
+ ((looking-at "[0-9]+'")
+ (goto-char (match-end 0))
+ (skip-chars-forward "0-9a-zA-Z")
+ (setq oldp (point)))
+
+
+ )
+ (goto-char oldp)
+ )) ; End of while
+ )
+
+ ;; Deal with multi-line comments
+ (and (prolog-inside-mline-comment end)
+ (setq inside_cmt t))
+
+ ;; Create return list
+ (list depth nil nil quoted inside_cmt endpos)
+ )))
+
+(defun prolog-inside-mline-comment (here)
+ (save-excursion
+ (goto-char here)
+ (let* ((next-close (save-excursion (search-forward "*/" nil t)))
+ (next-open (save-excursion (search-forward "/*" nil t)))
+ (prev-open (save-excursion (search-backward "/*" nil t)))
+ (prev-close (save-excursion (search-backward "*/" nil t)))
+ (unmatched-next-close (and next-close
+ (or (not next-open)
+ (> next-open next-close))))
+ (unmatched-prev-open (and prev-open
+ (or (not prev-close)
+ (> prev-open prev-close))))
+ )
+ (or unmatched-next-close unmatched-prev-open)
+ )))
+
+
+;;-------------------------------------------------------------------
+;; Online help
+;;-------------------------------------------------------------------
+
+(defvar prolog-help-function
+ '((mercury nil)
+ (eclipse prolog-help-online)
+ ;; (sicstus prolog-help-info)
+ (sicstus prolog-find-documentation)
+ (swi prolog-help-online)
+ (t prolog-help-online))
+ "Alist for the name of the function for finding help on a predicate.")
+
+(defun prolog-help-on-predicate ()
+ "Invoke online help on the atom under cursor."
+ (interactive)
+
+ (cond
+ ;; Redirect help for SICStus to `prolog-find-documentation'.
+ ((eq prolog-help-function-i 'prolog-find-documentation)
+ (prolog-find-documentation))
+
+ ;; Otherwise, ask for the predicate name and then call the function
+ ;; in prolog-help-function-i
+ (t
+ (let* ((word (prolog-atom-under-point))
+ (predicate (read-string
+ (format "Help on predicate%s: "
+ (if word
+ (concat " (default " word ")")
+ ""))
+ nil nil word))
+ ;;point
+ )
+ (if prolog-help-function-i
+ (funcall prolog-help-function-i predicate)
+ (error "Sorry, no help method defined for this Prolog system."))))
+ ))
+
+(defun prolog-help-info (predicate)
+ (let ((buffer (current-buffer))
+ oldp
+ (str (concat "^\\* " (regexp-quote predicate) " */")))
+ (require 'info)
+ (pop-to-buffer nil)
+ (Info-goto-node prolog-info-predicate-index)
+ (if (not (re-search-forward str nil t))
+ (error (format "Help on predicate `%s' not found." predicate)))
+
+ (setq oldp (point))
+ (if (re-search-forward str nil t)
+ ;; Multiple matches, ask user
+ (let ((max 2)
+ n)
+ ;; Count matches
+ (while (re-search-forward str nil t)
+ (setq max (1+ max)))
+
+ (goto-char oldp)
+ (re-search-backward "[^ /]" nil t)
+ (recenter 0)
+ (setq n (read-string ;; was read-input, which is obsolete
+ (format "Several matches, choose (1-%d): " max) "1"))
+ (forward-line (- (string-to-number n) 1)))
+ ;; Single match
+ (re-search-backward "[^ /]" nil t))
+
+ ;; (Info-follow-nearest-node (point))
+ (prolog-Info-follow-nearest-node)
+ (re-search-forward (concat "^`" (regexp-quote predicate)) nil t)
+ (beginning-of-line)
+ (recenter 0)
+ (pop-to-buffer buffer)))
+
+(defun prolog-Info-follow-nearest-node ()
+ (if (featurep 'xemacs)
+ (Info-follow-nearest-node (point))
+ (Info-follow-nearest-node)))
+
+(defun prolog-help-online (predicate)
+ (prolog-ensure-process)
+ (process-send-string "prolog" (concat "help(" predicate ").\n"))
+ (display-buffer "*prolog*"))
+
+(defun prolog-help-apropos (string)
+ "Find Prolog apropos on given STRING.
+This function is only available when `prolog-system' is set to `swi'."
+ (interactive "sApropos: ")
+ (cond
+ ((eq prolog-system 'swi)
+ (prolog-ensure-process)
+ (process-send-string "prolog" (concat "apropos(" string ").\n"))
+ (display-buffer "*prolog*"))
+ (t
+ (error "Sorry, no Prolog apropos available for this Prolog system."))))
+
+(defun prolog-atom-under-point ()
+ "Return the atom under or left to the point."
+ (save-excursion
+ (let ((nonatom_chars "[](){},\. \t\n")
+ start)
+ (skip-chars-forward (concat "^" nonatom_chars))
+ (skip-chars-backward nonatom_chars)
+ (skip-chars-backward (concat "^" nonatom_chars))
+ (setq start (point))
+ (skip-chars-forward (concat "^" nonatom_chars))
+ (buffer-substring-no-properties start (point))
+ )))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Help function with completion
+;; Stolen from Per Mildner's SICStus debugger mode and modified
+
+(defun prolog-find-documentation ()
+ "Go to the Info node for a predicate in the SICStus Info manual."
+ (interactive)
+ (let ((pred (prolog-read-predicate)))
+ (prolog-goto-predicate-info pred)))
+
+(defvar prolog-info-alist nil
+ "Alist with all builtin predicates.
+Only for internal use by `prolog-find-documentation'")
+
+;; Very similar to prolog-help-info except that that function cannot
+;; cope with arity and that it asks the user if there are several
+;; functors with different arity. This function also uses
+;; prolog-info-alist for finding the info node, rather than parsing
+;; the predicate index.
+(defun prolog-goto-predicate-info (predicate)
+ "Go to the info page for PREDICATE, which is a PredSpec."
+ (interactive)
+ (require 'info)
+ (string-match "\\(.*\\)/\\([0-9]+\\).*$" predicate)
+ (let ((buffer (current-buffer))
+ (name (match-string 1 predicate))
+ (arity (string-to-number (match-string 2 predicate)))
+ ;oldp
+ ;(str (regexp-quote predicate))
+ )
+ (pop-to-buffer nil)
+
+ (Info-goto-node
+ prolog-info-predicate-index) ;; We must be in the SICStus pages
+ (Info-goto-node (car (cdr (assoc predicate prolog-info-alist))))
+
+ (prolog-find-term (regexp-quote name) arity "^`")
+
+ (recenter 0)
+ (pop-to-buffer buffer))
+)
+
+(defun prolog-read-predicate ()
+ "Read a PredSpec from the user.
+Returned value is a string \"FUNCTOR/ARITY\".
+Interaction supports completion."
+ (let ((default (prolog-atom-under-point)))
+ ;; If the predicate index is not yet built, do it now
+ (if (not prolog-info-alist)
+ (prolog-build-info-alist))
+ ;; Test if the default string could be the base for completion.
+ ;; Discard it if not.
+ (if (eq (try-completion default prolog-info-alist) nil)
+ (setq default nil))
+ ;; Read the PredSpec from the user
+ (completing-read
+ (if (zerop (length default))
+ "Help on predicate: "
+ (concat "Help on predicate (default " default "): "))
+ prolog-info-alist nil t nil nil default)))
+
+(defun prolog-build-info-alist (&optional verbose)
+ "Build an alist of all builtins and library predicates.
+Each element is of the form (\"NAME/ARITY\" . (INFO-NODE1 INFO-NODE2 ...)).
+Typically there is just one Info node associated with each name
+If an optional argument VERBOSE is non-nil, print messages at the beginning
+and end of list building."
+ (if verbose
+ (message "Building info alist..."))
+ (setq prolog-info-alist
+ (let ((l ())
+ (last-entry (cons "" ())))
+ (save-excursion
+ (save-window-excursion
+ ;; select any window but the minibuffer (as we cannot switch
+ ;; buffers in minibuffer window.
+ ;; I am not sure this is the right/best way
+ (if (active-minibuffer-window) ; nil if none active
+ (select-window (next-window)))
+ ;; Do this after going away from minibuffer window
+ (save-window-excursion
+ (info))
+ (Info-goto-node prolog-info-predicate-index)
+ (goto-char (point-min))
+ (while (re-search-forward
+ "^\\* \\(.+\\)/\\([0-9]+\\)\\([^\n:*]*\\):" nil t)
+ (let* ((name (match-string 1))
+ (arity (string-to-number (match-string 2)))
+ (comment (match-string 3))
+ (fa (format "%s/%d%s" name arity comment))
+ info-node)
+ (beginning-of-line)
+ ;; Extract the info node name
+ (setq info-node (progn
+ (re-search-forward ":[ \t]*\\([^:]+\\).$")
+ (match-string 1)
+ ))
+ ;; ###### Easier? (from Milan version 0.1.28)
+ ;; (setq info-node (Info-extract-menu-node-name))
+ (if (equal fa (car last-entry))
+ (setcdr last-entry (cons info-node (cdr last-entry)))
+ (setq last-entry (cons fa (list info-node))
+ l (cons last-entry l)))))
+ (nreverse l)
+ ))))
+ (if verbose
+ (message "Building info alist... done.")))
+
+
+;;-------------------------------------------------------------------
+;; Miscellaneous functions
+;;-------------------------------------------------------------------
+
+;; For Windows. Change backslash to slash. SICStus handles either
+;; path separator but backslash must be doubled, therefore use slash.
+(defun prolog-bsts (string)
+ "Change backslashes to slashes in STRING."
+ (let ((str1 (copy-sequence string))
+ (len (length string))
+ (i 0))
+ (while (< i len)
+ (if (char-equal (aref str1 i) ?\\)
+ (aset str1 i ?/))
+ (setq i (1+ i)))
+ str1))
+
+;;(defun prolog-temporary-file ()
+;; "Make temporary file name for compilation."
+;; (make-temp-name
+;; (concat
+;; (or
+;; (getenv "TMPDIR")
+;; (getenv "TEMP")
+;; (getenv "TMP")
+;; (getenv "SYSTEMP")
+;; "/tmp")
+;; "/prolcomp")))
+;;(setq prolog-temp-filename (prolog-bsts (prolog-temporary-file)))
+
+(defun prolog-temporary-file ()
+ "Make temporary file name for compilation."
+ (if prolog-temporary-file-name
+ ;; We already have a file, erase content and continue
+ (progn
+ (write-region "" nil prolog-temporary-file-name nil 'silent)
+ prolog-temporary-file-name)
+ ;; Actually create the file and set `prolog-temporary-file-name'
+ ;; accordingly.
+ (setq prolog-temporary-file-name
+ (make-temp-file "prolcomp" nil ".pl"))))
+
+(defun prolog-goto-prolog-process-buffer ()
+ "Switch to the prolog process buffer and go to its end."
+ (switch-to-buffer-other-window "*prolog*")
+ (goto-char (point-max))
+)
+
+(defun prolog-enable-sicstus-sd ()
+ "Enable the source level debugging facilities of SICStus 3.7 and later."
+ (interactive)
+ (require 'pltrace) ; Load the SICStus debugger code
+ ;; Turn on the source level debugging by default
+ (add-hook 'prolog-inferior-mode-hook 'pltrace-on)
+ (if (not prolog-use-sicstus-sd)
+ (progn
+ ;; If there is a *prolog* buffer, then call pltrace-on
+ (if (get-buffer "*prolog*")
+ ;; Avoid compilation warnings by using eval
+ (eval '(pltrace-on)))
+ (setq prolog-use-sicstus-sd t)
+ )))
+
+(defun prolog-disable-sicstus-sd ()
+ "Disable the source level debugging facilities of SICStus 3.7 and later."
+ (interactive)
+ (setq prolog-use-sicstus-sd nil)
+ ;; Remove the hook
+ (remove-hook 'prolog-inferior-mode-hook 'pltrace-on)
+ ;; If there is a *prolog* buffer, then call pltrace-off
+ (if (get-buffer "*prolog*")
+ ;; Avoid compile warnings by using eval
+ (eval '(pltrace-off))))
+
+(defun prolog-toggle-sicstus-sd ()
+ ;; FIXME: Use define-minor-mode.
+ "Toggle the source level debugging facilities of SICStus 3.7 and later."
+ (interactive)
+ (if prolog-use-sicstus-sd
+ (prolog-disable-sicstus-sd)
+ (prolog-enable-sicstus-sd)))
+
+(defun prolog-debug-on (&optional arg)
+ "Enable debugging.
+When called with prefix argument ARG, disable debugging instead."
+ (interactive "P")
+ (if arg
+ (prolog-debug-off)
+ (prolog-process-insert-string (get-process "prolog")
+ prolog-debug-on-string)
+ (process-send-string "prolog" prolog-debug-on-string)))
+
+(defun prolog-debug-off ()
+ "Disable debugging."
+ (interactive)
+ (prolog-process-insert-string (get-process "prolog")
+ prolog-debug-off-string)
+ (process-send-string "prolog" prolog-debug-off-string))
+
+(defun prolog-trace-on (&optional arg)
+ "Enable tracing.
+When called with prefix argument ARG, disable tracing instead."
+ (interactive "P")
+ (if arg
+ (prolog-trace-off)
+ (prolog-process-insert-string (get-process "prolog")
+ prolog-trace-on-string)
+ (process-send-string "prolog" prolog-trace-on-string)))
+
+(defun prolog-trace-off ()
+ "Disable tracing."
+ (interactive)
+ (prolog-process-insert-string (get-process "prolog")
+ prolog-trace-off-string)
+ (process-send-string "prolog" prolog-trace-off-string))
+
+(defun prolog-zip-on (&optional arg)
+ "Enable zipping (for SICStus 3.7 and later).
+When called with prefix argument ARG, disable zipping instead."
+ (interactive "P")
+ (if (not (and (eq prolog-system 'sicstus)
+ (prolog-atleast-version '(3 . 7))))
+ (error "Only works for SICStus 3.7 and later"))
+ (if arg
+ (prolog-zip-off)
+ (prolog-process-insert-string (get-process "prolog")
+ prolog-zip-on-string)
+ (process-send-string "prolog" prolog-zip-on-string)))
+
+(defun prolog-zip-off ()
+ "Disable zipping (for SICStus 3.7 and later)."
+ (interactive)
+ (prolog-process-insert-string (get-process "prolog")
+ prolog-zip-off-string)
+ (process-send-string "prolog" prolog-zip-off-string))
+
+;; (defun prolog-create-predicate-index ()
+;; "Create an index for all predicates in the buffer."
+;; (let ((predlist '())
+;; clauseinfo
+;; object
+;; pos
+;; )
+;; (goto-char (point-min))
+;; ;; Replace with prolog-clause-start!
+;; (while (re-search-forward "^.+:-" nil t)
+;; (setq pos (match-beginning 0))
+;; (setq clauseinfo (prolog-clause-info))
+;; (setq object (prolog-in-object))
+;; (setq predlist (append
+;; predlist
+;; (list (cons
+;; (if (and (eq prolog-system 'sicstus)
+;; (prolog-in-object))
+;; (format "%s::%s/%d"
+;; object
+;; (nth 0 clauseinfo)
+;; (nth 1 clauseinfo))
+;; (format "%s/%d"
+;; (nth 0 clauseinfo)
+;; (nth 1 clauseinfo)))
+;; pos
+;; ))))
+;; (prolog-end-of-predicate))
+;; predlist))
+
+(defun prolog-get-predspec ()
+ (save-excursion
+ (let ((state (prolog-clause-info))
+ (object (prolog-in-object)))
+ (if (or (equal (nth 0 state) "") (equal (prolog-in-string-or-comment) 'cmt))
+ nil
+ (if (and (eq prolog-system 'sicstus)
+ object)
+ (format "%s::%s/%d"
+ object
+ (nth 0 state)
+ (nth 1 state))
+ (format "%s/%d"
+ (nth 0 state)
+ (nth 1 state)))
+ ))))
+
+;; For backward compatibility. Stolen from custom.el.
+(or (fboundp 'match-string)
+ ;; Introduced in Emacs 19.29.
+ (defun match-string (num &optional string)
+ "Return string of text matched by last search.
+NUM specifies which parenthesized expression in the last regexp.
+ Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
+Zero means the entire text matched by the whole regexp or whole string.
+STRING should be given if the last search was by `string-match' on STRING."
+ (if (match-beginning num)
+ (if string
+ (substring string (match-beginning num) (match-end num))
+ (buffer-substring (match-beginning num) (match-end num))))))
+
+(defun prolog-pred-start ()
+ "Return the starting point of the first clause of the current predicate."
+ (save-excursion
+ (goto-char (prolog-clause-start))
+ ;; Find first clause, unless it was a directive
+ (if (and (not (looking-at "[:?]-"))
+ (not (looking-at "[ \t]*[%/]")) ; Comment
+
+ )
+ (let* ((pinfo (prolog-clause-info))
+ (predname (nth 0 pinfo))
+ (arity (nth 1 pinfo))
+ (op (point)))
+ (while (and (re-search-backward
+ (format "^%s\\([(\\.]\\| *%s\\)"
+ predname prolog-head-delimiter) nil t)
+ (= arity (nth 1 (prolog-clause-info)))
+ )
+ (setq op (point)))
+ (if (eq prolog-system 'mercury)
+ ;; Skip to the beginning of declarations of the predicate
+ (progn
+ (goto-char (prolog-beginning-of-clause))
+ (while (and (not (eq (point) op))
+ (looking-at
+ (format ":-[ \t]*\\(pred\\|mode\\)[ \t]+%s"
+ predname)))
+ (setq op (point))
+ (goto-char (prolog-beginning-of-clause)))))
+ op)
+ (point))))
+
+(defun prolog-pred-end ()
+ "Return the position at the end of the last clause of the current predicate."
+ (save-excursion
+ (goto-char (prolog-clause-end)) ; if we are before the first predicate
+ (goto-char (prolog-clause-start))
+ (let* ((pinfo (prolog-clause-info))
+ (predname (nth 0 pinfo))
+ (arity (nth 1 pinfo))
+ oldp
+ (notdone t)
+ (op (point)))
+ (if (looking-at "[:?]-")
+ ;; This was a directive
+ (progn
+ (if (and (eq prolog-system 'mercury)
+ (looking-at
+ (format ":-[ \t]*\\(pred\\|mode\\)[ \t]+\\(%s+\\)"
+ prolog-atom-regexp)))
+ ;; Skip predicate declarations
+ (progn
+ (setq predname (buffer-substring-no-properties
+ (match-beginning 2) (match-end 2)))
+ (while (re-search-forward
+ (format
+ "\n*\\(:-[ \t]*\\(pred\\|mode\\)[ \t]+\\)?%s[( \t]"
+ predname)
+ nil t))))
+ (goto-char (prolog-clause-end))
+ (setq op (point)))
+ ;; It was not a directive, find the last clause
+ (while (and notdone
+ (re-search-forward
+ (format "^%s\\([(\\.]\\| *%s\\)"
+ predname prolog-head-delimiter) nil t)
+ (= arity (nth 1 (prolog-clause-info))))
+ (setq oldp (point))
+ (setq op (prolog-clause-end))
+ (if (>= oldp op)
+ ;; End of clause not found.
+ (setq notdone nil)
+ ;; Continue while loop
+ (goto-char op))))
+ op)))
+
+(defun prolog-clause-start (&optional not-allow-methods)
+ "Return the position at the start of the head of the current clause.
+If NOTALLOWMETHODS is non-nil then do not match on methods in
+objects (relevent only if 'prolog-system' is set to 'sicstus)."
+ (save-excursion
+ (let ((notdone t)
+ (retval (point-min)))
+ (end-of-line)
+
+ ;; SICStus object?
+ (if (and (not not-allow-methods)
+ (eq prolog-system 'sicstus)
+ (prolog-in-object))
+ (while (and
+ notdone
+ ;; Search for a head or a fact
+ (re-search-backward
+ ;; If in object, then find method start.
+ ;; "^[ \t]+[a-z$].*\\(:-\\|&\\|:: {\\|,\\)"
+ "^[ \t]+[a-z$].*\\(:-\\|&\\|:: {\\)" ; The comma causes
+ ; problems since we cannot assume
+ ; that the line starts at column 0,
+ ; thus we don't know if the line
+ ; is a head or a subgoal
+ (point-min) t))
+ (if (>= (prolog-paren-balance) 0) ; To no match on " a) :-"
+ ;; Start of method found
+ (progn
+ (setq retval (point))
+ (setq notdone nil)))
+ ) ; End of while
+
+ ;; Not in object
+ (while (and
+ notdone
+ ;; Search for a text at beginning of a line
+ ;; ######
+ ;; (re-search-backward "^[a-z$']" nil t))
+ (let ((case-fold-search nil))
+ (re-search-backward
+ ;; (format "^[%s$']" prolog-lower-case-string)
+ ;; FIXME: Use [:lower:]
+ (format "^\\([%s$']\\|[:?]-\\)" prolog-lower-case-string)
+ nil t)))
+ (let ((bal (prolog-paren-balance)))
+ (cond
+ ((> bal 0)
+ ;; Start of clause found
+ (progn
+ (setq retval (point))
+ (setq notdone nil)))
+ ((and (= bal 0)
+ (looking-at
+ (format ".*\\(\\.\\|%s\\|!,\\)[ \t]*\\(%%.*\\|\\)$"
+ prolog-head-delimiter)))
+ ;; Start of clause found if the line ends with a '.' or
+ ;; a prolog-head-delimiter
+ (progn
+ (setq retval (point))
+ (setq notdone nil))
+ )
+ (t nil) ; Do nothing
+ ))))
+
+ retval)))
+
+(defun prolog-clause-end (&optional not-allow-methods)
+ "Return the position at the end of the current clause.
+If NOTALLOWMETHODS is non-nil then do not match on methods in
+objects (relevent only if 'prolog-system' is set to 'sicstus)."
+ (save-excursion
+ (beginning-of-line) ; Necessary since we use "^...." for the search.
+ (if (re-search-forward
+ (if (and (not not-allow-methods)
+ (eq prolog-system 'sicstus)
+ (prolog-in-object))
+ (format
+ "^\\(%s\\|%s\\|[^\n\'\"%%]\\)*&[ \t]*\\(\\|%%.*\\)$\\|[ \t]*}"
+ prolog-quoted-atom-regexp prolog-string-regexp)
+ (format
+ "^\\(%s\\|%s\\|[^\n\'\"%%]\\)*\\.[ \t]*\\(\\|%%.*\\)$"
+ prolog-quoted-atom-regexp prolog-string-regexp))
+ nil t)
+ (if (and (prolog-in-string-or-comment)
+ (not (eobp)))
+ (progn
+ (forward-char)
+ (prolog-clause-end))
+ (point))
+ (point))))
+
+(defun prolog-clause-info ()
+ "Return a (name arity) list for the current clause."
+ (save-excursion
+ (goto-char (prolog-clause-start))
+ (let* ((op (point))
+ (predname
+ (if (looking-at prolog-atom-char-regexp)
+ (progn
+ (skip-chars-forward "^ (\\.")
+ (buffer-substring op (point)))
+ ""))
+ (arity 0))
+ ;; Retrieve the arity.
+ (if (looking-at prolog-left-paren)
+ (let ((endp (save-excursion
+ (prolog-forward-list) (point))))
+ (setq arity 1)
+ (forward-char 1) ; Skip the opening paren.
+ (while (progn
+ (skip-chars-forward "^[({,'\"")
+ (< (point) endp))
+ (if (looking-at ",")
+ (progn
+ (setq arity (1+ arity))
+ (forward-char 1) ; Skip the comma.
+ )
+ ;; We found a string, list or something else we want
+ ;; to skip over. Always use prolog-tokenize,
+ ;; parse-partial-sexp does not have a 'skipover mode.
+ (goto-char (nth 5 (prolog-tokenize (point) endp 'skipover))))
+ )))
+ (list predname arity))))
+
+(defun prolog-in-object ()
+ "Return object name if the point is inside a SICStus object definition."
+ ;; Return object name if the last line that starts with a character
+ ;; that is neither white space nor a comment start
+ (save-excursion
+ (if (save-excursion
+ (beginning-of-line)
+ (looking-at "\\([^\n ]+\\)[ \t]*::[ \t]*{"))
+ ;; We were in the head of the object
+ (match-string 1)
+ ;; We were not in the head
+ (if (and (re-search-backward "^[a-z$'}]" nil t)
+ (looking-at "\\([^\n ]+\\)[ \t]*::[ \t]*{"))
+ (match-string 1)
+ nil))))
+
+(defun prolog-forward-list ()
+ "Move the point to the matching right parenthesis."
+ (interactive)
+ (if prolog-use-prolog-tokenizer-flag
+ (let ((state (prolog-tokenize (point) (point-max) 'zerodepth)))
+ (goto-char (nth 5 state)))
+ (forward-list)))
+
+;; NB: This could be done more efficiently!
+(defun prolog-backward-list ()
+ "Move the point to the matching left parenthesis."
+ (interactive)
+ (if prolog-use-prolog-tokenizer-flag
+ (let ((bal 0)
+ (paren-regexp (concat prolog-left-paren "\\|" prolog-right-paren))
+ (notdone t))
+ ;; FIXME: Doesn't this incorrectly count 0'( and 0') ?
+ (while (and notdone (re-search-backward paren-regexp nil t))
+ (cond
+ ((looking-at prolog-left-paren)
+ (if (not (prolog-in-string-or-comment))
+ (setq bal (1+ bal)))
+ (if (= bal 0)
+ (setq notdone nil)))
+ ((looking-at prolog-right-paren)
+ (if (not (prolog-in-string-or-comment))
+ (setq bal (1- bal))))
+ )))
+ (backward-list)))
+
+(defun prolog-beginning-of-clause ()
+ "Move to the beginning of current clause.
+If already at the beginning of clause, move to previous clause."
+ (interactive)
+ (let ((point (point))
+ (new-point (prolog-clause-start)))
+ (if (and (>= new-point point)
+ (> point 1))
+ (progn
+ (goto-char (1- point))
+ (goto-char (prolog-clause-start)))
+ (goto-char new-point)
+ (skip-chars-forward " \t"))))
+
+;; (defun prolog-previous-clause ()
+;; "Move to the beginning of the previous clause."
+;; (interactive)
+;; (forward-char -1)
+;; (prolog-beginning-of-clause))
+
+(defun prolog-end-of-clause ()
+ "Move to the end of clause.
+If already at the end of clause, move to next clause."
+ (interactive)
+ (let ((point (point))
+ (new-point (prolog-clause-end)))
+ (if (and (<= new-point point)
+ (not (eq new-point (point-max))))
+ (progn
+ (goto-char (1+ point))
+ (goto-char (prolog-clause-end)))
+ (goto-char new-point))))
+
+;; (defun prolog-next-clause ()
+;; "Move to the beginning of the next clause."
+;; (interactive)
+;; (prolog-end-of-clause)
+;; (forward-char)
+;; (prolog-end-of-clause)
+;; (prolog-beginning-of-clause))
+
+(defun prolog-beginning-of-predicate ()
+ "Go to the nearest beginning of predicate before current point.
+Return the final point or nil if no such a beginning was found."
+ (interactive)
+ (let ((op (point))
+ (pos (prolog-pred-start)))
+ (if pos
+ (if (= op pos)
+ (if (not (bobp))
+ (progn
+ (goto-char pos)
+ (backward-char 1)
+ (setq pos (prolog-pred-start))
+ (if pos
+ (progn
+ (goto-char pos)
+ (point)))))
+ (goto-char pos)
+ (point)))))
+
+(defun prolog-end-of-predicate ()
+ "Go to the end of the current predicate."
+ (interactive)
+ (let ((op (point)))
+ (goto-char (prolog-pred-end))
+ (if (= op (point))
+ (progn
+ (forward-line 1)
+ (prolog-end-of-predicate)))))
+
+(defun prolog-insert-predspec ()
+ "Insert the predspec for the current predicate."
+ (interactive)
+ (let* ((pinfo (prolog-clause-info))
+ (predname (nth 0 pinfo))
+ (arity (nth 1 pinfo)))
+ (insert (format "%s/%d" predname arity))))
+
+(defun prolog-view-predspec ()
+ "Insert the predspec for the current predicate."
+ (interactive)
+ (let* ((pinfo (prolog-clause-info))
+ (predname (nth 0 pinfo))
+ (arity (nth 1 pinfo)))
+ (message (format "%s/%d" predname arity))))
+
+(defun prolog-insert-predicate-template ()
+ "Insert the template for the current clause."
+ (interactive)
+ (let* ((n 1)
+ oldp
+ (pinfo (prolog-clause-info))
+ (predname (nth 0 pinfo))
+ (arity (nth 1 pinfo)))
+ (insert predname)
+ (if (> arity 0)
+ (progn
+ (insert "(")
+ (when prolog-electric-dot-full-predicate-template
+ (setq oldp (point))
+ (while (< n arity)
+ (insert ",")
+ (setq n (1+ n)))
+ (insert ")")
+ (goto-char oldp))
+ ))
+ ))
+
+(defun prolog-insert-next-clause ()
+ "Insert newline and the name of the current clause."
+ (interactive)
+ (insert "\n")
+ (prolog-insert-predicate-template))
+
+(defun prolog-insert-module-modeline ()
+ "Insert a modeline for module specification.
+This line should be first in the buffer.
+The module name should be written manually just before the semi-colon."
+ (interactive)
+ (insert "%%% -*- Module: ; -*-\n")
+ (backward-char 6))
+
+(defalias 'prolog-uncomment-region
+ (if (fboundp 'uncomment-region) #'uncomment-region
+ (lambda (beg end)
+ "Uncomment the region between BEG and END."
+ (interactive "r")
+ (comment-region beg end -1))))
+
+(defun prolog-goto-comment-column (&optional nocreate)
+ "Move comments on the current line to the correct position.
+If NOCREATE is nil (or omitted) and there is no comment on the line, then
+a new comment is created."
+ (interactive)
+ (beginning-of-line)
+ (if (or (not nocreate)
+ (and
+ (re-search-forward
+ (format "^\\(\\(%s\\|%s\\|[^\n\'\"%%]\\)*\\)%% *"
+ prolog-quoted-atom-regexp prolog-string-regexp)
+ (line-end-position) 'limit)
+ (progn
+ (goto-char (match-beginning 0))
+ (not (eq (prolog-in-string-or-comment) 'txt)))))
+ (indent-for-comment)))
+
+(defun prolog-indent-predicate ()
+ "*Indent the current predicate."
+ (interactive)
+ (indent-region (prolog-pred-start) (prolog-pred-end) nil))
+
+(defun prolog-indent-buffer ()
+ "*Indent the entire buffer."
+ (interactive)
+ (indent-region (point-min) (point-max) nil))
+
+(defun prolog-mark-clause ()
+ "Put mark at the end of this clause and move point to the beginning."
+ (interactive)
+ (let ((pos (point)))
+ (goto-char (prolog-clause-end))
+ (forward-line 1)
+ (beginning-of-line)
+ (set-mark (point))
+ (goto-char pos)
+ (goto-char (prolog-clause-start))))
+
+(defun prolog-mark-predicate ()
+ "Put mark at the end of this predicate and move point to the beginning."
+ (interactive)
+ (goto-char (prolog-pred-end))
+ (let ((pos (point)))
+ (forward-line 1)
+ (beginning-of-line)
+ (set-mark (point))
+ (goto-char pos)
+ (goto-char (prolog-pred-start))))
+
+;; Stolen from `cc-mode.el':
+(defun prolog-electric-delete (arg)
+ "Delete preceding character or whitespace.
+If `prolog-hungry-delete-key-flag' is non-nil, then all preceding whitespace is
+consumed. If however an ARG is supplied, or `prolog-hungry-delete-key-flag' is
+nil, or point is inside a literal then the function in the variable
+`backward-delete-char' is called."
+ (interactive "P")
+ (if (or (not prolog-hungry-delete-key-flag)
+ arg
+ (prolog-in-string-or-comment))
+ (funcall 'backward-delete-char (prefix-numeric-value arg))
+ (let ((here (point)))
+ (skip-chars-backward " \t\n")
+ (if (/= (point) here)
+ (delete-region (point) here)
+ (funcall 'backward-delete-char 1)
+ ))))
+
+;; For XEmacs compatibility (suggested by Per Mildner)
+(put 'prolog-electric-delete 'pending-delete 'supersede)
+
+(defun prolog-electric-if-then-else (arg)
+ "If `prolog-electric-if-then-else-flag' is non-nil, indent if-then-else constructs.
+Bound to the >, ; and ( keys."
+ (interactive "P")
+ (self-insert-command (prefix-numeric-value arg))
+ (if prolog-electric-if-then-else-flag (prolog-insert-spaces-after-paren)))
+
+(defun prolog-electric-colon (arg)
+ "If `prolog-electric-colon-flag' is non-nil, insert the electric `:' construct.
+That is, insert space (if appropriate), `:-' and newline if colon is pressed
+at the end of a line that starts in the first column (i.e., clause
+heads)."
+ (interactive "P")
+ (if (and prolog-electric-colon-flag
+ (null arg)
+ (eolp)
+ ;(not (string-match "^\\s " (thing-at-point 'line))))
+ (not (string-match "^\\(\\s \\|%\\)" (thing-at-point 'line))))
+ (progn
+ (unless (save-excursion (backward-char 1) (looking-at "\\s "))
+ (insert " "))
+ (insert ":-\n")
+ (prolog-indent-line))
+ (self-insert-command (prefix-numeric-value arg))))
+
+(defun prolog-electric-dash (arg)
+ "If `prolog-electric-dash-flag' is non-nil, insert the electric `-' construct.
+that is, insert space (if appropriate), `-->' and newline if dash is pressed
+at the end of a line that starts in the first column (i.e., DCG
+heads)."
+ (interactive "P")
+ (if (and prolog-electric-dash-flag
+ (null arg)
+ (eolp)
+ ;(not (string-match "^\\s " (thing-at-point 'line))))
+ (not (string-match "^\\(\\s \\|%\\)" (thing-at-point 'line))))
+ (progn
+ (unless (save-excursion (backward-char 1) (looking-at "\\s "))
+ (insert " "))
+ (insert "-->\n")
+ (prolog-indent-line))
+ (self-insert-command (prefix-numeric-value arg))))
+
+(defun prolog-electric-dot (arg)
+ "Insert dot and newline or a head of a new clause.
+
+If `prolog-electric-dot-flag' is nil, then simply insert dot.
+Otherwise::
+When invoked at the end of nonempty line, insert dot and newline.
+When invoked at the end of an empty line, insert a recursive call to
+the current predicate.
+When invoked at the beginning of line, insert a head of a new clause
+of the current predicate.
+
+When called with prefix argument ARG, insert just dot."
+ (interactive "P")
+ ;; Check for situations when the electricity should not be active
+ (if (or (not prolog-electric-dot-flag)
+ arg
+ (prolog-in-string-or-comment)
+ ;; Do not be electric in a floating point number or an operator
+ (not
+ (or
+ ;; (re-search-backward
+ ;; ######
+ ;; "\\(^\\|[])}a-zA-Z_!'0-9]+\\)[ \t]*\\=" nil t)))
+ (save-excursion
+ (re-search-backward
+ ;; "\\(^\\|[])}_!'0-9]+\\)[ \t]*\\=" nil t)))
+ "\\(^\\|[])}_!'0-9]+\\)[ \t]*\\="
+ nil t))
+ (save-excursion
+ (re-search-backward
+ ;; "\\(^\\|[])}a-zA-Z]+\\)[ \t]*\\=" nil t)))
+ (format "\\(^\\|[])}%s]+\\)[ \t]*\\="
+ prolog-lower-case-string) ;FIXME: [:lower:]
+ nil t))
+ (save-excursion
+ (re-search-backward
+ ;; "\\(^\\|[])}a-zA-Z]+\\)[ \t]*\\=" nil t)))
+ (format "\\(^\\|[])}%s]+\\)[ \t]*\\="
+ prolog-upper-case-string) ;FIXME: [:upper:]
+ nil t))
+ )
+ )
+ ;; Do not be electric if inside a parenthesis pair.
+ (not (= (prolog-region-paren-balance (prolog-clause-start) (point))
+ 0))
+ )
+ (funcall 'self-insert-command (prefix-numeric-value arg))
+ (cond
+ ;; Beginning of line
+ ((bolp)
+ (prolog-insert-predicate-template))
+ ;; At an empty line with at least one whitespace
+ ((save-excursion
+ (beginning-of-line)
+ (looking-at "[ \t]+$"))
+ (prolog-insert-predicate-template)
+ (when prolog-electric-dot-full-predicate-template
+ (save-excursion
+ (end-of-line)
+ (insert ".\n"))))
+ ;; Default
+ (t
+ (insert ".\n"))
+ )))
+
+(defun prolog-electric-underscore ()
+ "Replace variable with an underscore.
+If `prolog-electric-underscore-flag' is non-nil and the point is
+on a variable then replace the variable with underscore and skip
+the following comma and whitespace, if any.
+If the point is not on a variable then insert underscore."
+ (interactive)
+ (if prolog-electric-underscore-flag
+ (let (;start
+ (case-fold-search nil)
+ (oldp (point)))
+ ;; ######
+ ;;(skip-chars-backward "a-zA-Z_")
+ (skip-chars-backward
+ (format "%s%s_"
+ ;; FIXME: Why not "a-zA-Z"?
+ prolog-lower-case-string
+ prolog-upper-case-string))
+
+ ;(setq start (point))
+ (if (and (not (prolog-in-string-or-comment))
+ ;; ######
+ ;; (looking-at "\\<[_A-Z][a-zA-Z_0-9]*\\>"))
+ (looking-at (format "\\<[_%s][%s%s_0-9]*\\>"
+ ;; FIXME: Use [:upper:] and friends.
+ prolog-upper-case-string
+ prolog-lower-case-string
+ prolog-upper-case-string)))
+ (progn
+ (replace-match "_")
+ (skip-chars-forward ", \t\n"))
+ (goto-char oldp)
+ (self-insert-command 1))
+ )
+ (self-insert-command 1))
+ )
+
+
+(defun prolog-find-term (functor arity &optional prefix)
+ "Go to the position at the start of the next occurrence of a term.
+The term is specified with FUNCTOR and ARITY. The optional argument
+PREFIX is the prefix of the search regexp."
+ (let* (;; If prefix is not set then use the default "\\<"
+ (prefix (if (not prefix)
+ "\\<"
+ prefix))
+ (regexp (concat prefix functor))
+ (i 1))
+
+ ;; Build regexp for the search if the arity is > 0
+ (if (= arity 0)
+ ;; Add that the functor must be at the end of a word. This
+ ;; does not work if the arity is > 0 since the closing )
+ ;; is not a word constituent.
+ (setq regexp (concat regexp "\\>"))
+ ;; Arity is > 0, add parens and commas
+ (setq regexp (concat regexp "("))
+ (while (< i arity)
+ (setq regexp (concat regexp ".+,"))
+ (setq i (1+ i)))
+ (setq regexp (concat regexp ".+)")))
+
+ ;; Search, and return position
+ (if (re-search-forward regexp nil t)
+ (goto-char (match-beginning 0))
+ (error "Term not found"))
+ ))
+
+(defun prolog-variables-to-anonymous (beg end)
+ "Replace all variables within a region BEG to END by anonymous variables."
+ (interactive "r")
+ (save-excursion
+ (let ((case-fold-search nil))
+ (goto-char end)
+ (while (re-search-backward "\\<[A-Z_][a-zA-Z_0-9]*\\>" beg t)
+ (progn
+ (replace-match "_")
+ (backward-char)))
+ )))
+
+
+(defun prolog-set-atom-regexps ()
+ "Set the `prolog-atom-char-regexp' and `prolog-atom-regexp' variables.
+Must be called after `prolog-build-case-strings'."
+ (setq prolog-atom-char-regexp
+ (format "[%s%s0-9_$]"
+ ;; FIXME: why not a-zA-Z?
+ prolog-lower-case-string
+ prolog-upper-case-string))
+ (setq prolog-atom-regexp
+ (format "[%s$]%s*"
+ prolog-lower-case-string
+ prolog-atom-char-regexp))
+ )
+
+(defun prolog-build-case-strings ()
+ "Set `prolog-upper-case-string' and `prolog-lower-case-string'.
+Uses the current case-table for extracting the relevant information."
+ (let ((up_string "")
+ (low_string ""))
+ ;; Use `map-char-table' if it is defined. Otherwise enumerate all
+ ;; numbers between 0 and 255. `map-char-table' is probably safer.
+ ;;
+ ;; `map-char-table' causes problems under Emacs 23.0.0.1, the
+ ;; while loop seems to do its job well (Ryszard Szopa)
+ ;;
+ ;;(if (and (not (featurep 'xemacs))
+ ;; (fboundp 'map-char-table))
+ ;; (map-char-table
+ ;; (lambda (key value)
+ ;; (cond
+ ;; ((and
+ ;; (eq (prolog-int-to-char key) (downcase key))
+ ;; (eq (prolog-int-to-char key) (upcase key)))
+ ;; ;; Do nothing if upper and lower case are the same
+ ;; )
+ ;; ((eq (prolog-int-to-char key) (downcase key))
+ ;; ;; The char is lower case
+ ;; (setq low_string (format "%s%c" low_string key)))
+ ;; ((eq (prolog-int-to-char key) (upcase key))
+ ;; ;; The char is upper case
+ ;; (setq up_string (format "%s%c" up_string key)))
+ ;; ))
+ ;; (current-case-table))
+ ;; `map-char-table' was undefined.
+ (let ((key 0))
+ (while (< key 256)
+ (cond
+ ((and
+ (eq (prolog-int-to-char key) (downcase key))
+ (eq (prolog-int-to-char key) (upcase key)))
+ ;; Do nothing if upper and lower case are the same
+ )
+ ((eq (prolog-int-to-char key) (downcase key))
+ ;; The char is lower case
+ (setq low_string (format "%s%c" low_string key)))
+ ((eq (prolog-int-to-char key) (upcase key))
+ ;; The char is upper case
+ (setq up_string (format "%s%c" up_string key)))
+ )
+ (setq key (1+ key))))
+ ;; )
+ ;; The strings are single-byte strings
+ (setq prolog-upper-case-string (prolog-dash-letters up_string))
+ (setq prolog-lower-case-string (prolog-dash-letters low_string))
+ ))
+
+;(defun prolog-regexp-dash-continuous-chars (chars)
+; (let ((ints (mapcar #'prolog-char-to-int (string-to-list chars)))
+; (beg 0)
+; (end 0))
+; (if (null ints)
+; chars
+; (while (and (< (+ beg 1) (length chars))
+; (not (or (= (+ (nth beg ints) 1) (nth (+ beg 1) ints))
+; (= (nth beg ints) (nth (+ beg 1) ints)))))
+; (setq beg (+ beg 1)))
+; (setq beg (+ beg 1)
+; end beg)
+; (while (and (< (+ end 1) (length chars))
+; (or (= (+ (nth end ints) 1) (nth (+ end 1) ints))
+; (= (nth end ints) (nth (+ end 1) ints))))
+; (setq end (+ end 1)))
+; (if (equal (substring chars end) "")
+; (substring chars 0 beg)
+; (concat (substring chars 0 beg) "-"
+; (prolog-regexp-dash-continuous-chars (substring chars end))))
+; )))
+
+(defun prolog-ints-intervals (ints)
+ "Return a list of intervals (from . to) covering INTS."
+ (when ints
+ (setq ints (sort ints '<))
+ (let ((prev (car ints))
+ (interval-start (car ints))
+ intervals)
+ (while ints
+ (let ((next (car ints)))
+ (when (> next (1+ prev)) ; start of new interval
+ (setq intervals (cons (cons interval-start prev) intervals))
+ (setq interval-start next))
+ (setq prev next)
+ (setq ints (cdr ints))))
+ (setq intervals (cons (cons interval-start prev) intervals))
+ (reverse intervals))))
+
+(defun prolog-dash-letters (string)
+ "Return a condensed regexp covering all letters in STRING."
+ (let ((intervals (prolog-ints-intervals (mapcar #'prolog-char-to-int
+ (string-to-list string))))
+ codes)
+ (while intervals
+ (let* ((i (car intervals))
+ (from (car i))
+ (to (cdr i))
+ (c (cond ((= from to) `(,from))
+ ((= (1+ from) to) `(,from ,to))
+ (t `(,from ?- ,to)))))
+ (setq codes (cons c codes)))
+ (setq intervals (cdr intervals)))
+ (apply 'concat (reverse codes))))
+
+;(defun prolog-condense-character-sets (regexp)
+; "Condense adjacent characters in character sets of REGEXP."
+; (let ((next -1))
+; (while (setq next (string-match "\\[\\(.*?\\)\\]" regexp (1+ next)))
+; (setq regexp (replace-match (prolog-dash-letters (match-string 1 regexp))
+; t t regexp 1))))
+; regexp)
+
+;; GNU Emacs compatibility: GNU Emacs does not differentiate between
+;; ints and chars, or at least these two are interchangeable.
+(defalias 'prolog-int-to-char
+ (if (fboundp 'int-to-char) #'int-to-char #'identity))
+
+(defalias 'prolog-char-to-int
+ (if (fboundp 'char-to-int) #'char-to-int #'identity))
+
+;;-------------------------------------------------------------------
+;; Menu stuff (both for the editing buffer and for the inferior
+;; prolog buffer)
+;;-------------------------------------------------------------------
+
+(unless (fboundp 'region-exists-p)
+ (defun region-exists-p ()
+ "Non-nil iff the mark is set. Lobotomized version for Emacsen that do not provide their own."
+ (mark)))
+
+
+;; GNU Emacs ignores `easy-menu-add' so the order in which the menus
+;; are defined _is_ important!
+
+(easy-menu-define
+ prolog-menu-help (list prolog-mode-map prolog-inferior-mode-map)
+ "Help menu for the Prolog mode."
+ ;; FIXME: Does it really deserve a whole menu to itself?
+ `(,(if (featurep 'xemacs) "Help"
+ ;; Not sure it's worth the trouble. --Stef
+ ;; (add-to-list 'menu-bar-final-items
+ ;; (easy-menu-intern "Prolog-Help"))
+ "Prolog-help")
+ ["On predicate" prolog-help-on-predicate prolog-help-function-i]
+ ["Apropos" prolog-help-apropos (eq prolog-system 'swi)]
+ "---"
+ ["Describe mode" describe-mode t]))
+
+(easy-menu-define
+ prolog-edit-menu-runtime prolog-mode-map
+ "Runtime Prolog commands available from the editing buffer"
+ ;; FIXME: Don't use a whole menu for just "Run Mercury". --Stef
+ `("System"
+ ;; Runtime menu name.
+ ,@(unless (featurep 'xemacs)
+ '(:label (cond ((eq prolog-system 'eclipse) "ECLiPSe")
+ ((eq prolog-system 'mercury) "Mercury")
+ (t "System"))))
+
+ ;; Consult items, NIL for mercury.
+ ["Consult file" prolog-consult-file
+ :included (not (eq prolog-system 'mercury))]
+ ["Consult buffer" prolog-consult-buffer
+ :included (not (eq prolog-system 'mercury))]
+ ["Consult region" prolog-consult-region :active (region-exists-p)
+ :included (not (eq prolog-system 'mercury))]
+ ["Consult predicate" prolog-consult-predicate
+ :included (not (eq prolog-system 'mercury))]
+
+ ;; Compile items, NIL for everything but SICSTUS.
+ ,(if (featurep 'xemacs) "---"
+ ["---" nil :included (eq prolog-system 'sicstus)])
+ ["Compile file" prolog-compile-file
+ :included (eq prolog-system 'sicstus)]
+ ["Compile buffer" prolog-compile-buffer
+ :included (eq prolog-system 'sicstus)]
+ ["Compile region" prolog-compile-region :active (region-exists-p)
+ :included (eq prolog-system 'sicstus)]
+ ["Compile predicate" prolog-compile-predicate
+ :included (eq prolog-system 'sicstus)]
+
+ ;; Debug items, NIL for Mercury.
+ ,(if (featurep 'xemacs) "---"
+ ["---" nil :included (not (eq prolog-system 'mercury))])
+ ;; FIXME: Could we use toggle or radio buttons? --Stef
+ ["Debug" prolog-debug-on :included (not (eq prolog-system 'mercury))]
+ ["Debug off" prolog-debug-off
+ ;; In SICStus, these are pairwise disjunctive,
+ ;; so it's enough with a single "off"-command
+ :included (not (memq prolog-system '(mercury sicstus)))]
+ ["Trace" prolog-trace-on :included (not (eq prolog-system 'mercury))]
+ ["Trace off" prolog-trace-off
+ :included (not (memq prolog-system '(mercury sicstus)))]
+ ["Zip" prolog-zip-on :included (and (eq prolog-system 'sicstus)
+ (prolog-atleast-version '(3 . 7)))]
+ ["All debug off" prolog-debug-off
+ :included (eq prolog-system 'sicstus)]
+ ["Source level debugging"
+ prolog-toggle-sicstus-sd
+ :included (and (eq prolog-system 'sicstus)
+ (prolog-atleast-version '(3 . 7)))
+ :style toggle
+ :selected prolog-use-sicstus-sd]
+
+ "---"
+ ["Run" run-prolog
+ :suffix (cond ((eq prolog-system 'eclipse) "ECLiPSe")
+ ((eq prolog-system 'mercury) "Mercury")
+ (t "Prolog"))]))
+
+(easy-menu-define
+ prolog-edit-menu-insert-move prolog-mode-map
+ "Commands for Prolog code manipulation."
+ '("Prolog"
+ ["Comment region" comment-region (region-exists-p)]
+ ["Uncomment region" prolog-uncomment-region (region-exists-p)]
+ ["Add comment/move to comment" indent-for-comment t]
+ ["Convert variables in region to '_'" prolog-variables-to-anonymous
+ :active (region-exists-p) :included (not (eq prolog-system 'mercury))]
+ "---"
+ ["Insert predicate template" prolog-insert-predicate-template t]
+ ["Insert next clause head" prolog-insert-next-clause t]
+ ["Insert predicate spec" prolog-insert-predspec t]
+ ["Insert module modeline" prolog-insert-module-modeline t]
+ "---"
+ ["Beginning of clause" prolog-beginning-of-clause t]
+ ["End of clause" prolog-end-of-clause t]
+ ["Beginning of predicate" prolog-beginning-of-predicate t]
+ ["End of predicate" prolog-end-of-predicate t]
+ "---"
+ ["Indent line" prolog-indent-line t]
+ ["Indent region" indent-region (region-exists-p)]
+ ["Indent predicate" prolog-indent-predicate t]
+ ["Indent buffer" prolog-indent-buffer t]
+ ["Align region" align (region-exists-p)]
+ "---"
+ ["Mark clause" prolog-mark-clause t]
+ ["Mark predicate" prolog-mark-predicate t]
+ ["Mark paragraph" mark-paragraph t]
+ ;;"---"
+ ;;["Fontify buffer" font-lock-fontify-buffer t]
+ ))
+
+(defun prolog-menu ()
+ "Add the menus for the Prolog editing buffers."
+
+ (easy-menu-add prolog-edit-menu-insert-move)
+ (easy-menu-add prolog-edit-menu-runtime)
+
+ ;; Add predicate index menu
+ (set (make-local-variable 'imenu-create-index-function)
+ 'imenu-default-create-index-function)
+ ;;Milan (this has problems with object methods...) ###### Does it? (Stefan)
+ (setq imenu-prev-index-position-function 'prolog-beginning-of-predicate)
+ (setq imenu-extract-index-name-function 'prolog-get-predspec)
+
+ (if (and prolog-imenu-flag
+ (< (count-lines (point-min) (point-max)) prolog-imenu-max-lines))
+ (imenu-add-to-menubar "Predicates"))
+
+ (easy-menu-add prolog-menu-help))
+
+(easy-menu-define
+ prolog-inferior-menu-all prolog-inferior-mode-map
+ "Menu for the inferior Prolog buffer."
+ `("Prolog"
+ ;; Runtime menu name.
+ ,@(unless (featurep 'xemacs)
+ '(:label (cond ((eq prolog-system 'eclipse) "ECLiPSe")
+ ((eq prolog-system 'mercury) "Mercury")
+ (t "Prolog"))))
+
+ ;; Debug items, NIL for Mercury.
+ ,(if (featurep 'xemacs) "---"
+ ["---" nil :included (not (eq prolog-system 'mercury))])
+ ;; FIXME: Could we use toggle or radio buttons? --Stef
+ ["Debug" prolog-debug-on :included (not (eq prolog-system 'mercury))]
+ ["Debug off" prolog-debug-off
+ ;; In SICStus, these are pairwise disjunctive,
+ ;; so it's enough with a single "off"-command
+ :included (not (memq prolog-system '(mercury sicstus)))]
+ ["Trace" prolog-trace-on :included (not (eq prolog-system 'mercury))]
+ ["Trace off" prolog-trace-off
+ :included (not (memq prolog-system '(mercury sicstus)))]
+ ["Zip" prolog-zip-on :included (and (eq prolog-system 'sicstus)
+ (prolog-atleast-version '(3 . 7)))]
+ ["All debug off" prolog-debug-off
+ :included (eq prolog-system 'sicstus)]
+ ["Source level debugging"
+ prolog-toggle-sicstus-sd
+ :included (and (eq prolog-system 'sicstus)
+ (prolog-atleast-version '(3 . 7)))
+ :style toggle
+ :selected prolog-use-sicstus-sd]
+
+ ;; Runtime.
+ "---"
+ ["Interrupt Prolog" comint-interrupt-subjob t]
+ ["Quit Prolog" comint-quit-subjob t]
+ ["Kill Prolog" comint-kill-subjob t]))
+
+
+(defun prolog-inferior-menu ()
+ "Create the menus for the Prolog inferior buffer.
+This menu is dynamically created because one may change systems during
+the life of an Emacs session."
+ (easy-menu-add prolog-inferior-menu-all)
+ (easy-menu-add prolog-menu-help))
-(defun inferior-prolog-load-file ()
- "Pass the current buffer's file to the inferior prolog process."
+(defun prolog-mode-version ()
+ "Echo the current version of Prolog mode in the minibuffer."
(interactive)
- (save-buffer)
- (let ((file buffer-file-name)
- (proc (inferior-prolog-process)))
- (with-current-buffer (process-buffer proc)
- (compilation-forget-errors)
- (comint-send-string proc (concat "['" (file-relative-name file) "'].\n"))
- (pop-to-buffer (current-buffer)))))
+ (message "Using Prolog mode version %s" prolog-mode-version))
(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 5edcddecd7f..cade56a194c 100644
--- a/lisp/progmodes/ps-mode.el
+++ b/lisp/progmodes/ps-mode.el
@@ -1,12 +1,11 @@
;;; ps-mode.el --- PostScript mode for GNU Emacs
-;; Copyright (C) 1999, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2001-2011 Free Software Foundation, Inc.
;; 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 +38,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 +431,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.
@@ -542,6 +541,10 @@ Typing \\<ps-run-mode-map>\\[ps-run-goto-error] when the cursor is at the number
(interactive)
(message " *** PostScript Mode (ps-mode) Version %s *** " ps-mode-version))
+;; From reporter.el
+(defvar reporter-prompt-for-summary-p)
+(defvar reporter-dont-compact-list)
+
(defun ps-mode-submit-bug-report ()
"Submit via mail a bug report on PostScript mode."
(interactive)
@@ -681,7 +684,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 +721,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,11 +980,9 @@ 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.
-
-\\{ps-run-mode-map}"
+This mode is invoked from `ps-mode' and should not be called directly."
(set (make-local-variable 'font-lock-defaults)
'((ps-run-font-lock-keywords
ps-run-font-lock-keywords-1
@@ -994,7 +992,7 @@ This mode is invoked from `ps-mode' and should not be called directly.
(defun ps-run-running ()
"Error if not in `ps-mode' or not running PostScript."
- (unless (equal major-mode 'ps-mode)
+ (unless (derived-mode-p 'ps-mode)
(error "This function can only be called from PostScript mode"))
(unless (equal (process-status "ps-run") 'run)
(error "No PostScript process running")))
@@ -1014,20 +1012,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 +1040,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 +1057,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 +1105,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 +1139,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"
@@ -1183,5 +1170,4 @@ Use line numbers if `ps-run-error-line-numbers' is not nil"
(provide 'ps-mode)
-;; arch-tag: dce13d2d-69fb-4ec4-9d5d-6dd29c3f0e6e
;;; ps-mode.el ends here
diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el
index d21137b3080..a7851c54356 100644
--- a/lisp/progmodes/python.el
+++ b/lisp/progmodes/python.el
@@ -1,7 +1,6 @@
;;; python.el --- silly walks for Python -*- coding: iso-8859-1 -*-
-;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2003-2011 Free Software Foundation, Inc.
;; Author: Dave Love <fx@gnu.org>
;; Maintainer: FSF
@@ -110,7 +109,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 +166,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 +197,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.
@@ -502,44 +499,6 @@ statement."
:type 'integer)
-(defcustom python-default-interpreter 'cpython
- "*Which Python interpreter is used by default.
-The value for this variable can be either `cpython' or `jpython'.
-
-When the value is `cpython', the variables `python-python-command' and
-`python-python-command-args' are consulted to determine the interpreter
-and arguments to use.
-
-When the value is `jpython', the variables `python-jpython-command' and
-`python-jpython-command-args' are consulted to determine the interpreter
-and arguments to use.
-
-Note that this variable is consulted only the first time that a Python
-mode buffer is visited during an Emacs session. After that, use
-\\[python-toggle-shells] to change the interpreter shell."
- :type '(choice (const :tag "Python (a.k.a. CPython)" cpython)
- (const :tag "JPython" jpython))
- :group 'python)
-
-(defcustom python-python-command-args '("-i")
- "*List of string arguments to be used when starting a Python shell."
- :type '(repeat string)
- :group 'python)
-
-(defcustom python-jython-command-args '("-i")
- "*List of string arguments to be used when starting a Jython shell."
- :type '(repeat string)
- :group 'python
- :tag "JPython Command Args")
-
-;; for toggling between CPython and JPython
-(defvar python-which-shell nil)
-(defvar python-which-args python-python-command-args)
-(defvar python-which-bufname "Python")
-(make-variable-buffer-local 'python-which-shell)
-(make-variable-buffer-local 'python-which-args)
-(make-variable-buffer-local 'python-which-bufname)
-
(defcustom python-pdbtrack-do-tracking-p t
"*Controls whether the pdbtrack feature is enabled or not.
@@ -565,11 +524,6 @@ having to restart the program."
(push '(python-pdbtrack-is-tracking-p python-pdbtrack-minor-mode-string)
minor-mode-alist))
-;; Bind python-file-queue before installing the kill-emacs-hook.
-(defvar python-file-queue nil
- "Queue of Python temp files awaiting execution.
-Currently-active file is at the head of the list.")
-
(defcustom python-shell-prompt-alist
'(("ipython" . "^In \\[[0-9]+\\]: *")
(t . "^>>> "))
@@ -1319,7 +1273,7 @@ See `python-check-command' for the default."
(let ((name (buffer-file-name)))
(if name
(file-name-nondirectory name))))))))
- (setq python-saved-check-command command)
+ (set (make-local-variable 'python-saved-check-command) command)
(require 'compile) ;To define compilation-* variables.
(save-some-buffers (not compilation-ask-about-save) nil)
(let ((compilation-error-regexp-alist
@@ -2291,6 +2245,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 +2258,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 +2455,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) "# ")
@@ -2524,7 +2478,6 @@ with skeleton expansions for compound statement templates.
(set (make-local-variable 'outline-heading-end-regexp) ":\\s-*\n")
(set (make-local-variable 'outline-level) #'python-outline-level)
(set (make-local-variable 'open-paren-in-column-0-is-defun-start) nil)
- (make-local-variable 'python-saved-check-command)
(set (make-local-variable 'beginning-of-defun-function)
'python-beginning-of-defun)
(set (make-local-variable 'end-of-defun-function) 'python-end-of-defun)
@@ -2542,7 +2495,7 @@ with skeleton expansions for compound statement templates.
;; doesn't seem to work properly.
(add-to-list 'hs-special-modes-alist
`(python-mode "^\\s-*\\(?:def\\|class\\)\\>" nil "#"
- ,(lambda (arg)
+ ,(lambda (_arg)
(python-end-of-defun)
(skip-chars-backward " \t\n"))
nil))
@@ -2588,20 +2541,6 @@ Runs `jython-mode-hook' after `python-mode-hook'."
;; pdbtrack features
-(defun python-comint-output-filter-function (string)
- "Watch output for Python prompt and exec next file waiting in queue.
-This function is appropriate for `comint-output-filter-functions'."
- ;; TBD: this should probably use split-string
- (when (and (string-match python--prompt-regexp string)
- python-file-queue)
- (condition-case nil
- (delete-file (car python-file-queue))
- (error nil))
- (setq python-file-queue (cdr python-file-queue))
- (if python-file-queue
- (let ((pyproc (get-buffer-process (current-buffer))))
- (python-execute-file pyproc (car python-file-queue))))))
-
(defun python-pdbtrack-overlay-arrow (activation)
"Activate or deactivate arrow at beginning-of-line in current buffer."
(if activation
@@ -2610,12 +2549,12 @@ 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)))
-(defun python-pdbtrack-track-stack-file (text)
+(defun python-pdbtrack-track-stack-file (_text)
"Show the file indicated by the pdb stack entry line, in a separate window.
Activity is disabled if the buffer-local variable
@@ -2727,8 +2666,8 @@ problem."
)
)
-(defun python-pdbtrack-grub-for-buffer (funcname lineno)
- "Find recent python-mode buffer named, or having function named funcname."
+(defun python-pdbtrack-grub-for-buffer (funcname _lineno)
+ "Find recent Python mode buffer named, or having function named FUNCNAME."
(let ((buffers (buffer-list))
buf
got)
@@ -2746,45 +2685,6 @@ problem."
(setq got buf)))
got))
-(defun python-toggle-shells (arg)
- "Toggles between the CPython and JPython shells.
-
-With positive argument ARG (interactively \\[universal-argument]),
-uses the CPython shell, with negative ARG uses the JPython shell, and
-with a zero argument, toggles the shell.
-
-Programmatically, ARG can also be one of the symbols `cpython' or
-`jpython', equivalent to positive arg and negative arg respectively."
- (interactive "P")
- ;; default is to toggle
- (if (null arg)
- (setq arg 0))
- ;; preprocess arg
- (cond
- ((equal arg 0)
- ;; toggle
- (if (string-equal python-which-bufname "Python")
- (setq arg -1)
- (setq arg 1)))
- ((equal arg 'cpython) (setq arg 1))
- ((equal arg 'jpython) (setq arg -1)))
- (let (msg)
- (cond
- ((< 0 arg)
- ;; set to CPython
- (setq python-which-shell python-python-command
- python-which-args python-python-command-args
- python-which-bufname "Python"
- msg "CPython"
- mode-name "Python"))
- ((> 0 arg)
- (setq python-which-shell python-jython-command
- python-which-args python-jython-command-args
- python-which-bufname "JPython"
- msg "JPython"
- mode-name "JPython")))
- (message "Using the %s shell" msg)))
-
;; Python subprocess utilities and filters
(defun python-execute-file (proc filename)
"Send to Python interpreter process PROC \"execfile('FILENAME')\".
@@ -2805,71 +2705,6 @@ comint believe the user typed this string so that
(set-buffer curbuf))
(process-send-string proc cmd)))
-;;;###autoload
-(defun python-shell (&optional argprompt)
- "Start an interactive Python interpreter in another window.
-This is like Shell mode, except that Python is running in the window
-instead of a shell. See the `Interactive Shell' and `Shell Mode'
-sections of the Emacs manual for details, especially for the key
-bindings active in the `*Python*' buffer.
-
-With optional \\[universal-argument], the user is prompted for the
-flags to pass to the Python interpreter. This has no effect when this
-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.
-
-Note: You can toggle between using the CPython interpreter and the
-JPython interpreter by hitting \\[python-toggle-shells]. This toggles
-buffer local variables which control whether all your subshell
-interactions happen to the `*JPython*' or `*Python*' buffers (the
-latter is the name used for the CPython buffer).
-
-Warning: Don't use an interactive Python if you change sys.ps1 or
-sys.ps2 from their default values, or if you're running code that
-prints `>>> ' or `... ' at the start of a line. `python-mode' can't
-distinguish your output from Python's output, and assumes that `>>> '
-at the start of a line is a prompt from Python. Similarly, the Emacs
-Shell mode code assumes that both `>>> ' and `... ' at the start of a
-line are Python prompts. Bad things can happen if you fool either
-mode.
-
-Warning: If you do any editing *in* the process buffer *while* the
-buffer is accepting output from Python, do NOT attempt to `undo' the
-changes. Some of the output (nowhere near the parts you changed!) may
-be lost if you do. This appears to be an Emacs bug, an unfortunate
-interaction between undo and process filters; the same problem exists in
-non-Python process buffers using the default (Emacs-supplied) process
-filter."
- (interactive "P")
- (require 'ansi-color) ; For ipython
- ;; Set the default shell if not already set
- (when (null python-which-shell)
- (python-toggle-shells python-default-interpreter))
- (let ((args python-which-args))
- (when (and argprompt
- (called-interactively-p 'interactive)
- (fboundp 'split-string))
- ;; TBD: Perhaps force "-i" in the final list?
- (setq args (split-string
- (read-string (concat python-which-bufname
- " arguments: ")
- (concat
- (mapconcat 'identity python-which-args " ") " ")
- ))))
- (switch-to-buffer-other-window
- (apply 'make-comint python-which-bufname python-which-shell nil args))
- (set-process-sentinel (get-buffer-process (current-buffer))
- 'python-sentinel)
- (python--set-prompt-regexp)
- (add-hook 'comint-output-filter-functions
- 'python-comint-output-filter-function nil t)
- ;; pdbtrack
- (set-syntax-table python-mode-syntax-table)
- (use-local-map python-shell-map)))
-
(defun python-pdbtrack-toggle-stack-tracking (arg)
(interactive "P")
(if (not (get-buffer-process (current-buffer)))
@@ -2890,7 +2725,7 @@ filter."
(interactive)
(python-pdbtrack-toggle-stack-tracking 0))
-(defun python-sentinel (proc msg)
+(defun python-sentinel (_proc _msg)
(setq overlay-arrow-position nil))
(provide 'python)
diff --git a/lisp/progmodes/ruby-mode.el b/lisp/progmodes/ruby-mode.el
index 81860b7e603..c8b156c5441 100644
--- a/lisp/progmodes/ruby-mode.el
+++ b/lisp/progmodes/ruby-mode.el
@@ -1,8 +1,6 @@
;;; 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, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1994-2011 Free Software Foundation, Inc.
;; Authors: Yukihiro Matsumoto
;; Nobuyoshi Nakada
@@ -43,6 +41,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 +98,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,21 +114,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 (concat
- (regexp-quote (concat (match-string 2) (match-string 3)))
- (if (string= (match-string 3) "_") "\\B" "\\b"))))
- (concat "<<"
- (let ((match (match-string 1)))
- (if (and match (> (length match) 0))
- (concat "\\(?:-\\([\"']?\\)\\|\\([\"']\\)" (match-string 1) "\\)"
- contents "\\(\\1\\|\\2\\)")
- (concat "-?\\([\"']\\|\\)" contents "\\1"))))))
-
-
(defconst ruby-delimiter
(concat "[?$/%(){}#\"'`.:]\\|<<\\|\\[\\|\\]\\|\\<\\("
ruby-block-beg-re
@@ -152,11 +133,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)
@@ -169,7 +148,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)
@@ -362,7 +340,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)))
@@ -405,8 +383,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
@@ -638,7 +615,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))
@@ -700,7 +677,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))
@@ -780,7 +757,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")
@@ -998,7 +974,7 @@ With ARG, do it many times. Negative ARG means move forward."
(goto-char (scan-sexps (1+ (point)) -1))
(case (char-before)
(?% (forward-char -1))
- ('(?q ?Q ?w ?W ?r ?x)
+ ((?q ?Q ?w ?W ?r ?x)
(if (eq (char-before (1- (point))) ?%) (forward-char -2))))
nil)
((looking-at "\\s\"\\|\\\\\\S_")
@@ -1038,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)
@@ -1134,8 +1108,90 @@ See `add-log-current-defun-function'."
(if mlist (concat mlist mname) mname)
mlist)))))
-(defconst ruby-font-lock-syntactic-keywords
- `(;; #{ }, #$hoge, #@foo are not comments
+(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 "."))
+ ;; $' $" $` .... are variables
+ ;; ?' ?" ?` are ascii codes
+ ("\\([?$]\\)[#\"'`]"
+ (1 (unless (save-excursion
+ ;; Not within a string.
+ (nth 3 (syntax-ppss (match-beginning 0))))
+ (string-to-syntax "\\"))))
+ ;; 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 (concat
+ (regexp-quote (concat (match-string 2) (match-string 3)))
+ (if (string= (match-string 3) "_") "\\B" "\\b"))))
+ (concat "<<"
+ (let ((match (match-string 1)))
+ (if (and match (> (length match) 0))
+ (concat "\\(?:-\\([\"']?\\)\\|\\([\"']\\)"
+ (match-string 1) "\\)"
+ contents "\\(\\1\\|\\2\\)")
+ (concat "-?\\([\"']\\|\\)" contents "\\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
@@ -1174,18 +1230,90 @@ See `add-log-current-defun-function'."
(,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 ()
+ (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)))))
+
+ (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 "\""))))
-(unless (functionp 'syntax-ppss)
- (defun syntax-ppss (&optional pos)
- (parse-partial-sexp (point-min) (or pos (point)))))
+ (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)))))
@@ -1196,10 +1324,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))))
@@ -1211,77 +1336,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)
@@ -1380,7 +1434,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
@@ -1389,11 +1443,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)
@@ -1402,12 +1451,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))
@@ -1415,12 +1465,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
@@ -1433,5 +1483,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 3257299715a..4151e2bb79a 100644
--- a/lisp/progmodes/scheme.el
+++ b/lisp/progmodes/scheme.el
@@ -1,7 +1,7 @@
;;; scheme.el --- Scheme (and DSSSL) editing mode
-;; Copyright (C) 1986, 1987, 1988, 1997, 1998, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1986-1988, 1997-1998, 2001-2011
+;; Free Software Foundation, Inc.
;; Author: Bill Rozas <jinx@martigny.ai.mit.edu>
;; Adapted-by: Dave Love <d.love@dl.ac.uk>
@@ -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))
@@ -126,39 +126,27 @@
(defun scheme-mode-variables ()
(set-syntax-table scheme-mode-syntax-table)
(setq local-abbrev-table scheme-mode-abbrev-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 'fill-paragraph-function)
- (setq fill-paragraph-function 'lisp-fill-paragraph)
+ (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 'fill-paragraph-function) 'lisp-fill-paragraph)
;; Adaptive fill mode gets in the way of auto-fill,
;; and should make no difference for explicit fill
;; because lisp-fill-paragraph should do the job.
- (make-local-variable 'adaptive-fill-mode)
- (setq 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 ";;; \\|(....")
- (make-local-variable 'comment-start)
- (setq comment-start ";")
+ (set (make-local-variable 'adaptive-fill-mode) nil)
+ (set (make-local-variable 'indent-line-function) 'lisp-indent-line)
+ (set (make-local-variable 'parse-sexp-ignore-comments) t)
+ (set (make-local-variable 'outline-regexp) ";;; \\|(....")
+ (set (make-local-variable 'comment-start) ";")
(set (make-local-variable 'comment-add) 1)
- (make-local-variable 'comment-start-skip)
;; Look within the line for a ; following an even number of backslashes
;; after either a non-backslash or the line beginning.
- (setq comment-start-skip "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+[ \t]*")
+ (set (make-local-variable 'comment-start-skip)
+ "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+[ \t]*")
(set (make-local-variable 'font-lock-comment-start-skip) ";+ *")
- (make-local-variable 'comment-column)
- (setq comment-column 40)
- (make-local-variable 'parse-sexp-ignore-comments)
- (setq parse-sexp-ignore-comments t)
- (make-local-variable 'lisp-indent-function)
- (setq lisp-indent-function 'scheme-indent-function)
+ (set (make-local-variable 'comment-column) 40)
+ (set (make-local-variable 'parse-sexp-ignore-comments) t)
+ (set (make-local-variable 'lisp-indent-function) 'scheme-indent-function)
(setq mode-line-process '("" scheme-mode-line-process))
(set (make-local-variable 'imenu-case-fold-search) t)
(setq imenu-generic-expression scheme-imenu-generic-expression)
@@ -206,7 +194,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
(define-key map "\e\C-q" 'indent-sexp))
;;;###autoload
-(defun scheme-mode ()
+(define-derived-mode scheme-mode prog-mode "Scheme"
"Major mode for editing Scheme code.
Editing commands are similar to those of `lisp-mode'.
@@ -225,13 +213,7 @@ Blank lines separate paragraphs. Semicolons start comments.
\\{scheme-mode-map}
Entry to this mode calls the value of `scheme-mode-hook'
if that value is non-nil."
- (interactive)
- (kill-all-local-variables)
- (use-local-map scheme-mode-map)
- (setq major-mode 'scheme-mode)
- (setq mode-name "Scheme")
- (scheme-mode-variables)
- (run-mode-hooks 'scheme-mode-hook))
+ (scheme-mode-variables))
(defgroup scheme nil
"Editing Scheme code."
@@ -404,10 +386,7 @@ Blank lines separate paragraphs. Semicolons start comments.
Entering this mode runs the hooks `scheme-mode-hook' and then
`dsssl-mode-hook' and inserts the value of `dsssl-sgml-declaration' if
that variable's value is a string."
- (make-local-variable 'page-delimiter)
- (setq page-delimiter "^;;;" ; ^L not valid SGML char
- major-mode 'dsssl-mode
- mode-name "DSSSL")
+ (set (make-local-variable 'page-delimiter) "^;;;") ; ^L not valid SGML char
;; Insert a suitable SGML declaration into an empty buffer.
;; FIXME: This should use `auto-insert-alist' instead.
(and (zerop (buffer-size))
@@ -601,5 +580,4 @@ that variable's value is a string."
(provide 'scheme)
-;; arch-tag: a8f06bc1-ad11-42d2-9e36-ce651df37a90
;;; scheme.el ends here
diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el
index d463f299094..258f9be9237 100644
--- a/lisp/progmodes/sh-script.el
+++ b/lisp/progmodes/sh-script.el
@@ -1,7 +1,6 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1997, 1999, 2001-2011 Free Software Foundation, Inc.
;; Author: Daniel Pfeiffer <occitan@esperanto.org>
;; Version: 2.0f
@@ -361,8 +360,6 @@ the car and cdr are the same symbol.")
"The shell being programmed. This is set by \\[sh-set-shell].")
;;;###autoload(put 'sh-shell 'safe-local-variable 'symbolp)
-(defvar sh-mode-abbrev-table nil)
-
(define-abbrev-table 'sh-mode-abbrev-table ())
@@ -411,11 +408,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 +429,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))
@@ -568,19 +562,6 @@ This is buffer-local in every such buffer.")
:type '(repeat function)
:group 'sh-script)
-
-(defcustom sh-require-final-newline
- '((csh . t)
- (pdksh . t))
- "Value of `require-final-newline' in Shell-Script mode buffers.
-\(SHELL . t) means use the value of `mode-require-final-newline' for SHELL.
-See `sh-feature'."
- :type '(repeat (cons (symbol :tag "Shell")
- (choice (const :tag "require" t)
- (sexp :format "Evaluate: %v"))))
- :group 'sh-script)
-
-
(defcustom sh-assignment-regexp
'((csh . "\\<\\([[:alnum:]_]+\\)\\(\\[.+\\]\\)?[ \t]*[-+*/%^]?=")
;; actually spaces are only supported in let/(( ... ))
@@ -611,7 +592,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:]:]\\)"
@@ -779,7 +760,7 @@ flow of control or syntax. See `sh-feature'."
(shell "break" "case" "continue" "exec" "exit")
(zsh sh-append bash
- "select"))
+ "select" "foreach"))
"List of keywords not in `sh-leading-keywords'.
See `sh-feature'."
:type '(repeat (cons (symbol :tag "Shell")
@@ -942,68 +923,20 @@ 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
- ;; Should match until the real end-of-continued-line, but if that is not
- ;; possible (because we bump into EOB or the search bound), then we should
- ;; match until the search bound.
- "\\(?:\\(?:.*[^\\\n]\\)?\\(?:\\\\\\\\\\)*\\\\\n\\)*.*")
-
-(defconst sh-here-doc-open-re
- (concat "<<-?\\s-*\\\\?\\(\\(?:['\"][^'\"]+['\"]\\|\\sw\\)+\\)"
- sh-escaped-line-re "\\(\n\\)"))
-
-(defvar sh-here-doc-markers nil)
-(make-variable-buffer-local 'sh-here-doc-markers)
-(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)
- "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) ""))
- ;; A rough regexp that should find the opening <<EOF back.
- (sre (concat "<<\\(-?\\)\\s-*['\"\\]?"
- ;; Use \s| to cheaply check it's an open-heredoc.
- eof-re "['\"]?\\([ \t|;&)<>]"
- sh-escaped-line-re
- "\\)?\\s|"))
- ;; A regexp that will find other EOFs.
- (ere (concat "^" (if indented "[ \t]*") eof-re "\n"))
- (start (save-excursion
- (goto-char bol)
- (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.
- (cond
- ((when (and start (match-end 1)
- (not (and indented (= (match-beginning 1) (match-end 1))))
- (not (sh-in-comment-or-string (match-beginning 0))))
- ;; Make sure our `<<' is not the EOF1 of a `cat <<EOF1 <<EOF2'.
- (save-excursion
- (goto-char start)
- (setq start (line-beginning-position 2))
- (while
- (progn
- (re-search-forward "<<") ; Skip ourselves.
- (and (re-search-forward sh-here-doc-open-re start 'move)
- (goto-char (match-beginning 0))
- (sh-in-comment-or-string (point)))))
- ;; No <<EOF2 found after our <<.
- (= (point) start)))
- 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.
- (setq sh-here-doc-markers (delete eof sh-here-doc-markers))
- (setq sh-here-doc-re
- (concat sh-here-doc-open-re "\\|^\\([ \t]*\\)"
- (regexp-opt sh-here-doc-markers t) "\\(\n\\)"))
- nil))))
-
-(defun sh-font-lock-open-heredoc (start string)
+(eval-and-compile
+ (defconst sh-escaped-line-re
+ ;; Should match until the real end-of-continued-line, but if that is not
+ ;; possible (because we bump into EOB or the search bound), then we should
+ ;; match until the search bound.
+ "\\(?:\\(?:.*[^\\\n]\\)?\\(?:\\\\\\\\\\)*\\\\\n\\)*.*")
+
+ (defconst sh-here-doc-open-re
+ (concat "<<-?\\s-*\\\\?\\(\\(?:['\"][^'\"]+['\"]\\|\\sw\\|[-/~._]\\)+\\)"
+ sh-escaped-line-re "\\(\n\\)")))
+
+(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\").
@@ -1014,32 +947,36 @@ Point is at the beginning of the next line."
(sh-in-comment-or-string start))
;; We're looking at <<STRING, so we add "^STRING$" to the syntactic
;; font-lock keywords to detect the end of this here document.
- (let ((str (replace-regexp-in-string "['\"]" "" string)))
- (unless (member str sh-here-doc-markers)
- (push str sh-here-doc-markers)
- (setq sh-here-doc-re
- (concat sh-here-doc-open-re "\\|^\\([ \t]*\\)"
- (regexp-opt sh-here-doc-markers t) "\\(\n\\)"))))
- (let ((ppss (save-excursion (syntax-ppss (1- (point))))))
+ (let ((str (replace-regexp-in-string "['\"]" "" string))
+ (ppss (save-excursion (syntax-ppss eol))))
(if (nth 4 ppss)
;; The \n not only starts the heredoc but also closes a comment.
;; Let's close the comment just before the \n.
- (put-text-property (1- (point)) (point) 'syntax-table '(12))) ;">"
- (if (or (nth 5 ppss) (> (count-lines start (point)) 1))
- ;; If the sh-escaped-line-re part of sh-here-doc-re has matched
+ (put-text-property (1- eol) eol 'syntax-table '(12))) ;">"
+ (if (or (nth 5 ppss) (> (count-lines start eol) 1))
+ ;; If the sh-escaped-line-re part of sh-here-doc-open-re has matched
;; several lines, make sure we refontify them together.
;; Furthermore, if (nth 5 ppss) is non-nil (i.e. the \n is
;; escaped), it means the right \n is actually further down.
;; 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 (1+ eol) 'syntax-multiline t))
+ (put-text-property eol (1+ eol) 'sh-here-doc-marker str)
+ (prog1 sh-here-doc-syntax
+ (goto-char (+ 2 start))))))
+
+(defun sh-syntax-propertize-here-doc (end)
+ (let ((ppss (syntax-ppss)))
+ (when (eq t (nth 3 ppss))
+ (let ((key (get-text-property (nth 8 ppss) 'sh-here-doc-marker))
+ (case-fold-search nil))
+ (when (re-search-forward
+ (concat "^\\([ \t]*\\)" (regexp-quote key) "\\(\n\\)")
+ end 'move)
+ (let ((eol (match-beginning 2)))
+ (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,12 +985,9 @@ 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.
+ (let (;; `state' can be: double-quote, backquote, code.
(state (if (eq (char-before) ?`) 'backquote 'code))
;; Stacked states in the context.
(states '(double-quote)))
@@ -1085,8 +1019,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)
@@ -1094,19 +1027,25 @@ subshells can nest."
(not (sh-is-quoted-p (1- pos)))))
(defun sh-font-lock-paren (start)
+ (unless (nth 8 (syntax-ppss))
(save-excursion
(goto-char start)
;; Skip through all patterns
(while
(progn
+ (while
+ (progn
(forward-comment (- (point-max)))
+ (when (and (eolp) (sh-is-quoted-p (point)))
+ (forward-char -1)
+ t)))
;; Skip through one pattern
(while
(or (/= 0 (skip-syntax-backward "w_"))
- (/= 0 (skip-chars-backward "?[]*@/\\"))
+ (/= 0 (skip-chars-backward "-$=?[]*@/\\\\"))
(and (sh-is-quoted-p (1- (point)))
(goto-char (- (point) 2)))
- (when (memq (char-before) '(?\" ?\'))
+ (when (memq (char-before) '(?\" ?\' ?\}))
(condition-case nil (progn (backward-sexp 1) t)
(error nil)))))
;; Patterns can be preceded by an open-paren (Bug#1320).
@@ -1119,19 +1058,21 @@ subshells can nest."
(backward-char 1))
(when (eq (char-before) ?|)
(backward-char 1) t)))
- ;; FIXME: ";; esac )" is a case that looks like a case-pattern but it's
- ;; really just a close paren after a case statement. I.e. if we skipped
- ;; over `esac' just now, we're not looking at a case-pattern.
(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
;; corresponding `case'.
- (looking-at ";;\\|in"))
- sh-st-punc)))
+ (and (looking-at ";[;&]\\|in")
+ ;; ";; esac )" is a case that looks like a case-pattern
+ ;; but it's really just a close paren after a case
+ ;; statement. I.e. if we skipped over `esac' just now,
+ ;; we're not looking at a case-pattern.
+ (not (looking-at "..[ \t\n]+esac[^[:word:]_]"))))
+ sh-st-punc))))
(defun sh-font-lock-backslash-quote ()
(if (eq (save-excursion (nth 3 (syntax-ppss (match-beginning 0)))) ?\')
@@ -1139,40 +1080,38 @@ 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)
+(defun sh-syntax-propertize-function (start end)
+ (goto-char start)
+ (sh-syntax-propertize-here-doc end)
+ (funcall
+ (syntax-propertize-rules
+ (sh-here-doc-open-re
+ (2 (sh-font-lock-open-heredoc
+ (match-beginning 0) (match-string 1) (match-beginning 2))))
+ ("\\s|" (0 (prog1 nil (sh-syntax-propertize-here-doc end))))
+ ;; 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)))
- ;; 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))
+ ("\\$\\([?@]\\)" (1 "_"))
;; 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)))
+ (")" (0 (sh-font-lock-paren (match-beginning 0))))
+ ;; Highlight (possibly nested) subshells inside "" quoted
+ ;; regions correctly.
+ ("\"\\(?:\\(?:[^\\\"]\\|\\)*?[^\\]\\(?:\\\\\\\\\\)*\\)??\\(\\$(\\|`\\)"
+ (1 (ignore
+ ;; Save excursion because we want to also apply other
+ ;; syntax-propertize rules within the affected region.
+ (if (nth 8 (syntax-ppss))
+ (goto-char (1+ (match-beginning 0)))
+ (save-excursion
+ (sh-font-lock-quoted-subshell end)))))))
+ (point) end))
(defun sh-font-lock-syntactic-face-function (state)
(let ((q (nth 3 state)))
@@ -1272,7 +1211,7 @@ a number means align to that column, e.g. 0 means first column."
;; "For debugging: display message ARGS if variable SH-DEBUG is non-nil."
;; (if sh-debug
;; (apply 'message args)))
-(defmacro sh-debug (&rest args))
+(defmacro sh-debug (&rest _args))
(defconst sh-symbol-list
'((const :tag "+ " :value +
@@ -1480,7 +1419,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 +1472,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 +1534,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)
@@ -1700,6 +1620,8 @@ This adds rules for comments and assignments."
("esac" sh-handle-this-esac sh-handle-prev-esac)
(case-label nil sh-handle-after-case-label) ;; ???
(";;" nil sh-handle-prev-case-alt-end) ;; ???
+ (";;&" nil sh-handle-prev-case-alt-end) ;Like ";;" with diff semantics.
+ (";&" nil sh-handle-prev-case-alt-end) ;Like ";;" with diff semantics.
("done" sh-handle-this-done sh-handle-prev-done)
("do" sh-handle-this-do sh-handle-prev-do))
@@ -1741,23 +1663,18 @@ Calls the value of `sh-set-shell-hook' if set."
(setq sh-shell-file
(executable-set-magic shell (sh-feature sh-shell-arg)
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)
+ (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 +1687,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 +2079,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)))
@@ -2224,7 +2137,6 @@ STRING This is ignored for the purposes of calculating
(save-excursion
(let ((have-result nil)
this-kw
- start
val
(result nil)
(align-point nil)
@@ -2233,10 +2145,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 "#")
@@ -2296,7 +2207,6 @@ STRING This is ignored for the purposes of calculating
;; We start off at beginning of this line.
;; Scan previous statements while this is <=
;; start of previous line.
- (setq start (point)) ;; for debug only
(goto-char prev-line-end)
(setq x t)
(while (and x (setq x (sh-prev-thing)))
@@ -2547,7 +2457,7 @@ we go to the end of the previous line and do not check for continuations."
(sh-prev-line nil)
(line-beginning-position))))
(skip-chars-backward " \t;" min-point)
- (if (looking-at "\\s-*;;")
+ (if (looking-at "\\s-*;[;&]")
;; (message "Found ;; !")
";;"
(skip-chars-backward "^)}];\"'`({[" min-point)
@@ -2701,7 +2611,7 @@ can be represented by a symbol then do so."
If INFO is supplied it is used, else it is calculated from current line."
(let ((ofs 0)
(base-value 0)
- elt a b var val)
+ elt a b val)
(or info
(setq info (sh-get-indent-info)))
(when info
@@ -3469,20 +3379,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 +3777,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 31da8241eab..dc2773a9efe 100644
--- a/lisp/progmodes/simula.el
+++ b/lisp/progmodes/simula.el
@@ -1,7 +1,6 @@
;;; simula.el --- SIMULA 87 code editing commands for Emacs
-;; Copyright (C) 1992, 1994, 1996, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 1994, 1996, 2001-2011 Free Software Foundation, Inc.
;; Author: Hans Henrik Eriksen <hhe@ifi.uio.no>
;; Maintainer: simula-mode@ifi.uio.no
@@ -163,17 +162,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
@@ -324,13 +324,13 @@ for SIMULA mode to function correctly."
"Keymap used in `simula-mode'.")
;; menus for Lucid
-(defun simula-popup-menu (e)
+(defun simula-popup-menu (_e)
"Pops up the SIMULA menu."
(interactive "@e")
(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:
@@ -370,34 +370,22 @@ Variables controlling indentation style:
Turning on SIMULA mode calls the value of the variable simula-mode-hook
with no arguments, if that value is non-nil."
- (make-local-variable 'comment-column)
- (setq comment-column 40)
-; (make-local-variable 'end-comment-column)
-; (setq end-comment-column 75)
- (make-local-variable 'paragraph-start)
- (setq paragraph-start "[ \t]*$\\|\\f")
- (make-local-variable 'paragraph-separate)
- (setq paragraph-separate paragraph-start)
- (make-local-variable 'indent-line-function)
- (setq indent-line-function 'simula-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-start-skip)
- (setq comment-start-skip "!+ *")
- (make-local-variable 'parse-sexp-ignore-comments)
- (setq parse-sexp-ignore-comments nil)
- (make-local-variable 'comment-multi-line)
- (setq comment-multi-line t)
- (make-local-variable 'font-lock-defaults)
- (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)))
+ (set (make-local-variable 'comment-column) 40)
+ ;; (set (make-local-variable 'end-comment-column) 75)
+ (set (make-local-variable 'paragraph-start) "[ \t]*$\\|\\f")
+ (set (make-local-variable 'paragraph-separate) paragraph-start)
+ (set (make-local-variable 'indent-line-function) 'simula-indent-line)
+ (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) nil)
+ (set (make-local-variable 'comment-multi-line) t)
+ (set (make-local-variable '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"))))
+ (set (make-local-variable 'syntax-propertize-function)
+ simula-syntax-propertize-function)
(abbrev-mode 1))
(defun simula-indent-exp ()
@@ -962,7 +950,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 +1009,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 +1050,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
@@ -1214,9 +1202,8 @@ If COUNT is negative, move backward instead."
((eq simula-abbrev-keyword 'downcase) (downcase-word -1))
((eq simula-abbrev-keyword 'capitalize) (capitalize-word -1)))
(let ((pos (- (point-max) (point)))
- (case-fold-search t)
- null)
- (condition-case null
+ (case-fold-search t))
+ (condition-case nil
(progn
;; check if the expanded word is on the beginning of the line.
(if (and (eq (char-syntax (preceding-char)) ?w)
@@ -1256,8 +1243,9 @@ An optional second argument BOUND bounds the search, it is a buffer position.
The match found must not extend after that position. Optional third argument
NOERROR, if t, means if fail just return nil (no error).
If not nil and not t, move to limit of search and return nil."
- (let (begin end context (comb-regexp (concat regexp "\\|\\<end\\>"))
- match (start-point (point)))
+ (let ((comb-regexp (concat regexp "\\|\\<end\\>"))
+ (start-point (point))
+ context match)
(catch 'simula-backward
(while (re-search-backward comb-regexp bound 1)
;; We have a match, check SIMULA context at match-beginning
@@ -1318,8 +1306,9 @@ An optional second argument BOUND bounds the search, it is a buffer position.
The match found must not extend after that position. Optional third argument
NOERROR, if t, means if fail just return nil (no error).
If not nil and not t, move to limit of search and return nil."
- (let (begin end context (comb-regexp (concat regexp "\\|\\<begin\\>"))
- match (start-point (point)))
+ (let ((comb-regexp (concat regexp "\\|\\<begin\\>"))
+ (start-point (point))
+ context match)
(catch 'simula-forward
(while (re-search-forward comb-regexp bound 1)
;; We have a match, check SIMULA context at match-beginning
@@ -1657,5 +1646,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 80c1085cf49..facbba60057 100644
--- a/lisp/progmodes/sql.el
+++ b/lisp/progmodes/sql.el
@@ -1,11 +1,10 @@
;;; sql.el --- specialized comint.el for SQL interpreters
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; 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 +102,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 +179,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)
-;; 9) Save and compile sql.el.
+;; 6) Define a convienence function to invoke the SQL interpreter.
+
+;; (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.
+
+;; 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 hilighting levels.
+;; 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 +219,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 +231,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 +242,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-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-connect the name of a function which accepts no
+ :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 +518,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 +634,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 +654,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 +705,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 +718,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 +735,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 +753,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 +773,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)
-The program can also specify a TCP connection. See `make-comint'."
+;; Customization for SQLite
+
+(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.
+ "Command to start mysql by TcX.
-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-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.
+ "Command to start SOLID SQL Editor.
-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)
-;; 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)
-(defcustom sql-sybase-program "isql"
- "*Command to start isql by SyBase.
+;; Customization for Sybase
-Starts `sql-interactive-mode' after doing some setup.
+(defcustom sql-sybase-program "isql"
+ "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.
+ "Command to start dbaccess by Informix.
-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-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 +966,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.
-
-Starts `sql-interactive-mode' after doing some setup.
+ "Command to start isql by Interbase.
-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.
-
-Starts `sql-interactive-mode' after doing some setup.
+ "Command to start db2 by IBM.
-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 +1052,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 +1077,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 +1119,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 +1133,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 +1145,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 +1191,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 +1260,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 +1345,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 +1383,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 +1415,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 +1493,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 +1581,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 +1611,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 +1628,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 +1639,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 +1798,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 +1826,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 +1847,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 +1861,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 +1878,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 +1933,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 +1965,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 +2027,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 +2053,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 +2082,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 +2097,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 +2104,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 +2178,150 @@ 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)))
- ;; Always highlight ANSI keywords
- (eval (sql-product-feature :font-lock 'ansi))
- ;; Fontify object names in CREATE, DROP and ALTER DDL
- ;; statements
- (list sql-mode-font-lock-object-name)))
+ (set (make-local-variable 'sql-mode-font-lock-keywords)
+ (append
+ (unless (eq sql-product 'ansi)
+ (sql-get-product-feature sql-product :font-lock))
+ ;; Always highlight ANSI keywords
+ (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)
- (setq font-lock-defaults (list 'sql-mode-font-lock-keywords
- keywords-only t syntax-alist))
+ (kill-local-variable 'font-lock-set-defaults)
+ (set (make-local-variable '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 preceded 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,14 +3060,179 @@ 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)))
;;; SQL mode -- uses SQL interactive mode
;;;###autoload
-(defun sql-mode ()
+(define-derived-mode sql-mode prog-mode "SQL"
"Major mode to edit SQL.
You can send SQL statements to the SQLi buffer using
@@ -2140,18 +3259,11 @@ you must tell Emacs. Here's how to do that in your `~/.emacs' file:
\(add-hook 'sql-mode-hook
(lambda ()
(modify-syntax-entry ?\\\\ \".\" sql-mode-syntax-table)))"
- (interactive)
- (kill-all-local-variables)
- (setq major-mode 'sql-mode)
- (setq mode-name "SQL")
- (use-local-map sql-mode-map)
+ :abbrev-table sql-mode-abbrev-table
(if sql-mode-menu
(easy-menu-add sql-mode-menu)); XEmacs
- (set-syntax-table sql-mode-syntax-table)
- (make-local-variable 'font-lock-defaults)
- (make-local-variable 'sql-mode-font-lock-keywords)
- (make-local-variable 'comment-start)
- (setq comment-start "--")
+
+ (set (make-local-variable 'comment-start) "--")
;; Make each buffer in sql-mode remember the "current" SQLi buffer.
(make-local-variable 'sql-buffer)
;; Add imenu support for sql-mode. Note that imenu-generic-expression
@@ -2161,17 +3273,11 @@ you must tell Emacs. Here's how to do that in your `~/.emacs' file:
imenu-case-fold-search t)
;; Make `sql-send-paragraph' work on paragraphs that contain indented
;; lines.
- (make-local-variable 'paragraph-separate)
- (make-local-variable 'paragraph-start)
- (setq paragraph-separate "[\f]*$"
- paragraph-start "[\n\f]")
+ (set (make-local-variable 'paragraph-separate) "[\f]*$")
+ (set (make-local-variable 'paragraph-start) "[\n\f]")
;; Abbrevs
- (setq local-abbrev-table sql-mode-abbrev-table)
(setq abbrev-all-caps 1)
- ;; Run hook
- (run-mode-hooks 'sql-mode-hook)
;; Catch changes to sql-product and highlight accordingly
- (sql-highlight-product)
(add-hook 'hack-local-variables-hook 'sql-highlight-product t t))
@@ -2249,48 +3355,65 @@ 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 major-mode 'sql-interactive-mode) ;FIXME: Use define-derived-mode.
+ (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 "--")
+ (set (make-local-variable 'comment-start) "--")
;; Abbreviation table init and case-insensitive. It is not activated
;; by default.
(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))
+ (set (make-local-variable '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 +3439,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 +3686,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 +3699,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 +3738,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 +3751,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 +3767,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 +3785,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 +3798,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 +3831,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 +3844,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 +3878,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 +3891,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 +3903,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 +3929,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 +3942,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 +3974,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 +3987,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 +4017,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 +4030,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 +4053,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 +4073,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 +4091,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 +4129,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 +4142,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 +4179,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 +4192,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 +4213,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 +4225,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 +4249,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)))
diff --git a/lisp/progmodes/subword.el b/lisp/progmodes/subword.el
index 2c614086bc5..1a403f50b1b 100644
--- a/lisp/progmodes/subword.el
+++ b/lisp/progmodes/subword.el
@@ -1,6 +1,6 @@
;;; subword.el --- Handling capitalized subwords in a nomenclature
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: Masatake YAMATO
@@ -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:
@@ -277,5 +277,4 @@ Optional argument ARG is the same as for `capitalize-word'."
(provide 'subword)
-;; arch-tag: b8a01202-8a52-4a71-ae0a-d753fafd67ef
;;; subword.el ends here
diff --git a/lisp/progmodes/tcl.el b/lisp/progmodes/tcl.el
index 50c8ad2b99c..f18ec5abe81 100644
--- a/lisp/progmodes/tcl.el
+++ b/lisp/progmodes/tcl.el
@@ -1,7 +1,6 @@
;;; tcl.el --- Tcl code editing commands for Emacs
-;; Copyright (C) 1994, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 1998-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Author: Tom Tromey <tromey@redhat.com>
@@ -411,9 +410,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 +545,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.
@@ -571,10 +571,7 @@ documentation for details):
Turning on Tcl mode runs `tcl-mode-hook'. Read the documentation for
`tcl-mode-hook' to see what kinds of interesting hook functions
-already exist.
-
-Commands:
-\\{tcl-mode-map}"
+already exist."
(unless (and (boundp 'filladapt-mode) filladapt-mode)
(set (make-local-variable 'paragraph-ignore-fill-prefix) t))
@@ -593,9 +590,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)
@@ -663,7 +660,7 @@ Commands:
-(defun tcl-indent-command (&optional arg)
+(defun tcl-indent-command (&optional _arg)
"Indent current line as Tcl code, or in some cases insert a tab character.
If `tcl-tab-always-indent' is t (the default), always indent current line.
If `tcl-tab-always-indent' is nil and point is not in the indentation
@@ -1063,7 +1060,7 @@ With argument, positions cursor at end of buffer."
(defun inferior-tcl-proc ()
"Return current inferior Tcl process.
See variable `inferior-tcl-buffer'."
- (let ((proc (get-buffer-process (if (eq major-mode 'inferior-tcl-mode)
+ (let ((proc (get-buffer-process (if (derived-mode-p 'inferior-tcl-mode)
(current-buffer)
inferior-tcl-buffer))))
(or proc
@@ -1199,8 +1196,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))
@@ -1287,7 +1283,7 @@ to update the alist.")
If FLAG is nil, just uses `current-word'.
Otherwise scans backward for most likely Tcl command word."
(if (and flag
- (memq major-mode '(tcl-mode inferior-tcl-mode)))
+ (derived-mode-p 'tcl-mode 'inferior-tcl-mode))
(condition-case nil
(save-excursion
;; Look backward for first word actually in alist.
@@ -1363,7 +1359,7 @@ Prefix argument means switch to the Tcl buffer afterwards."
;; filename.
(car (comint-get-source "Load Tcl file: "
(or (and
- (eq major-mode 'tcl-mode)
+ (derived-mode-p 'tcl-mode)
(buffer-file-name))
tcl-previous-dir/file)
'(tcl-mode) t))
@@ -1383,12 +1379,12 @@ Prefix argument means switch to the Tcl buffer afterwards."
(list
(car (comint-get-source "Restart with Tcl file: "
(or (and
- (eq major-mode 'tcl-mode)
+ (derived-mode-p 'tcl-mode)
(buffer-file-name))
tcl-previous-dir/file)
'(tcl-mode) t))
current-prefix-arg))
- (let* ((buf (if (eq major-mode 'inferior-tcl-mode)
+ (let* ((buf (if (derived-mode-p 'inferior-tcl-mode)
(current-buffer)
inferior-tcl-buffer))
(proc (and buf (get-process buf))))
@@ -1510,7 +1506,7 @@ The first line is assumed to look like \"#!.../program ...\"."
;; loading the XEmacs menu emulation code.
;;
-(defun tcl-popup-menu (e)
+(defun tcl-popup-menu (_e)
(interactive "@e")
(popup-menu tcl-mode-menu))
@@ -1548,5 +1544,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 525ce460bc8..1f33f5f3aaf 100644
--- a/lisp/progmodes/vera-mode.el
+++ b/lisp/progmodes/vera-mode.el
@@ -1,7 +1,6 @@
-;;; vera-mode.el --- major mode for editing Vera files.
+;;; vera-mode.el --- major mode for editing Vera files
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2011 Free Software Foundation, Inc.
;; Author: Reto Zimmermann <reto@gnu.org>
;; Maintainer: Reto Zimmermann <reto@gnu.org>
@@ -253,7 +252,7 @@ If nil, TAB always indents current line."
;;;###autoload (add-to-list 'auto-mode-alist (cons (purecopy "\\.vr[hi]?\\'") 'vera-mode))
;;;###autoload
-(defun vera-mode ()
+(define-derived-mode vera-mode prog-mode "Vera"
"Major mode for editing Vera code.
Usage:
@@ -301,13 +300,6 @@ Key bindings:
-------------
\\{vera-mode-map}"
- (interactive)
- (kill-all-local-variables)
- (setq major-mode 'vera-mode)
- (setq mode-name "Vera")
- ;; set maps and tables
- (use-local-map vera-mode-map)
- (set-syntax-table vera-mode-syntax-table)
;; set local variables
(require 'cc-cmds)
(set (make-local-variable 'comment-start) "//")
@@ -328,9 +320,7 @@ Key bindings:
;; add menu (XEmacs)
(easy-menu-add vera-mode-menu)
;; miscellaneous
- (message "Vera Mode %s. Type C-c C-h for documentation." vera-version)
- ;; run hooks
- (run-hooks 'vera-mode-hook))
+ (message "Vera Mode %s. Type C-c C-h for documentation." vera-version))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -770,7 +760,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))
@@ -1087,7 +1077,7 @@ try to increase performance by using this macro."
(save-excursion
(beginning-of-line)
(let ((indent-point (point))
- syntax state placeholder pos)
+ syntax state placeholder)
;; determine syntax state
(setq state (parse-partial-sexp (point-min) (point)))
(cond
@@ -1250,7 +1240,7 @@ Calls `indent-region' for whole buffer."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; electrifications
-(defun vera-electric-tab (&optional prefix-arg)
+(defun vera-electric-tab (&optional prefix)
"Do what I mean (indent, expand, tab, change indent, etc..).
If preceding character is part of a word or a paren then `hippie-expand',
else if right of non whitespace on line then `tab-to-tab-stop',
@@ -1270,7 +1260,7 @@ If `vera-intelligent-tab' is nil, always indent line."
(or (and (boundp 'hippie-expand-only-buffers)
hippie-expand-only-buffers)
'(vera-mode))))
- (vera-expand-abbrev prefix-arg)))
+ (vera-expand-abbrev prefix)))
((> (current-column) (current-indentation))
(tab-to-tab-stop))
((and (or (eq last-command 'vera-electric-tab)
@@ -1412,7 +1402,7 @@ If `vera-intelligent-tab' is nil, always indent line."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Comments
-(defun vera-comment-uncomment-region (beg end &optional arg)
+(defun vera-comment-uncomment-region (beg end &optional _arg)
"Comment region if not commented, uncomment region if already commented."
(interactive "r\nP")
(goto-char beg)
@@ -1482,5 +1472,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 f250947b8f8..8bb9256078a 100644
--- a/lisp/progmodes/verilog-mode.el
+++ b/lisp/progmodes/verilog-mode.el
@@ -1,7 +1,6 @@
;; verilog-mode.el --- major mode for editing verilog source in Emacs
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Michael McNamara (mac@verilog.com),
;; Wilson Snyder (wsnyder@wsnyder.org)
@@ -1378,19 +1377,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 +1468,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 +1488,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)))
@@ -1544,16 +1532,14 @@ portion, will be substituted."
(cond
((or (file-exists-p "makefile") ;If there is a makefile, use it
(file-exists-p "Makefile"))
- (make-local-variable 'compile-command)
- (setq compile-command "make "))
+ (set (make-local-variable 'compile-command) "make "))
(t
- (make-local-variable 'compile-command)
- (setq compile-command
- (if verilog-tool
- (if (string-match "%s" (eval verilog-tool))
- (format (eval verilog-tool) (or buffer-file-name ""))
- (concat (eval verilog-tool) " " (or buffer-file-name "")))
- ""))))
+ (set (make-local-variable 'compile-command)
+ (if verilog-tool
+ (if (string-match "%s" (eval verilog-tool))
+ (format (eval verilog-tool) (or buffer-file-name ""))
+ (concat (eval verilog-tool) " " (or buffer-file-name "")))
+ ""))))
(verilog-modify-compile-command))
(defun verilog-expand-command (command)
@@ -1577,8 +1563,8 @@ be substituted."
(when (and
(stringp compile-command)
(string-match "\\b\\(__FLAGS__\\|__FILE__\\)\\b" compile-command))
- (make-local-variable 'compile-command)
- (setq compile-command (verilog-expand-command compile-command))))
+ (set (make-local-variable 'compile-command)
+ (verilog-expand-command compile-command))))
(if (featurep 'xemacs)
;; Following code only gets called from compilation-mode-hook on XEmacs to add error handling.
@@ -1599,8 +1585,8 @@ find the errors."
(cdr compilation-error-regexp-alist-alist)))))
(if (boundp 'compilation-font-lock-keywords)
(progn
- (make-local-variable 'compilation-font-lock-keywords)
- (setq compilation-font-lock-keywords verilog-error-font-lock-keywords)
+ (set (make-local-variable 'compilation-font-lock-keywords)
+ verilog-error-font-lock-keywords)
(font-lock-set-defaults)))
;; Need to re-run compilation-error-regexp builder
(if (fboundp 'compilation-build-compilation-error-regexp-alist)
@@ -2919,7 +2905,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
@@ -2986,7 +2972,7 @@ Use filename, if current buffer being edited shorten to just buffer name."
;;
(defvar verilog-which-tool 1)
;;;###autoload
-(defun verilog-mode ()
+(define-derived-mode verilog-mode prog-mode "Verilog"
"Major mode for editing Verilog code.
\\<verilog-mode-map>
See \\[describe-function] verilog-auto (\\[verilog-auto]) for details on how
@@ -3114,30 +3100,21 @@ All key bindings can be seen in a Verilog-buffer with \\[describe-bindings].
Key bindings specific to `verilog-mode-map' are:
\\{verilog-mode-map}"
- (interactive)
- (kill-all-local-variables)
- (use-local-map verilog-mode-map)
- (setq major-mode 'verilog-mode)
- (setq mode-name "Verilog")
- (setq local-abbrev-table verilog-mode-abbrev-table)
+ :abbrev-table verilog-mode-abbrev-table
(set (make-local-variable 'beginning-of-defun-function)
'verilog-beg-of-defun)
(set (make-local-variable 'end-of-defun-function)
'verilog-end-of-defun)
(set-syntax-table verilog-mode-syntax-table)
- (make-local-variable 'indent-line-function)
- (setq indent-line-function 'verilog-indent-line-relative)
+ (set (make-local-variable 'indent-line-function)
+ #'verilog-indent-line-relative)
(setq comment-indent-function 'verilog-comment-indent)
- (make-local-variable 'parse-sexp-ignore-comments)
- (setq parse-sexp-ignore-comments nil)
- (make-local-variable 'comment-start)
- (make-local-variable 'comment-end)
- (make-local-variable 'comment-multi-line)
- (make-local-variable 'comment-start-skip)
- (setq comment-start "// "
- comment-end ""
- comment-start-skip "/\\*+ *\\|// *"
- comment-multi-line nil)
+ (set (make-local-variable 'parse-sexp-ignore-comments) nil)
+
+ (set (make-local-variable 'comment-start) "// ")
+ (set (make-local-variable 'comment-end) "")
+ (set (make-local-variable 'comment-start-skip) "/\\*+ *\\|// *")
+ (set (make-local-variable 'comment-multi-line) nil)
;; Set up for compilation
(setq verilog-which-tool 1)
(setq verilog-tool 'verilog-linter)
@@ -3177,8 +3154,8 @@ Key bindings specific to `verilog-mode-map' are:
(add-hook 'after-change-functions 'verilog-highlight-region t t))
;; Tell imenu how to handle Verilog.
- (make-local-variable 'imenu-generic-expression)
- (setq imenu-generic-expression verilog-imenu-generic-expression)
+ (set (make-local-variable 'imenu-generic-expression)
+ verilog-imenu-generic-expression)
;; Tell which-func-modes that imenu knows about verilog
(when (boundp 'which-function-modes)
(add-to-list 'which-func-modes 'verilog-mode))
@@ -3191,8 +3168,7 @@ Key bindings specific to `verilog-mode-map' are:
hs-special-modes-alist))))
;; Stuff for autos
- (add-hook 'write-contents-hooks 'verilog-auto-save-check) ; already local
- (run-hooks 'verilog-mode-hook))
+ (add-hook 'write-contents-hooks 'verilog-auto-save-check nil 'local))
;;
@@ -3925,7 +3901,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 +3954,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 +4488,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)))))
@@ -8053,8 +8029,7 @@ Optionally associate it with the specified enumeration ENUMNAME."
(let ((enumvar (intern (concat "venum-" enumname))))
;;(message "Define %s=%s" defname defvalue) (sleep-for 1)
(unless (boundp enumvar) (set enumvar nil))
- (make-local-variable enumvar)
- (add-to-list enumvar defname)))))
+ (add-to-list (make-local-variable enumvar) defname)))))
(defun verilog-read-defines (&optional filename recurse subcall)
"Read `defines and parameters for the current file, or optional FILENAME.
@@ -8287,8 +8262,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))))
@@ -9361,10 +9335,9 @@ Typing \\[verilog-inject-auto] will make this into:
(defun verilog-auto-reeval-locals (&optional force)
"Read file local variable segment at bottom of file if it has changed.
If FORCE, always reread it."
- (make-local-variable 'verilog-auto-last-file-locals)
(let ((curlocal (verilog-auto-read-locals)))
(when (or force (not (equal verilog-auto-last-file-locals curlocal)))
- (setq verilog-auto-last-file-locals curlocal)
+ (set (make-local-variable 'verilog-auto-last-file-locals) curlocal)
;; Note this may cause this function to be recursively invoked,
;; because hack-local-variables may call (verilog-mode)
;; The above when statement will prevent it from recursing forever.
@@ -11915,7 +11888,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 +12112,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 86b917767a9..9aaf3059b78 100644
--- a/lisp/progmodes/vhdl-mode.el
+++ b/lisp/progmodes/vhdl-mode.el
@@ -1,8 +1,6 @@
;;; vhdl-mode.el --- major mode for editing VHDL code
-;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
-;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1992-2011 Free Software Foundation, Inc.
;; Authors: Reto Zimmermann <reto@gnu.org>
;; Rodney J. Whitby <software.vhdl-mode@rwhitby.net>
@@ -199,21 +197,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'."
@@ -1954,7 +1937,7 @@ Here is the current list of valid syntactic element symbols:
comment -- a line containing only a comment
arglist-intro -- the first line in an argument list
arglist-cont -- subsequent argument list lines when no
- arguments follow on the same line as the
+ arguments follow on the same line as
the arglist opening paren
arglist-cont-nonempty -- subsequent argument list lines when at
least one argument follows on the same
@@ -3466,13 +3449,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
@@ -4134,7 +4115,10 @@ The directory of the current source file is scanned."
;; performs all buffer local initializations
;;;###autoload
-(defun vhdl-mode ()
+(define-derived-mode vhdl-mode prog-mode
+ '("VHDL" (vhdl-electric-mode "/" (vhdl-stutter-mode "/"))
+ (vhdl-electric-mode "e")
+ (vhdl-stutter-mode "s"))
"Major mode for editing VHDL code.
Usage:
@@ -4667,23 +4651,13 @@ Key bindings:
-------------
\\{vhdl-mode-map}"
- (interactive)
- (kill-all-local-variables)
- (setq major-mode 'vhdl-mode)
- (setq mode-name "VHDL")
-
- ;; set maps and tables
- (use-local-map vhdl-mode-map)
- (set-syntax-table vhdl-mode-syntax-table)
- (setq local-abbrev-table vhdl-mode-abbrev-table)
+ :abbrev-table vhdl-mode-abbrev-table
;; set local variables
(set (make-local-variable 'paragraph-start)
"\\s-*\\(--+\\s-*$\\|[^ -]\\|$\\)")
(set (make-local-variable 'paragraph-separate) paragraph-start)
(set (make-local-variable 'paragraph-ignore-fill-prefix) t)
- (set (make-local-variable 'require-final-newline)
- (if vhdl-emacs-22 mode-require-final-newline t))
(set (make-local-variable 'parse-sexp-ignore-comments) t)
(set (make-local-variable 'indent-line-function) 'vhdl-indent-line)
(set (make-local-variable 'comment-start) "--")
@@ -4700,15 +4674,21 @@ Key bindings:
;; setup the comment indent variable in a Emacs version portable way
;; ignore any byte compiler warnings you might get here
(when (boundp 'comment-indent-function)
- (make-local-variable 'comment-indent-function)
- (setq comment-indent-function 'vhdl-comment-indent))
+ (set (make-local-variable 'comment-indent-function) 'vhdl-comment-indent))
;; initialize font locking
(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,14 +4717,8 @@ 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."))
-
- ;; run hooks
- (if vhdl-emacs-22
- (run-mode-hooks 'vhdl-mode-hook)
- (run-hooks 'vhdl-mode-hook)))
+ (if noninteractive "" " See menu for documentation and release notes.")))
(defun vhdl-activate-customizations ()
"Activate all customizations on local variables."
@@ -4757,16 +4731,15 @@ 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."
(if vhdl-modify-date-on-saving
- (add-hook 'local-write-file-hooks 'vhdl-template-modify-noerror)
- (remove-hook 'local-write-file-hooks 'vhdl-template-modify-noerror))
- (make-local-variable 'after-save-hook)
- (add-hook 'after-save-hook 'vhdl-add-modified-file))
+ (add-hook 'local-write-file-hooks 'vhdl-template-modify-noerror nil t)
+ (remove-hook 'local-write-file-hooks 'vhdl-template-modify-noerror t))
+ (if (featurep 'xemacs) (make-local-hook 'after-save-hook))
+ (add-hook 'after-save-hook 'vhdl-add-modified-file nil t))
(defun vhdl-process-command-line-option (option)
"Process command line options for VHDL Mode."
@@ -5280,13 +5253,12 @@ argument. The styles are chosen from the `vhdl-style-alist' variable."
(lambda (varentry)
(let ((var (car varentry))
(val (cdr varentry)))
- (and local
- (make-local-variable var))
;; special case for vhdl-offsets-alist
(if (not (eq var 'vhdl-offsets-alist))
- (set var val)
+ (set (if local (make-local-variable var) var) val)
;; reset vhdl-offsets-alist to the default value first
- (setq vhdl-offsets-alist (copy-alist vhdl-offsets-alist-default))
+ (set (if local (make-local-variable var) var)
+ (copy-alist vhdl-offsets-alist-default))
;; now set the langelems that are different
(mapcar
(function
@@ -7278,7 +7250,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 +7276,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 +7287,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 +7305,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 +7969,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 +7982,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 +8027,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 +8093,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 +8160,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 +8524,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 +8691,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 +9019,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 +9393,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 +9541,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 +10041,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 +10180,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 +12096,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 +12113,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)))))
@@ -12528,12 +12481,12 @@ File statistics: \"%s\"\n\
(cons (list 'vhdl-mode vhdl-hs-start-regexp nil "--\\( \\|$\\)"
'vhdl-hs-forward-sexp-func nil)
hs-special-modes-alist)))
- (make-local-variable 'hs-minor-mode-hook)
+ (if (featurep 'xemacs) (make-local-hook 'hs-minor-mode-hook))
(if vhdl-hide-all-init
- (add-hook 'hs-minor-mode-hook 'hs-hide-all)
- (remove-hook 'hs-minor-mode-hook 'hs-hide-all))
+ (add-hook 'hs-minor-mode-hook 'hs-hide-all nil t)
+ (remove-hook 'hs-minor-mode-hook 'hs-hide-all t))
(hs-minor-mode arg)
- (vhdl-mode-line-update))) ; hack to update menu bar
+ (force-mode-line-update))) ; hack to update menu bar
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -12946,10 +12899,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)
@@ -12999,8 +12951,8 @@ This does background highlighting of translate-off regions.")
(if (featurep 'xemacs)
(when (boundp 'ps-print-color-p)
(vhdl-ps-print-settings))
- (make-local-variable 'ps-print-hook)
- (add-hook 'ps-print-hook 'vhdl-ps-print-settings)))
+ (if (featurep 'xemacs) (make-local-hook 'ps-print-hook))
+ (add-hook 'ps-print-hook 'vhdl-ps-print-settings nil t)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -15942,7 +15894,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 +16955,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/which-func.el b/lisp/progmodes/which-func.el
index 6b794d36099..4e4d7b15053 100644
--- a/lisp/progmodes/which-func.el
+++ b/lisp/progmodes/which-func.el
@@ -1,7 +1,6 @@
;;; which-func.el --- print current function in mode line
-;; Copyright (C) 1994, 1997, 1998, 2001, 2002, 2003, 2004, 2005, 2006
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 1997-1998, 2001-2011 Free Software Foundation, Inc.
;; Author: Alex Rezinsky <alexr@msil.sps.mot.com>
;; (doesn't seem to be responsive any more)
@@ -198,7 +197,7 @@ It creates the Imenu index for the buffer, if necessary."
(or (eq which-func-modes t)
(member major-mode which-func-modes))))
- (condition-case nil
+ (condition-case err
(if (and which-func-mode
(not (member major-mode which-func-non-auto-modes))
(or (null which-func-maxout)
@@ -207,6 +206,7 @@ It creates the Imenu index for the buffer, if necessary."
(setq imenu--index-alist
(save-excursion (funcall imenu-create-index-function))))
(error
+ (message "which-func-ff-hook error: %S" err)
(setq which-func-mode nil))))
(defun which-func-update ()
@@ -225,7 +225,7 @@ It creates the Imenu index for the buffer, if necessary."
(force-mode-line-update)))
(error
(setq which-func-mode nil)
- (error "Error in which-func-update: %s" info))))))
+ (error "Error in which-func-update: %S" info))))))
;;;###autoload
(defalias 'which-func-mode 'which-function-mode)
@@ -282,8 +282,7 @@ If no function name is found, return nil."
(null which-function-imenu-failed))
(imenu--make-index-alist t)
(unless imenu--index-alist
- (make-local-variable 'which-function-imenu-failed)
- (setq which-function-imenu-failed t)))
+ (set (make-local-variable 'which-function-imenu-failed) t)))
;; If we have an index alist, use it.
(when (and (null name)
(boundp 'imenu--index-alist) imenu--index-alist)
@@ -294,29 +293,31 @@ If no function name is found, return nil."
;; ("submenu" ("name" . marker) ... ). The list can be
;; arbitrarily nested.
(while (or alist imstack)
- (if alist
- (progn
- (setq pair (car-safe alist)
- alist (cdr-safe alist))
-
- (cond ((atom pair)) ; skip anything not a cons
-
- ((imenu--subalist-p pair)
- (setq imstack (cons alist imstack)
- namestack (cons (car pair) namestack)
- alist (cdr pair)))
-
- ((number-or-marker-p (setq mark (cdr pair)))
- (if (>= (setq offset (- (point) mark)) 0)
- (if (< offset minoffset) ; find the closest item
- (setq minoffset offset
- name (funcall
- which-func-imenu-joiner-function
- (reverse (cons (car pair)
- namestack)))))))))
- (setq alist (car imstack)
- namestack (cdr namestack)
- imstack (cdr imstack))))))
+ (if (null alist)
+ (setq alist (car imstack)
+ namestack (cdr namestack)
+ imstack (cdr imstack))
+
+ (setq pair (car-safe alist)
+ alist (cdr-safe alist))
+
+ (cond
+ ((atom pair)) ; Skip anything not a cons.
+
+ ((imenu--subalist-p pair)
+ (setq imstack (cons alist imstack)
+ namestack (cons (car pair) namestack)
+ alist (cdr pair)))
+
+ ((number-or-marker-p (setq mark (cdr pair)))
+ (when (and (>= (setq offset (- (point) mark)) 0)
+ (< offset minoffset)) ; Find the closest item.
+ (setq minoffset offset
+ name (if (null which-func-imenu-joiner-function)
+ (car pair)
+ (funcall
+ which-func-imenu-joiner-function
+ (reverse (cons (car pair) namestack))))))))))))
;; Try using add-log support.
(when (null name)
@@ -329,5 +330,4 @@ If no function name is found, return nil."
(provide 'which-func)
-;; arch-tag: fa8a55c7-bfe3-4ffc-95ab-01bf21796827
;;; which-func.el ends here
diff --git a/lisp/progmodes/xscheme.el b/lisp/progmodes/xscheme.el
index 1cd669a1af9..dfa91b3fe30 100644
--- a/lisp/progmodes/xscheme.el
+++ b/lisp/progmodes/xscheme.el
@@ -1,7 +1,7 @@
;;; xscheme.el --- run MIT Scheme under Emacs
-;; Copyright (C) 1986, 1987, 1989, 1990, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1986-1987, 1989-1990, 2001-2011
+;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: languages, lisp
@@ -186,8 +186,7 @@ With argument, asks for a command line."
(setq-default xscheme-process-command-line command-line)
(switch-to-buffer
(xscheme-start-process command-line process-name buffer-name))
- (make-local-variable 'xscheme-process-command-line)
- (setq xscheme-process-command-line command-line))
+ (set (make-local-variable 'xscheme-process-command-line) command-line))
(defun xscheme-read-command-line (arg)
(let ((default
@@ -278,13 +277,11 @@ With argument, asks for a command line."
xscheme-buffer-name
t)))
(let ((process-name (verify-xscheme-buffer buffer-name t)))
- (make-local-variable 'xscheme-buffer-name)
- (setq xscheme-buffer-name buffer-name)
- (make-local-variable 'xscheme-process-name)
- (setq xscheme-process-name process-name)
- (make-local-variable 'xscheme-runlight)
- (setq xscheme-runlight (with-current-buffer buffer-name
- xscheme-runlight))))
+ (set (make-local-variable 'xscheme-buffer-name) buffer-name)
+ (set (make-local-variable 'xscheme-process-name) process-name)
+ (set (make-local-variable 'xscheme-runlight)
+ (with-current-buffer buffer-name
+ xscheme-runlight))))
(defun local-clear-scheme-interaction-buffer ()
"Make the current buffer use the default scheme interaction buffer."
@@ -386,21 +383,19 @@ Entry to this mode calls the value of scheme-interaction-mode-hook
with no args, if that value is non-nil.
Likewise with the value of scheme-mode-hook.
scheme-interaction-mode-hook is called after scheme-mode-hook."
+ ;; FIXME: Use define-derived-mode.
(interactive "P")
(if (not preserve)
(let ((previous-mode major-mode))
(kill-all-local-variables)
- (make-local-variable 'xscheme-previous-mode)
- (make-local-variable 'xscheme-buffer-name)
(make-local-variable 'xscheme-process-name)
(make-local-variable 'xscheme-previous-process-state)
(make-local-variable 'xscheme-runlight-string)
(make-local-variable 'xscheme-runlight)
- (make-local-variable 'xscheme-last-input-end)
- (setq xscheme-previous-mode previous-mode)
+ (set (make-local-variable 'xscheme-previous-mode) previous-mode)
(let ((buffer (current-buffer)))
- (setq xscheme-buffer-name (buffer-name buffer))
- (setq xscheme-last-input-end (make-marker))
+ (set (make-local-variable 'xscheme-buffer-name) (buffer-name buffer))
+ (set (make-local-variable 'xscheme-last-input-end) (make-marker))
(let ((process (get-buffer-process buffer)))
(if process
(progn
@@ -420,7 +415,7 @@ with no args, if that value is non-nil.
(defun exit-scheme-interaction-mode ()
"Take buffer out of scheme interaction mode"
(interactive)
- (if (not (eq major-mode 'scheme-interaction-mode))
+ (if (not (derived-mode-p 'scheme-interaction-mode))
(error "Buffer not in scheme interaction mode"))
(let ((previous-state xscheme-previous-process-state))
(funcall xscheme-previous-mode)
@@ -437,7 +432,7 @@ with no args, if that value is non-nil.
(defun scheme-interaction-mode-initialize ()
(use-local-map scheme-interaction-mode-map)
- (setq major-mode 'scheme-interaction-mode)
+ (setq major-mode 'scheme-interaction-mode) ;FIXME: Use define-derived-mode.
(setq mode-name "Scheme Interaction"))
(defun scheme-interaction-mode-commands (keymap)
@@ -469,8 +464,8 @@ with no args, if that value is non-nil.
(defun xscheme-enter-interaction-mode ()
(with-current-buffer (xscheme-process-buffer)
- (if (not (eq major-mode 'scheme-interaction-mode))
- (if (eq major-mode 'scheme-debugger-mode)
+ (if (not (derived-mode-p 'scheme-interaction-mode))
+ (if (derived-mode-p 'scheme-debugger-mode)
(scheme-interaction-mode-initialize)
(scheme-interaction-mode t)))))
@@ -494,7 +489,7 @@ Commands:
(defun scheme-debugger-mode-initialize ()
(use-local-map scheme-debugger-mode-map)
- (setq major-mode 'scheme-debugger-mode)
+ (setq major-mode 'scheme-debugger-mode) ;FIXME: Use define-derived-mode.
(setq mode-name "Scheme Debugger"))
(defun scheme-debugger-mode-commands (keymap)
@@ -516,11 +511,11 @@ Commands:
(interactive)
(xscheme-send-char last-command-event))
-(defun xscheme-enter-debugger-mode (prompt-string)
+(defun xscheme-enter-debugger-mode (_prompt-string)
(with-current-buffer (xscheme-process-buffer)
- (if (not (eq major-mode 'scheme-debugger-mode))
+ (if (not (derived-mode-p 'scheme-debugger-mode))
(progn
- (if (not (eq major-mode 'scheme-interaction-mode))
+ (if (not (derived-mode-p 'scheme-interaction-mode))
(scheme-interaction-mode t))
(scheme-debugger-mode-initialize)))))
@@ -528,7 +523,7 @@ Commands:
(let ((buffer (xscheme-process-buffer)))
(and buffer
(with-current-buffer buffer
- (eq major-mode 'scheme-debugger-mode)))))
+ (derived-mode-p 'scheme-debugger-mode)))))
;;;; Evaluation Commands
@@ -550,7 +545,7 @@ The strings are concatenated and terminated by a newline."
(defun xscheme-send-string-1 (strings)
(let ((string (apply 'concat strings)))
(xscheme-send-string-2 string)
- (if (eq major-mode 'scheme-interaction-mode)
+ (if (derived-mode-p 'scheme-interaction-mode)
(xscheme-insert-expression string))))
(defun xscheme-send-string-2 (string)
@@ -701,12 +696,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)))
@@ -1034,8 +1024,7 @@ the remaining input.")
(xscheme-goto-output-point)
(let ((old-point (point)))
(while (string-match "\\(\007\\|\f\\)" string)
- (let ((start (match-beginning 0))
- (end (match-end 0)))
+ (let ((start (match-beginning 0)))
(insert-before-markers (substring string 0 start))
(if (= ?\f (aref string start))
(progn
@@ -1224,5 +1213,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 113c9e91b09..14aee8c3ecf 100644
--- a/lisp/ps-bdf.el
+++ b/lisp/ps-bdf.el
@@ -1,13 +1,10 @@
;;; ps-bdf.el --- BDF font file handler for ps-print
-;; Copyright (C) 1998, 1999, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1998-1999, 2001-2011 Free Software Foundation, Inc.
;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
;; 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
;; Registration Number H14PRO021
-
;; Copyright (C) 2003
;; National Institute of Advanced Industrial Science and Technology (AIST)
;; Registration Number H13PRO009
@@ -15,6 +12,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.
@@ -38,8 +36,7 @@
;;; Code:
-(eval-and-compile
- (require 'ps-mule))
+(require 'ps-mule)
;;;###autoload
(defcustom bdf-directory-list
@@ -447,5 +444,4 @@ BITMAP-STRING is a string representing bits by hexadecimal digits."
(provide 'ps-bdf)
-;; arch-tag: 9b875ba8-565a-4ecf-acaa-30cee732c898
;;; ps-bdf.el ends here
diff --git a/lisp/ps-def.el b/lisp/ps-def.el
index 95bb64b5803..639183e5ab3 100644
--- a/lisp/ps-def.el
+++ b/lisp/ps-def.el
@@ -1,6 +1,6 @@
;;; ps-def.el --- XEmacs and Emacs definitions for ps-print
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Kenichi Handa <handa@m17n.org> (multi-byte characters)
@@ -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.
@@ -31,7 +32,7 @@
;;; Code:
(eval-and-compile
- (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest _r))))
(declare-function ps-plot-with-face "ps-print" (from to face))
(declare-function ps-plot-string "ps-print" (string))
@@ -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)))
+ (defun charset-dimension (_charset) 1)) ; 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))
+ (defun char-width (_char) 1)) ; ascii
(or (fboundp 'encode-char)
- (defun encode-char (ch ccs)
+ (defun encode-char (ch _ccs)
ch))
-
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ps-print
@@ -471,5 +402,4 @@
(provide 'ps-def)
-;; arch-tag: 4edde45b-af10-4685-b8ee-7cd0f951095a
;;; ps-def.el ends here
diff --git a/lisp/ps-mule.el b/lisp/ps-mule.el
index bc8aff1780d..d95719ba552 100644
--- a/lisp/ps-mule.el
+++ b/lisp/ps-mule.el
@@ -1,13 +1,13 @@
;;; ps-mule.el --- provide multi-byte character facility to ps-print
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Kenichi Handa <handa@m17n.org> (multi-byte characters)
;; 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.
@@ -88,8 +88,7 @@
;;; Code:
-(eval-and-compile
- (require 'ps-print))
+(require 'ps-print)
;;;###autoload
@@ -633,7 +632,7 @@ f2, f3, h0, h1, and H0 respectively."
(ps-output "]"))))))
(ps-output " ] " (if (nth 3 composition) "RLC" "RBC") "\n"))
-(defun ps-mule-plot-string (from to &optional bg-color)
+(defun ps-mule-plot-string (from to &optional _bg-color)
"Generate PostScript code for plotting characters in the region FROM and TO.
Optional argument BG-COLOR is ignored.
@@ -1210,5 +1209,4 @@ V%s 0 /%s-latin1 /%s Latin1Encoding put\n"
;; generated-autoload-file: "ps-print.el"
;; End:
-;; arch-tag: bca017b2-66a7-4e59-8584-103e749eadbe
;;; ps-mule.el ends here
diff --git a/lisp/ps-print.el b/lisp/ps-print.el
index 25cb9cac2df..3d1dbfb406a 100644
--- a/lisp/ps-print.el
+++ b/lisp/ps-print.el
@@ -1,8 +1,6 @@
;;; ps-print.el --- print text from the buffer as PostScript
-;; Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1993-2011 Free Software Foundation, Inc.
;; Author: Jim Thompson (was <thompson@wg2.waii.com>)
;; Jacques Duthen (was <duthen@cegelec-red.fr>)
@@ -1466,12 +1464,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")))
@@ -1484,7 +1479,7 @@ Please send all bug fixes and enhancements to
;; Load XEmacs/Emacs definitions
-(eval-and-compile (require 'ps-def))
+(require 'ps-def)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -1497,7 +1492,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."
@@ -4597,16 +4592,16 @@ page-height == ((floor print-height ((th + ls) * zh)) * ((th + ls) * zh)) - th
ps-print-height))))))
-(defun ps-print-preprint-region (prefix-arg)
+(defun ps-print-preprint-region (prefix)
(or (ps-mark-active-p)
(error "The mark is not set now"))
- (list (point) (mark) (ps-print-preprint prefix-arg)))
+ (list (point) (mark) (ps-print-preprint prefix)))
-(defun ps-print-preprint (prefix-arg)
- (and prefix-arg
- (or (numberp prefix-arg)
- (listp prefix-arg))
+(defun ps-print-preprint (prefix)
+ (and prefix
+ (or (numberp prefix)
+ (listp prefix))
(let* ((name (concat (file-name-nondirectory (or (buffer-file-name)
(buffer-name)))
".ps"))
@@ -6025,7 +6020,7 @@ XSTART YSTART are the relative position for the first page in a sheet.")
(ps-output " S\n")
wrappoint))
-(defun ps-basic-plot-string (from to &optional bg-color)
+(defun ps-basic-plot-string (from to &optional _bg-color)
(let* ((wrappoint (ps-find-wrappoint from to
(ps-avg-char-width 'ps-font-for-text)))
(to (car wrappoint))
@@ -6034,7 +6029,7 @@ XSTART YSTART are the relative position for the first page in a sheet.")
(ps-output " S\n")
wrappoint))
-(defun ps-basic-plot-whitespace (from to &optional bg-color)
+(defun ps-basic-plot-whitespace (from to &optional _bg-color)
(let* ((wrappoint (ps-find-wrappoint from to
(ps-space-width 'ps-font-for-text)))
(to (car wrappoint)))
@@ -6650,7 +6645,8 @@ If FACE is not a valid face name, use default face."
(error "Unprinted PostScript"))))
(cond ((fboundp 'add-hook)
- (funcall 'add-hook 'kill-emacs-hook 'ps-kill-emacs-check))
+ (unless noninteractive
+ (funcall 'add-hook 'kill-emacs-hook 'ps-kill-emacs-check)))
(kill-emacs-hook
(message "Won't override existing `kill-emacs-hook'"))
(t
@@ -6662,7 +6658,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" "7fadcd6c4b18087e900bd21e6da5e854")
+;;;;;; ps-multibyte-buffer) "ps-mule" "ps-mule.el" "179b43ee432338186dde9e8c4fe761af")
;;; Generated autoloads from ps-mule.el
(defvar ps-multibyte-buffer nil "\
diff --git a/lisp/ps-samp.el b/lisp/ps-samp.el
index ad7616d78b7..8b652b26082 100644
--- a/lisp/ps-samp.el
+++ b/lisp/ps-samp.el
@@ -1,6 +1,6 @@
;;; ps-samp.el --- ps-print sample setup code
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Jim Thompson (was <thompson@wg2.waii.com>)
;; Jacques Duthen (was <duthen@cegelec-red.fr>)
@@ -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.
@@ -33,7 +34,7 @@
;;; Code:
-(eval-and-compile (require 'ps-print))
+(require 'ps-print)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -253,9 +254,8 @@
(eval-when-compile
(require 'cl))
-(eval-and-compile
- (require 'printing)
- (require 'zeroconf))
+(require 'printing)
+(require 'zeroconf)
;; Add a Postscript printer to the "Postscript printer" menu.
(defun ps-add-printer (service)
@@ -308,5 +308,4 @@
(provide 'ps-samp)
-;; arch-tag: 99c415d3-be39-43c6-aa32-7ee33ba19600
;;; ps-samp.el ends here
diff --git a/lisp/recentf.el b/lisp/recentf.el
index 9df352bf63a..fc9b7881733 100644
--- a/lisp/recentf.el
+++ b/lisp/recentf.el
@@ -1,7 +1,6 @@
;;; recentf.el --- setup a menu of recently opened files
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: David Ponce <david@dponce.com>
;; Created: July 19 1999
@@ -412,13 +411,14 @@ That is, if it doesn't match any of the `recentf-exclude' checks."
(checks recentf-exclude)
(keepit t))
(while (and checks keepit)
- (setq keepit (condition-case nil
- (not (if (stringp (car checks))
- ;; A regexp
- (string-match (car checks) filename)
- ;; A predicate
- (funcall (car checks) filename)))
- (error nil))
+ ;; If there was an error in a predicate, err on the side of
+ ;; keeping the file. (Bug#5843)
+ (setq keepit (not (ignore-errors
+ (if (stringp (car checks))
+ ;; A regexp
+ (string-match (car checks) filename)
+ ;; A predicate
+ (funcall (car checks) filename))))
checks (cdr checks)))
keepit))
@@ -590,7 +590,7 @@ menu-elements (no sub-menu)."
;; Count the number of assigned menu shortcuts.
(defvar recentf-menu-shortcuts)
-(defun recentf-make-menu-items (&optional menu)
+(defun recentf-make-menu-items (&optional _menu)
"Make menu items from the recent list.
This is a menu filter function which ignores the MENU argument."
(setq recentf-menu-filter-commands nil)
@@ -1036,7 +1036,7 @@ That is, remove a non kept file from the recent list."
;;; Common dialog stuff
;;
-(defun recentf-cancel-dialog (&rest ignore)
+(defun recentf-cancel-dialog (&rest _ignore)
"Cancel the current dialog.
IGNORE arguments."
(interactive)
@@ -1092,7 +1092,7 @@ Go to the beginning of buffer if not found."
;;
(defvar recentf-edit-list nil)
-(defun recentf-edit-list-select (widget &rest ignore)
+(defun recentf-edit-list-select (widget &rest _ignore)
"Toggle a file selection based on the checkbox WIDGET state.
IGNORE other arguments."
(let ((value (widget-get widget :tag))
@@ -1102,7 +1102,7 @@ IGNORE other arguments."
(setq recentf-edit-list (delq value recentf-edit-list)))
(message "%s %sselected" value (if check "" "un"))))
-(defun recentf-edit-list-validate (&rest ignore)
+(defun recentf-edit-list-validate (&rest _ignore)
"Process the recent list when the edit list dialog is committed.
IGNORE arguments."
(if recentf-edit-list
@@ -1146,7 +1146,7 @@ Click on Cancel or type `q' to cancel.\n")
;;; Open file dialog
;;
-(defun recentf-open-files-action (widget &rest ignore)
+(defun recentf-open-files-action (widget &rest _ignore)
"Open the file stored in WIDGET's value when notified.
IGNORE other arguments."
(kill-buffer (current-buffer))
@@ -1355,11 +1355,7 @@ that were operated on recently."
(recentf-auto-cleanup)
(let ((hook-setup (if recentf-mode 'add-hook 'remove-hook)))
(dolist (hook recentf-used-hooks)
- (apply hook-setup hook)))
- (run-hooks 'recentf-mode-hook)
- (when (called-interactively-p 'interactive)
- (message "Recentf mode %sabled" (if recentf-mode "en" "dis"))))
- recentf-mode)
+ (apply hook-setup hook)))))
(defun recentf-unload-function ()
"Unload the recentf library."
@@ -1371,5 +1367,4 @@ that were operated on recently."
(run-hooks 'recentf-load-hook)
-;; arch-tag: 78f1eec9-0d16-4d19-a4eb-2e4529edb62a
;;; recentf.el ends here
diff --git a/lisp/rect.el b/lisp/rect.el
index 1560cd26a59..ad914cab7d2 100644
--- a/lisp/rect.el
+++ b/lisp/rect.el
@@ -1,10 +1,10 @@
;;; rect.el --- rectangle functions for GNU Emacs
-;; Copyright (C) 1985, 1999, 2000, 2001, 2002, 2003, 2004
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1999-2011 Free Software Foundation, Inc.
;; Maintainer: Didier Verna <didier@xemacs.org>
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -26,10 +26,8 @@
;; This package provides the operations on rectangles that are documented
;; in the Emacs manual.
-;; ### NOTE: this file has been almost completely rewritten by Didier Verna
-;; <didier@xemacs.org> in July 1999. The purpose of this rewrite is to be less
-;; intrusive and fill lines with whitespaces only when needed. A few functions
-;; are untouched though, as noted above their definition.
+;; ### NOTE: this file was almost completely rewritten by Didier Verna
+;; <didier@xemacs.org> in July 1999.
;;; Global key bindings
@@ -39,26 +37,11 @@
;;;###autoload (define-key ctl-x-r-map "y" 'yank-rectangle)
;;;###autoload (define-key ctl-x-r-map "o" 'open-rectangle)
;;;###autoload (define-key ctl-x-r-map "t" 'string-rectangle)
+;;;###autoload (define-key ctl-x-r-map "N" 'rectangle-number-lines)
;;; Code:
-;;;###autoload
-(defun move-to-column-force (column &optional flag)
- "If COLUMN is within a multi-column character, replace it by spaces and tab.
-As for `move-to-column', passing anything but nil or t in FLAG will move to
-the desired column only if the line is long enough."
- (move-to-column column (or flag t)))
-
-;;;###autoload
-(make-obsolete 'move-to-column-force 'move-to-column "21.2")
-
-;; not used any more --dv
-;; extract-rectangle-line stores lines into this list
-;; to accumulate them for extract-rectangle and delete-extract-rectangle.
-(defvar operate-on-rectangle-lines)
-
-;; ### NOTE: this function is untouched, but not used anymore apart from
-;; `delete-whitespace-rectangle'. `apply-on-rectangle' is used instead. --dv
+;; FIXME: this function should be replaced by `apply-on-rectangle'
(defun operate-on-rectangle (function start end coerce-tabs)
"Call FUNCTION for each line of rectangle with corners at START, END.
If COERCE-TABS is non-nil, convert multi-column characters
@@ -106,7 +89,6 @@ Point is at the end of the segment of this line within the rectangle."
(forward-line 1)))
(- endcol startcol)))
-;; The replacement for `operate-on-rectangle' -- dv
(defun apply-on-rectangle (function start end &rest args)
"Call FUNCTION for each line of rectangle with corners at START, END.
FUNCTION is called with two arguments: the start and end columns of the
@@ -150,9 +132,9 @@ the function is called."
(setcdr lines (cons (filter-buffer-substring pt (point) t) (cdr lines))))
))
-;; ### NOTE: this is actually the only function that needs to do complicated
-;; stuff like what's happening in `operate-on-rectangle', because the buffer
-;; might be read-only. --dv
+;; This is actually the only function that needs to do complicated
+;; stuff like what's happening in `operate-on-rectangle', because the
+;; buffer might be read-only.
(defun extract-rectangle-line (startcol endcol lines)
(let (start end begextra endextra line)
(move-to-column startcol)
@@ -185,7 +167,6 @@ the function is called."
(defconst spaces-strings
'["" " " " " " " " " " " " " " " " "])
-;; this one is untouched --dv
(defun spaces-string (n)
"Return a string with N spaces."
(if (<= n 8) (aref spaces-strings n)
@@ -252,14 +233,12 @@ even beep.)"
(barf-if-buffer-read-only)
(signal 'text-read-only (list (current-buffer)))))))
-;; this one is untouched --dv
;;;###autoload
(defun yank-rectangle ()
"Yank the last killed rectangle with upper left corner at point."
(interactive "*")
(insert-rectangle killed-rectangle))
-;; this one is untoutched --dv
;;;###autoload
(defun insert-rectangle (rectangle)
"Insert text of RECTANGLE with upper left corner at point.
@@ -302,7 +281,7 @@ no text on the right side of the rectangle."
(= (point) (point-at-eol)))
(indent-to endcol))))
-(defun delete-whitespace-rectangle-line (startcol endcol fill)
+(defun delete-whitespace-rectangle-line (startcol _endcol fill)
(when (= (move-to-column startcol (if fill t 'coerce)) startcol)
(unless (= (point) (point-at-eol))
(delete-region (point) (progn (skip-syntax-forward " ") (point))))))
@@ -322,10 +301,6 @@ With a prefix (or a FILL) argument, also fill too short lines."
(interactive "*r\nP")
(apply-on-rectangle 'delete-whitespace-rectangle-line start end fill))
-;; not used any more --dv
-;; string-rectangle uses this variable to pass the string
-;; to string-rectangle-line.
-(defvar string-rectangle-string)
(defvar string-rectangle-history nil)
(defun string-rectangle-line (startcol endcol string delete)
(move-to-column startcol t)
@@ -395,7 +370,45 @@ rectangle which were empty."
(delete-region pt (point))
(indent-to endcol)))))
+;; Line numbers for `rectangle-number-line-callback'.
+(defvar rectangle-number-line-counter)
+
+(defun rectangle-number-line-callback (start _end format-string)
+ (move-to-column start t)
+ (insert (format format-string rectangle-number-line-counter))
+ (setq rectangle-number-line-counter
+ (1+ rectangle-number-line-counter)))
+
+(defun rectange--default-line-number-format (start end start-at)
+ (concat "%"
+ (int-to-string (length (int-to-string (+ (count-lines start end)
+ start-at))))
+ "d "))
+
+;;;###autoload
+(defun rectangle-number-lines (start end start-at &optional format)
+ "Insert numbers in front of the region-rectangle.
+
+START-AT, if non-nil, should be a number from which to begin
+counting. FORMAT, if non-nil, should be a format string to pass
+to `format' along with the line count. When called interactively
+with a prefix argument, prompt for START-AT and FORMAT."
+ (interactive
+ (if current-prefix-arg
+ (let* ((start (region-beginning))
+ (end (region-end))
+ (start-at (read-number "Number to count from: " 1)))
+ (list start end start-at
+ (read-string "Format string: "
+ (rectange--default-line-number-format
+ start end start-at))))
+ (list (region-beginning) (region-end) 1 nil)))
+ (unless format
+ (setq format (rectange--default-line-number-format start end start-at)))
+ (let ((rectangle-number-line-counter start-at))
+ (apply-on-rectangle 'rectangle-number-line-callback
+ start end format)))
+
(provide 'rect)
-;; arch-tag: 178847b3-1f50-4b03-83de-a6e911cc1d16
;;; rect.el ends here
diff --git a/lisp/register.el b/lisp/register.el
index f34fd8d0657..af1a421a0a2 100644
--- a/lisp/register.el
+++ b/lisp/register.el
@@ -1,10 +1,10 @@
;;; register.el --- register commands for Emacs
-;; Copyright (C) 1985, 1993, 1994, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1993-1994, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -88,7 +88,7 @@ Argument is a character, naming the register."
(if arg (list (current-frame-configuration) (point-marker))
(point-marker))))
-(defun window-configuration-to-register (register &optional arg)
+(defun window-configuration-to-register (register &optional _arg)
"Store the window configuration of the selected frame in register REGISTER.
Use \\[jump-to-register] to restore the configuration.
Argument is a character, naming the register."
@@ -97,7 +97,7 @@ Argument is a character, naming the register."
;; of point in the current buffer, so record that separately.
(set-register register (list (current-window-configuration) (point-marker))))
-(defun frame-configuration-to-register (register &optional arg)
+(defun frame-configuration-to-register (register &optional _arg)
"Store the window configuration of all frames in register REGISTER.
Use \\[jump-to-register] to restore the configuration.
Argument is a character, naming the register."
@@ -352,5 +352,4 @@ START and END are buffer positions giving two corners of rectangle."
(extract-rectangle start end))))
(provide 'register)
-;; arch-tag: ce14dd68-8265-475f-9341-5d4ec5a53035
;;; register.el ends here
diff --git a/lisp/repeat.el b/lisp/repeat.el
index ab0c42a0dde..b33039b609b 100644
--- a/lisp/repeat.el
+++ b/lisp/repeat.el
@@ -1,11 +1,10 @@
;;; repeat.el --- convenient way to repeat the previous command
-;; Copyright (C) 1998, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 2001-2011 Free Software Foundation, Inc.
;; 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.
@@ -392,5 +391,4 @@ recently executed command not bound to an input event\"."
(provide 'repeat)
-;; arch-tag: cd569600-a1ad-4fa7-9062-bb91dfeaf1db
;;; repeat.el ends here
diff --git a/lisp/replace.el b/lisp/replace.el
index 0b90c94c7fa..31a48d48960 100644
--- a/lisp/replace.el
+++ b/lisp/replace.el
@@ -1,10 +1,10 @@
;;; replace.el --- replace commands for Emacs
-;; Copyright (C) 1985, 1986, 1987, 1992, 1994, 1996, 1997, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+;; Copyright (C) 1985-1987, 1992, 1994, 1996-1997, 2000-2011
;; Free Software Foundation, Inc.
;; Maintainer: FSF
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -33,7 +33,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'.
@@ -95,6 +98,10 @@ is highlighted lazily using isearch lazy highlighting (see
:group 'matching
:version "22.1")
+(defvar replace-count 0
+ "Number of replacements done so far.
+See `replace-regexp' and `query-replace-regexp-eval'.")
+
(defun query-replace-descr (string)
(mapconcat 'isearch-text-char-description string ""))
@@ -394,12 +401,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))
@@ -527,6 +535,9 @@ which will run faster and will not set the mark or print anything."
Maximum length of the history list is determined by the value
of `history-length', which see.")
+(defvar occur-collect-regexp-history '("\\1")
+ "History of regexp for occur's collect operation")
+
(defun read-regexp (prompt &optional default-value)
"Read regexp as a string using the regexp history and some useful defaults.
Prompt for a regular expression with PROMPT (without a colon and
@@ -762,32 +773,32 @@ a previously found match."
(define-key map "\M-p" 'occur-prev)
(define-key map "r" 'occur-rename-buffer)
(define-key map "c" 'clone-buffer)
- (define-key map "g" 'revert-buffer)
- (define-key map "q" 'quit-window)
- (define-key map "z" 'kill-this-buffer)
(define-key map "\C-c\C-f" 'next-error-follow-minor-mode)
(define-key map [menu-bar] (make-sparse-keymap))
(define-key map [menu-bar occur]
- `(cons ,(purecopy "Occur") map))
+ (cons (purecopy "Occur") map))
(define-key map [next-error-follow-minor-mode]
- (menu-bar-make-mm-toggle next-error-follow-minor-mode
- "Auto Occurrence Display"
- "Display another occurrence when moving the cursor"))
+ `(menu-item ,(purecopy "Auto Occurrence Display")
+ next-error-follow-minor-mode
+ :help ,(purecopy
+ "Display another occurrence when moving the cursor")
+ :button (:toggle . (and (boundp 'next-error-follow-minor-mode)
+ next-error-follow-minor-mode))))
(define-key map [separator-1] menu-bar-separator)
(define-key map [kill-this-buffer]
- `(menu-item ,(purecopy "Kill occur buffer") kill-this-buffer
+ `(menu-item ,(purecopy "Kill Occur Buffer") kill-this-buffer
:help ,(purecopy "Kill the current *Occur* buffer")))
(define-key map [quit-window]
- `(menu-item ,(purecopy "Quit occur window") quit-window
+ `(menu-item ,(purecopy "Quit Occur Window") quit-window
:help ,(purecopy "Quit the current *Occur* buffer. Bury it, and maybe delete the selected frame")))
(define-key map [revert-buffer]
- `(menu-item ,(purecopy "Revert occur buffer") revert-buffer
+ `(menu-item ,(purecopy "Revert Occur Buffer") revert-buffer
:help ,(purecopy "Replace the text in the *Occur* buffer with the results of rerunning occur")))
(define-key map [clone-buffer]
- `(menu-item ,(purecopy "Clone occur buffer") clone-buffer
+ `(menu-item ,(purecopy "Clone Occur Buffer") clone-buffer
:help ,(purecopy "Create and return a twin copy of the current *Occur* buffer")))
(define-key map [occur-rename-buffer]
- `(menu-item ,(purecopy "Rename occur buffer") occur-rename-buffer
+ `(menu-item ,(purecopy "Rename Occur Buffer") occur-rename-buffer
:help ,(purecopy "Rename the current *Occur* buffer to *Occur: original-buffer-name*.")))
(define-key map [separator-2] menu-bar-separator)
(define-key map [occur-mode-goto-occurrence-other-window]
@@ -800,10 +811,10 @@ a previously found match."
`(menu-item ,(purecopy "Display Occurrence") occur-mode-display-occurrence
:help ,(purecopy "Display in another window the occurrence the current line describes")))
(define-key map [occur-next]
- `(menu-item ,(purecopy "Move to next match") occur-next
+ `(menu-item ,(purecopy "Move to Next Match") occur-next
:help ,(purecopy "Move to the Nth (default 1) next match in an Occur mode buffer")))
(define-key map [occur-prev]
- `(menu-item ,(purecopy "Move to previous match") occur-prev
+ `(menu-item ,(purecopy "Move to Previous Match") occur-prev
:help ,(purecopy "Move to the Nth (default 1) previous match in an Occur mode buffer")))
map)
"Keymap for `occur-mode'.")
@@ -830,25 +841,19 @@ for this is to reveal context in an outline-mode when the occurrence is hidden."
:group 'matching)
(put 'occur-mode 'mode-class 'special)
-(defun occur-mode ()
+(define-derived-mode occur-mode special-mode "Occur"
"Major mode for output from \\[occur].
\\<occur-mode-map>Move point to one of the items in this buffer, then use
\\[occur-mode-goto-occurrence] to go to the occurrence that the item refers to.
Alternatively, click \\[occur-mode-mouse-goto] on an item to go to it.
\\{occur-mode-map}"
- (interactive)
- (kill-all-local-variables)
- (use-local-map occur-mode-map)
- (setq major-mode 'occur-mode)
- (setq mode-name "Occur")
(set (make-local-variable 'revert-buffer-function) 'occur-revert-function)
(make-local-variable 'occur-revert-arguments)
(add-hook 'change-major-mode-hook 'font-lock-defontify nil t)
- (setq next-error-function 'occur-next-error)
- (run-mode-hooks 'occur-mode-hook))
+ (setq next-error-function 'occur-next-error))
-(defun occur-revert-function (ignore1 ignore2)
+(defun occur-revert-function (_ignore1 _ignore2)
"Handle `revert-buffer' for Occur mode buffers."
(apply 'occur-1 (append occur-revert-arguments (list (buffer-name)))))
@@ -1001,41 +1006,30 @@ 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))
- (when current-prefix-arg
- (prefix-numeric-value current-prefix-arg))))
+ (let* ((perform-collect (consp current-prefix-arg))
+ (regexp (read-regexp (if perform-collect
+ "Collect strings matching regexp"
+ "List lines matching regexp")
+ (car regexp-history))))
+ (list regexp
+ (if perform-collect
+ ;; Perform collect operation
+ (if (zerop (regexp-opt-depth regexp))
+ ;; No subexpression so collect the entire match.
+ "\\&"
+ ;; Get the regexp for collection pattern.
+ (let ((default (car occur-collect-regexp-history)))
+ (read-string
+ (format "Regexp to collect (default %s): " default)
+ nil 'occur-collect-regexp-history default)))
+ ;; Otherwise normal occur takes numerical prefix argument.
+ (when current-prefix-arg
+ (prefix-numeric-value current-prefix-arg))))))
(defun occur-rename-buffer (&optional unique-p interactive-p)
"Rename the current *Occur* buffer to *Occur: original-buffer-name*.
-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 +1046,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.
@@ -1064,10 +1058,23 @@ It serves as a menu to find any of the occurrences in this buffer.
\\<occur-mode-map>\\[describe-mode] in that buffer will explain how.
If REGEXP contains upper case characters (excluding those preceded by `\\')
-and `search-upper-case' is non-nil, the matching is case-sensitive."
+and `search-upper-case' is non-nil, the matching is case-sensitive.
+
+When NLINES is a string or when the function is called
+interactively with prefix argument without a number (`C-u' alone
+as prefix) the matching strings are collected into the `*Occur*'
+buffer by using NLINES as a replacement regexp. NLINES may
+contain \\& and \\N which convention follows `replace-match'.
+For example, providing \"defun\\s +\\(\\S +\\)\" for REGEXP and
+\"\\1\" for NLINES collects all the function names in a lisp
+program. When there is no parenthesized subexpressions in REGEXP
+the entire match is collected. In any case the searched buffers
+are not modified."
(interactive (occur-read-primary-args))
(occur-1 regexp nlines (list (current-buffer))))
+(defvar ido-ignore-item-temp-list)
+
(defun multi-occur (bufs regexp &optional nlines)
"Show all lines in buffers BUFS containing a match for REGEXP.
This function acts on multiple buffers; otherwise, it is exactly like
@@ -1146,28 +1153,54 @@ See also `multi-occur'."
(setq occur-buf (get-buffer-create buf-name))
(with-current-buffer occur-buf
- (occur-mode)
+ (if (stringp nlines)
+ (fundamental-mode) ;; This is for collect opeartion.
+ (occur-mode))
(let ((inhibit-read-only t)
;; Don't generate undo entries for creation of the initial contents.
(buffer-undo-list t))
(erase-buffer)
- (let ((count (occur-engine
- regexp active-bufs occur-buf
- (or nlines list-matching-lines-default-context-lines)
- (if (and case-fold-search search-upper-case)
- (isearch-no-upper-case-p regexp t)
- case-fold-search)
- list-matching-lines-buffer-name-face
- nil list-matching-lines-face
- (not (eq occur-excluded-properties t)))))
+ (let ((count
+ (if (stringp nlines)
+ ;; Treat nlines as a regexp to collect.
+ (let ((bufs active-bufs)
+ (count 0))
+ (while bufs
+ (with-current-buffer (car bufs)
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ ;; Insert the replacement regexp.
+ (let ((str (match-substitute-replacement nlines)))
+ (if str
+ (with-current-buffer occur-buf
+ (insert str)
+ (setq count (1+ count))
+ (or (zerop (current-column))
+ (insert "\n"))))))))
+ (setq bufs (cdr bufs)))
+ count)
+ ;; Perform normal occur.
+ (occur-engine
+ regexp active-bufs occur-buf
+ (or nlines list-matching-lines-default-context-lines)
+ (if (and case-fold-search search-upper-case)
+ (isearch-no-upper-case-p regexp t)
+ case-fold-search)
+ list-matching-lines-buffer-name-face
+ nil list-matching-lines-face
+ (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,28 +1210,26 @@ 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
+(defun occur-engine (regexp buffers out-buf nlines case-fold
title-face prefix-face match-face keep-props)
(with-current-buffer out-buf
(let ((globalcount 0)
- (coding nil))
+ (coding nil)
+ (case-fold-search case-fold))
;; Map over all the buffers
(dolist (buf buffers)
(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 +1245,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 +1272,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 +1306,46 @@ 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")))))
+ (insert data)))
(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 +1353,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 +1373,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.
@@ -1425,8 +1563,9 @@ type them using Lisp syntax."
(setcar n 'replace-count))))))
(setq n (cdr n))))
-(defun replace-eval-replacement (expression replace-count)
- (let ((replacement (eval expression)))
+(defun replace-eval-replacement (expression count)
+ (let* ((replace-count count)
+ (replacement (eval expression)))
(if (stringp replacement)
replacement
(prin1-to-string replacement t))))
@@ -1446,15 +1585,15 @@ with the `noescape' argument set.
(prin1-to-string replacement t))
t t)))
-(defun replace-loop-through-replacements (data replace-count)
+(defun replace-loop-through-replacements (data count)
;; DATA is a vector contaning the following values:
;; 0 next-rotate-count
;; 1 repeat-count
;; 2 next-replacement
;; 3 replacements
- (if (= (aref data 0) replace-count)
+ (if (= (aref data 0) count)
(progn
- (aset data 0 (+ replace-count (aref data 1)))
+ (aset data 0 (+ count (aref data 1)))
(let ((next (cdr (aref data 2))))
(aset data 2 (if (consp next) next (aref data 3))))))
(car (aref data 2)))
@@ -1879,6 +2018,11 @@ make, or the user didn't cancel the call."
(if (= replace-count 1) "" "s")))
(or (and keep-going stack) multi-buffer)))
+(defvar isearch-error)
+(defvar isearch-forward)
+(defvar isearch-case-fold-search)
+(defvar isearch-string)
+
(defvar replace-overlay nil)
(defun replace-highlight (match-beg match-end range-beg range-end
@@ -1896,6 +2040,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 ()
@@ -1905,5 +2052,4 @@ make, or the user didn't cancel the call."
(lazy-highlight-cleanup lazy-highlight-cleanup)
(setq isearch-lazy-highlight-last-string nil)))
-;; arch-tag: 16b4cd61-fd40-497b-b86f-b667c4cf88e4
;;; replace.el ends here
diff --git a/lisp/reposition.el b/lisp/reposition.el
index 3aff744ba82..51dd630a0c6 100644
--- a/lisp/reposition.el
+++ b/lisp/reposition.el
@@ -1,7 +1,6 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1991, 1994, 2001-2011 Free Software Foundation, Inc.
;; Author: Michael D. Ernst <mernst@theory.lcs.mit.edu>
;; Created: Jan 1991
@@ -58,7 +57,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 +192,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 ab2a6597366..bf18602379c 100644
--- a/lisp/reveal.el
+++ b/lisp/reveal.el
@@ -1,7 +1,6 @@
-;;; reveal.el --- Automatically reveal hidden text at point
+;;; reveal.el --- Automatically reveal hidden text at point -*- lexical-binding: t -*-
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: outlines
@@ -49,7 +48,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."
@@ -225,5 +224,4 @@ With zero or negative ARG turn mode off."
(provide 'reveal)
-;; arch-tag: 96ba0242-2274-4ed7-8e10-26bc0707b4d8
;;; reveal.el ends here
diff --git a/lisp/rfn-eshadow.el b/lisp/rfn-eshadow.el
index e574feb8b11..9eb2d2abdee 100644
--- a/lisp/rfn-eshadow.el
+++ b/lisp/rfn-eshadow.el
@@ -1,10 +1,10 @@
;;; rfn-eshadow.el --- Highlight `shadowed' part of read-file-name input text
;;
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;;
;; Author: Miles Bader <miles@gnu.org>
;; Keywords: convenience minibuffer
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -239,5 +239,4 @@ Returns non-nil if the new state is enabled."
(provide 'rfn-eshadow)
-;; arch-tag: dcf70a52-0115-4ec2-b1e3-4f8d3541a888
;;; rfn-eshadow.el ends here
diff --git a/lisp/rot13.el b/lisp/rot13.el
index 88a380775d3..89b687efdc6 100644
--- a/lisp/rot13.el
+++ b/lisp/rot13.el
@@ -1,7 +1,6 @@
;;; rot13.el --- display a buffer in ROT13
-;; Copyright (C) 1988, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1988, 2001-2011 Free Software Foundation, Inc.
;; Author: Howard Gayle
;; Maintainer: FSF
@@ -109,5 +108,4 @@ See also `toggle-rot13-mode'."
(provide 'rot13)
-;; arch-tag: ad5b9ca8-946c-4414-996f-e9b1bf9ec79f
;;; rot13.el ends here
diff --git a/lisp/ruler-mode.el b/lisp/ruler-mode.el
index ec4a724e95f..fc62bf6b633 100644
--- a/lisp/ruler-mode.el
+++ b/lisp/ruler-mode.el
@@ -1,7 +1,6 @@
;;; ruler-mode.el --- display a ruler in the header line
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001-2011 Free Software Foundation, Inc.
;; Author: David Ponce <david@dponce.com>
;; Maintainer: David Ponce <david@dponce.com>
@@ -550,21 +549,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)
@@ -761,5 +775,4 @@ Optional argument PROPS specifies other text properties to apply."
;; coding: iso-latin-1
;; End:
-;; arch-tag: b2f24546-5605-44c4-b67b-c9a4eeba3ee8
;;; ruler-mode.el ends here
diff --git a/lisp/savehist.el b/lisp/savehist.el
index 99a1f5ff561..653d0312a19 100644
--- a/lisp/savehist.el
+++ b/lisp/savehist.el
@@ -1,7 +1,6 @@
-;;; savehist.el --- Save minibuffer history.
+;;; savehist.el --- Save minibuffer history
-;; Copyright (C) 1997, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2005-2011 Free Software Foundation, Inc.
;; Author: Hrvoje Niksic <hniksic@xemacs.org>
;; Maintainer: FSF
@@ -59,17 +58,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 +169,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 +179,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 +198,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'.
@@ -274,6 +254,10 @@ Normally invoked by calling `savehist-mode' to unset the minor mode."
(cancel-timer savehist-timer))
(setq savehist-timer nil)))
+;; From XEmacs?
+(defvar print-readably)
+(defvar print-string-length)
+
(defun savehist-save (&optional auto-save)
"Save the values of minibuffer history variables.
Unbound symbols referenced in `savehist-additional-variables' are ignored.
@@ -408,6 +392,5 @@ trimming of history lists to `history-length' items."
(provide 'savehist)
-;; arch-tag: b3ce47f4-c5ad-4ebc-ad02-73aba705cf9f
;;; savehist.el ends here
diff --git a/lisp/saveplace.el b/lisp/saveplace.el
index d4db44bface..2d1586d895a 100644
--- a/lisp/saveplace.el
+++ b/lisp/saveplace.el
@@ -1,7 +1,6 @@
;;; saveplace.el --- automatically save place in files
-;; Copyright (C) 1993, 1994, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1994, 2001-2011 Free Software Foundation, Inc.
;; Author: Karl Fogel <kfogel@red-bean.com>
;; Maintainer: FSF
@@ -213,7 +212,9 @@ may have changed\) back to `save-place-alist'."
(symbol-name coding-system-for-write)))
(let ((print-length nil)
(print-level nil))
- (print save-place-alist (current-buffer)))
+ (pp (sort save-place-alist
+ (lambda (a b) (string< (car a) (car b))))
+ (current-buffer)))
(let ((version-control
(cond
((null save-place-version-control) nil)
@@ -284,7 +285,7 @@ may have changed\) back to `save-place-alist'."
(let ((cell (assoc buffer-file-name save-place-alist)))
(if cell
(progn
- (or after-find-file-from-revert-buffer
+ (or revert-buffer-in-progress-p
(goto-char (cdr cell)))
;; and make sure it will be saved again for later
(setq save-place t)))))
@@ -299,11 +300,11 @@ may have changed\) back to `save-place-alist'."
(add-hook 'find-file-hook 'save-place-find-file-hook t)
-(add-hook 'kill-emacs-hook 'save-place-kill-emacs-hook)
+(unless noninteractive
+ (add-hook 'kill-emacs-hook 'save-place-kill-emacs-hook))
(add-hook 'kill-buffer-hook 'save-place-to-alist)
(provide 'saveplace) ; why not...
-;; arch-tag: 3c2ef47b-0a22-4558-b116-118c9ef454a0
;;; saveplace.el ends here
diff --git a/lisp/sb-image.el b/lisp/sb-image.el
index e4af3c0d7ef..843186218a5 100644
--- a/lisp/sb-image.el
+++ b/lisp/sb-image.el
@@ -1,7 +1,6 @@
;;; sb-image --- Image management for speedbar
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2003, 2005-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: file, tags, tools
@@ -105,5 +104,4 @@ See `speedbar-expand-image-button-alist' for details."
(provide 'sb-image)
-;; arch-tag: 6b05accd-e8b8-4290-8379-f063f3dacabb
;;; sb-image.el ends here
diff --git a/lisp/scroll-all.el b/lisp/scroll-all.el
index f07041c3114..6dbdc9ab90d 100644
--- a/lisp/scroll-all.el
+++ b/lisp/scroll-all.el
@@ -1,7 +1,6 @@
;;; scroll-all.el --- scroll all buffers together minor mode
-;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Gary D. Foster <Gary.Foster@corp.sun.com>
;; Keywords: scroll crisp brief lock
@@ -90,9 +89,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))
@@ -116,5 +115,4 @@ apply to all visible windows in the same frame."
(provide 'scroll-all)
-;; arch-tag: db20089a-b157-45df-b5d4-2430e60acdd8
;;; scroll-all.el ends here
diff --git a/lisp/scroll-bar.el b/lisp/scroll-bar.el
index 6e847f7f4c5..54f2ba765b5 100644
--- a/lisp/scroll-bar.el
+++ b/lisp/scroll-bar.el
@@ -1,10 +1,10 @@
;;; scroll-bar.el --- window system-independent scroll bar support
-;; Copyright (C) 1993, 1994, 1995, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1995, 1999-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: hardware
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -29,6 +29,7 @@
;;; Code:
(require 'mouse)
+(eval-when-compile (require 'cl))
;;;; Utilities.
@@ -79,9 +80,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 +105,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.
@@ -147,7 +141,7 @@ when they are turned on; if it is nil, they go on the left."
(if (> arg 0)
(or scroll-bar-mode default-frame-scroll-bars))))))
-(defun toggle-horizontal-scroll-bar (arg)
+(defun toggle-horizontal-scroll-bar (_arg)
"Toggle whether or not the selected frame has horizontal scroll bars.
With arg, turn horizontal scroll bars on if and only if arg is positive.
Horizontal scroll bars aren't implemented yet."
@@ -210,7 +204,7 @@ EVENT should be a scroll bar click or drag event."
(let* ((start-position (event-start event))
(window (nth 0 start-position))
(portion-whole (nth 2 start-position)))
- (save-excursion
+ (save-excursion
(with-current-buffer (window-buffer window)
;; Calculate position relative to the accessible part of the buffer.
(goto-char (+ (point-min)
@@ -356,5 +350,4 @@ EVENT should be a scroll bar click."
(provide 'scroll-bar)
-;; arch-tag: 6f1d01d0-0b1e-4bf8-86db-d491e0f399f3
;;; scroll-bar.el ends here
diff --git a/lisp/scroll-lock.el b/lisp/scroll-lock.el
index f8af384ba04..0fe39c2ac3e 100644
--- a/lisp/scroll-lock.el
+++ b/lisp/scroll-lock.el
@@ -1,6 +1,6 @@
;;; scroll-lock.el --- Scroll lock scrolling.
-;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2005-2011 Free Software Foundation, Inc.
;; Author: Ralf Angeli <angeli@iwi.uni-sb.de>
;; Maintainer: FSF
@@ -123,5 +123,4 @@ during scrolling."
(provide 'scroll-lock)
-;; arch-tag: 148fc8e8-67e0-4638-bb34-3291595ab7e1
;;; scroll-lock.el ends here
diff --git a/lisp/select.el b/lisp/select.el
index 9e7d844ff22..1f5191e86c1 100644
--- a/lisp/select.el
+++ b/lisp/select.el
@@ -1,12 +1,10 @@
;;; select.el --- lisp portion of standard selection support
+;; Copyright (C) 1993-1994, 2001-2011 Free Software Foundation, Inc.
+
;; Maintainer: FSF
;; Keywords: internal
-;; Copyright (C) 1993, 1994, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 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 +22,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 +65,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 +182,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.
@@ -236,7 +213,7 @@ two markers or an overlay. Otherwise, it is nil."
(defun xselect--int-to-cons (n)
(cons (ash n -16) (logand n 65535)))
-(defun xselect-convert-to-string (selection type value)
+(defun xselect-convert-to-string (_selection type value)
(let (str coding)
;; Get the actual string from VALUE.
(cond ((stringp value)
@@ -302,7 +279,7 @@ two markers or an overlay. Otherwise, it is nil."
(setq next-selection-coding-system nil)
(cons type str))))
-(defun xselect-convert-to-length (selection type value)
+(defun xselect-convert-to-length (_selection _type value)
(let ((len (cond ((stringp value)
(length value))
((setq value (xselect--selection-bounds value))
@@ -310,7 +287,7 @@ two markers or an overlay. Otherwise, it is nil."
(if len
(xselect--int-to-cons len))))
-(defun xselect-convert-to-targets (selection type value)
+(defun xselect-convert-to-targets (_selection _type _value)
;; return a vector of atoms, but remove duplicates first.
(let* ((all (cons 'TIMESTAMP (mapcar 'car selection-converter-alist)))
(rest all))
@@ -323,25 +300,25 @@ two markers or an overlay. Otherwise, it is nil."
(setq rest (cdr rest)))))
(apply 'vector all)))
-(defun xselect-convert-to-delete (selection type value)
+(defun xselect-convert-to-delete (selection _type _value)
(x-disown-selection-internal selection)
;; A return value of nil means that we do not know how to do this conversion,
;; and replies with an "error". A return value of NULL means that we have
;; done the conversion (and any side-effects) but have no value to return.
'NULL)
-(defun xselect-convert-to-filename (selection type value)
+(defun xselect-convert-to-filename (_selection _type value)
(when (setq value (xselect--selection-bounds value))
(buffer-file-name (nth 2 value))))
-(defun xselect-convert-to-charpos (selection type value)
+(defun xselect-convert-to-charpos (_selection _type value)
(when (setq value (xselect--selection-bounds value))
(let ((beg (1- (nth 0 value))) ; zero-based
(end (1- (nth 1 value))))
(cons 'SPAN (vector (xselect--int-to-cons (min beg end))
(xselect--int-to-cons (max beg end)))))))
-(defun xselect-convert-to-lineno (selection type value)
+(defun xselect-convert-to-lineno (_selection _type value)
(when (setq value (xselect--selection-bounds value))
(with-current-buffer (nth 2 value)
(let ((beg (line-number-at-pos (nth 0 value)))
@@ -349,7 +326,7 @@ two markers or an overlay. Otherwise, it is nil."
(cons 'SPAN (vector (xselect--int-to-cons (min beg end))
(xselect--int-to-cons (max beg end))))))))
-(defun xselect-convert-to-colno (selection type value)
+(defun xselect-convert-to-colno (_selection _type value)
(when (setq value (xselect--selection-bounds value))
(with-current-buffer (nth 2 value)
(let ((beg (progn (goto-char (nth 0 value)) (current-column)))
@@ -357,35 +334,35 @@ two markers or an overlay. Otherwise, it is nil."
(cons 'SPAN (vector (xselect--int-to-cons (min beg end))
(xselect--int-to-cons (max beg end))))))))
-(defun xselect-convert-to-os (selection type size)
+(defun xselect-convert-to-os (_selection _type _size)
(symbol-name system-type))
-(defun xselect-convert-to-host (selection type size)
+(defun xselect-convert-to-host (_selection _type _size)
(system-name))
-(defun xselect-convert-to-user (selection type size)
+(defun xselect-convert-to-user (_selection _type _size)
(user-full-name))
-(defun xselect-convert-to-class (selection type size)
+(defun xselect-convert-to-class (_selection _type _size)
"Convert selection to class.
This function returns the string \"Emacs\"."
"Emacs")
;; We do not try to determine the name Emacs was invoked with,
;; because it is not clean for a program's behavior to depend on that.
-(defun xselect-convert-to-name (selection type size)
+(defun xselect-convert-to-name (_selection _type _size)
"Convert selection to name.
This function returns the string \"emacs\"."
"emacs")
-(defun xselect-convert-to-integer (selection type value)
+(defun xselect-convert-to-integer (_selection _type value)
(and (integerp value)
(xselect--int-to-cons value)))
-(defun xselect-convert-to-atom (selection type value)
+(defun xselect-convert-to-atom (_selection _type value)
(and (symbolp value) value))
-(defun xselect-convert-to-identity (selection type value) ; used internally
+(defun xselect-convert-to-identity (_selection _type value) ; used internally
(vector value))
(setq selection-converter-alist
diff --git a/lisp/server.el b/lisp/server.el
index 816a072bf75..c421ee09812 100644
--- a/lisp/server.el
+++ b/lisp/server.el
@@ -1,8 +1,6 @@
-;;; server.el --- Lisp code for GNU Emacs running as server process
+;;; server.el --- Lisp code for GNU Emacs running as server process -*- lexical-binding: t -*-
-;; Copyright (C) 1986, 1987, 1992, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
-;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1986-1987, 1992, 1994-2011 Free Software Foundation, Inc.
;; Author: William Sommerfeld <wesommer@athena.mit.edu>
;; Maintainer: FSF
@@ -110,8 +108,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 +131,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
@@ -325,9 +335,9 @@ If CLIENT is non-nil, add a description of it to the logged message."
(goto-char (point-max))
(insert (funcall server-log-time-function)
(cond
- ((null client) " ")
- ((listp client) (format " %s: " (car client)))
- (t (format " %s: " client)))
+ ((null client) " ")
+ ((listp client) (format " %s: " (car client)))
+ (t (format " %s: " client)))
string)
(or (bolp) (newline)))))
@@ -344,7 +354,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))
@@ -399,18 +410,19 @@ If CLIENT is non-nil, add a description of it to the logged message."
proc
;; See if this is the last frame for this client.
(>= 1 (let ((frame-num 0))
- (dolist (f (frame-list))
- (when (eq proc (frame-parameter f 'client))
- (setq frame-num (1+ frame-num))))
- frame-num)))
+ (dolist (f (frame-list))
+ (when (eq proc (frame-parameter f 'client))
+ (setq frame-num (1+ frame-num))))
+ frame-num)))
(server-log (format "server-handle-delete-frame, frame %s" frame) proc)
(server-delete-client proc 'noframe)))) ; Let delete-frame delete the frame later.
(defun server-handle-suspend-tty (terminal)
- "Notify the emacsclient process to suspend itself when its tty device is suspended."
+ "Notify the client process that its tty device is suspended."
(dolist (proc (server-clients-with 'terminal terminal))
- (server-log (format "server-handle-suspend-tty, terminal %s" terminal) proc)
- (condition-case err
+ (server-log (format "server-handle-suspend-tty, terminal %s" terminal)
+ proc)
+ (condition-case nil
(server-send-string proc "-suspend \n")
(file-error ;The pipe/socket was closed.
(ignore-errors (server-delete-client proc))))))
@@ -528,7 +540,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
@@ -572,8 +586,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
@@ -583,18 +597,18 @@ server or call `M-x server-force-delete' to forcibly disconnect it.")
(when server-use-tcp
(let ((auth-key
(loop
- ;; The auth key is a 64-byte string of random chars in the
- ;; range `!'..`~'.
- for i below 64
- collect (+ 33 (random 94)) into auth
- finally return (concat auth))))
+ ;; The auth key is a 64-byte string of random chars in the
+ ;; range `!'..`~'.
+ repeat 64
+ collect (+ 33 (random 94)) into auth
+ finally return (concat auth))))
(process-put server-process :auth-key auth-key)
(with-temp-file server-file
(set-buffer-multibyte nil)
(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 ()
@@ -616,7 +630,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
@@ -682,31 +696,31 @@ Server mode runs a process that accepts commands from the
(add-to-list 'frame-inherited-parameters 'client)
(let ((frame
(server-with-environment (process-get proc 'env)
- '("LANG" "LC_CTYPE" "LC_ALL"
- ;; For tgetent(3); list according to ncurses(3).
- "BAUDRATE" "COLUMNS" "ESCDELAY" "HOME" "LINES"
- "NCURSES_ASSUMED_COLORS" "NCURSES_NO_PADDING"
- "NCURSES_NO_SETBUF" "TERM" "TERMCAP" "TERMINFO"
- "TERMINFO_DIRS" "TERMPATH"
- ;; rxvt wants these
- "COLORFGBG" "COLORTERM")
- (make-frame `((window-system . nil)
- (tty . ,tty)
- (tty-type . ,type)
- ;; Ignore nowait here; we always need to
- ;; clean up opened ttys when the client dies.
- (client . ,proc)
- ;; This is a leftover from an earlier
- ;; attempt at making it possible for process
- ;; run in the server process to use the
- ;; environment of the client process.
- ;; It has no effect now and to make it work
- ;; we'd need to decide how to make
- ;; process-environment interact with client
- ;; envvars, and then to change the
- ;; C functions `child_setup' and
- ;; `getenv_internal' accordingly.
- (environment . ,(process-get proc 'env)))))))
+ '("LANG" "LC_CTYPE" "LC_ALL"
+ ;; For tgetent(3); list according to ncurses(3).
+ "BAUDRATE" "COLUMNS" "ESCDELAY" "HOME" "LINES"
+ "NCURSES_ASSUMED_COLORS" "NCURSES_NO_PADDING"
+ "NCURSES_NO_SETBUF" "TERM" "TERMCAP" "TERMINFO"
+ "TERMINFO_DIRS" "TERMPATH"
+ ;; rxvt wants these
+ "COLORFGBG" "COLORTERM")
+ (make-frame `((window-system . nil)
+ (tty . ,tty)
+ (tty-type . ,type)
+ ;; Ignore nowait here; we always need to
+ ;; clean up opened ttys when the client dies.
+ (client . ,proc)
+ ;; This is a leftover from an earlier
+ ;; attempt at making it possible for process
+ ;; run in the server process to use the
+ ;; environment of the client process.
+ ;; It has no effect now and to make it work
+ ;; we'd need to decide how to make
+ ;; process-environment interact with client
+ ;; envvars, and then to change the
+ ;; C functions `child_setup' and
+ ;; `getenv_internal' accordingly.
+ (environment . ,(process-get proc 'env)))))))
;; ttys don't use the `display' parameter, but callproc.c does to set
;; the DISPLAY environment on subprocesses.
@@ -719,12 +733,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
@@ -740,12 +751,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)
@@ -771,8 +784,7 @@ Server mode runs a process that accepts commands from the
;; frame because input from that display will be blocked (until exiting
;; the minibuffer). Better exit this minibuffer right away.
;; Similarly with recursive-edits such as the splash screen.
- (run-with-timer 0 nil (lexical-let ((proc proc))
- (lambda () (server-execute-continuation proc))))
+ (run-with-timer 0 nil (lambda () (server-execute-continuation proc)))
(top-level)))
;; We use various special properties on process objects:
@@ -890,6 +902,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)))
@@ -900,6 +915,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)
@@ -913,131 +931,134 @@ 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
- arg)
+ args-left)
;; Remove this line from STRING.
(setq string (substring string (match-end 0)))
- (setq command-line-args-left
+ (setq args-left
(mapcar 'server-unquote-arg (split-string request " " t)))
- (while (setq arg (pop command-line-args-left))
- (cond
- ;; -version CLIENT-VERSION: obsolete at birth.
- ((and (equal "-version" arg) command-line-args-left)
- (pop command-line-args-left))
-
- ;; -nowait: Emacsclient won't wait for a result.
- ((equal "-nowait" arg) (setq nowait t))
-
- ;; -current-frame: Don't create frames.
- ((equal "-current-frame" arg) (setq use-current-frame t))
-
- ;; -display DISPLAY:
- ;; Open X frames on the given display instead of the default.
- ((and (equal "-display" arg) command-line-args-left)
- (setq display (pop command-line-args-left))
- (if (zerop (length display)) (setq display nil)))
-
- ;; -window-system: Open a new X frame.
- ((equal "-window-system" arg)
- (setq dontkill t)
- (setq tty-name 'window-system))
-
- ;; -resume: Resume a suspended tty frame.
- ((equal "-resume" arg)
- (lexical-let ((terminal (process-get proc 'terminal)))
- (setq dontkill t)
- (push (lambda ()
- (when (eq (terminal-live-p terminal) t)
- (resume-tty terminal)))
- commands)))
-
- ;; -suspend: Suspend the client's frame. (In case we
- ;; get out of sync, and a C-z sends a SIGTSTP to
- ;; emacsclient.)
- ((equal "-suspend" arg)
- (lexical-let ((terminal (process-get proc 'terminal)))
- (setq dontkill t)
- (push (lambda ()
- (when (eq (terminal-live-p terminal) t)
- (suspend-tty terminal)))
- commands)))
-
- ;; -ignore COMMENT: Noop; useful for debugging emacsclient.
- ;; (The given comment appears in the server log.)
- ((and (equal "-ignore" arg) command-line-args-left
- (setq dontkill t)
- (pop command-line-args-left)))
-
- ;; -tty DEVICE-NAME TYPE: Open a new tty frame at the client.
- ((and (equal "-tty" arg)
- (cdr command-line-args-left))
- (setq tty-name (pop command-line-args-left)
- tty-type (pop command-line-args-left)
- dontkill (or dontkill
- (not use-current-frame))))
-
- ;; -position LINE[:COLUMN]: Set point to the given
- ;; position in the next file.
- ((and (equal "-position" arg)
- command-line-args-left
- (string-match "\\+\\([0-9]+\\)\\(?::\\([0-9]+\\)\\)?"
- (car command-line-args-left)))
- (setq arg (pop command-line-args-left))
- (setq filepos
- (cons (string-to-number (match-string 1 arg))
- (string-to-number (or (match-string 2 arg) "")))))
-
- ;; -file FILENAME: Load the given file.
- ((and (equal "-file" arg)
- command-line-args-left)
- (let ((file (pop command-line-args-left)))
- (if coding-system
- (setq file (decode-coding-string file coding-system)))
- (setq file (expand-file-name file dir))
- (push (cons file filepos) files)
- (server-log (format "New file: %s %s"
- file (or filepos "")) proc))
- (setq filepos nil))
-
- ;; -eval EXPR: Evaluate a Lisp expression.
- ((and (equal "-eval" arg)
- command-line-args-left)
- (if use-current-frame
- (setq use-current-frame 'always))
- (lexical-let ((expr (pop command-line-args-left)))
- (if coding-system
- (setq expr (decode-coding-string expr coding-system)))
- (push (lambda () (server-eval-and-print expr proc))
- commands)
- (setq filepos nil)))
-
- ;; -env NAME=VALUE: An environment variable.
- ((and (equal "-env" arg) command-line-args-left)
- (let ((var (pop command-line-args-left)))
- ;; XXX Variables should be encoded as in getenv/setenv.
- (process-put proc 'env
- (cons var (process-get proc 'env)))))
-
- ;; -dir DIRNAME: The cwd of the emacsclient process.
- ((and (equal "-dir" arg) command-line-args-left)
- (setq dir (pop command-line-args-left))
- (if coding-system
- (setq dir (decode-coding-string dir coding-system)))
- (setq dir (command-line-normalize-file-name dir)))
-
- ;; Unknown command.
- (t (error "Unknown command: %s" arg))))
+ (while args-left
+ (pcase (pop args-left)
+ ;; -version CLIENT-VERSION: obsolete at birth.
+ (`"-version" (pop args-left))
+
+ ;; -nowait: Emacsclient won't wait for a result.
+ (`"-nowait" (setq nowait t))
+
+ ;; -current-frame: Don't create frames.
+ (`"-current-frame" (setq use-current-frame t))
+
+ ;; -display DISPLAY:
+ ;; Open X frames on the given display instead of the default.
+ (`"-display"
+ (setq display (pop args-left))
+ (if (zerop (length display)) (setq display nil)))
+
+ ;; -parent-id ID:
+ ;; Open X frame within window ID, via XEmbed.
+ (`"-parent-id"
+ (setq parent-id (pop args-left))
+ (if (zerop (length parent-id)) (setq parent-id nil)))
+
+ ;; -window-system: Open a new X frame.
+ (`"-window-system"
+ (setq dontkill t)
+ (setq tty-name 'window-system))
+
+ ;; -resume: Resume a suspended tty frame.
+ (`"-resume"
+ (let ((terminal (process-get proc 'terminal)))
+ (setq dontkill t)
+ (push (lambda ()
+ (when (eq (terminal-live-p terminal) t)
+ (resume-tty terminal)))
+ commands)))
+
+ ;; -suspend: Suspend the client's frame. (In case we
+ ;; get out of sync, and a C-z sends a SIGTSTP to
+ ;; emacsclient.)
+ (`"-suspend"
+ (let ((terminal (process-get proc 'terminal)))
+ (setq dontkill t)
+ (push (lambda ()
+ (when (eq (terminal-live-p terminal) t)
+ (suspend-tty terminal)))
+ commands)))
+
+ ;; -ignore COMMENT: Noop; useful for debugging emacsclient.
+ ;; (The given comment appears in the server log.)
+ (`"-ignore"
+ (setq dontkill t)
+ (pop args-left))
+
+ ;; -tty DEVICE-NAME TYPE: Open a new tty frame at the client.
+ (`"-tty"
+ (setq tty-name (pop args-left)
+ tty-type (pop args-left)
+ dontkill (or dontkill
+ (not use-current-frame))))
+
+ ;; -position LINE[:COLUMN]: Set point to the given
+ ;; position in the next file.
+ (`"-position"
+ (if (not (string-match "\\+\\([0-9]+\\)\\(?::\\([0-9]+\\)\\)?"
+ (car args-left)))
+ (error "Invalid -position command in client args"))
+ (let ((arg (pop args-left)))
+ (setq filepos
+ (cons (string-to-number (match-string 1 arg))
+ (string-to-number (or (match-string 2 arg)
+ ""))))))
+
+ ;; -file FILENAME: Load the given file.
+ (`"-file"
+ (let ((file (pop args-left)))
+ (if coding-system
+ (setq file (decode-coding-string file coding-system)))
+ (setq file (expand-file-name file dir))
+ (push (cons file filepos) files)
+ (server-log (format "New file: %s %s"
+ file (or filepos "")) proc))
+ (setq filepos nil))
+
+ ;; -eval EXPR: Evaluate a Lisp expression.
+ (`"-eval"
+ (if use-current-frame
+ (setq use-current-frame 'always))
+ (let ((expr (pop args-left)))
+ (if coding-system
+ (setq expr (decode-coding-string expr coding-system)))
+ (push (lambda () (server-eval-and-print expr proc))
+ commands)
+ (setq filepos nil)))
+
+ ;; -env NAME=VALUE: An environment variable.
+ (`"-env"
+ (let ((var (pop args-left)))
+ ;; XXX Variables should be encoded as in getenv/setenv.
+ (process-put proc 'env
+ (cons var (process-get proc 'env)))))
+
+ ;; -dir DIRNAME: The cwd of the emacsclient process.
+ (`"-dir"
+ (setq dir (pop args-left))
+ (if coding-system
+ (setq dir (decode-coding-string dir coding-system)))
+ (setq dir (command-line-normalize-file-name dir)))
+
+ ;; Unknown command.
+ (arg (error "Unknown command: %s" arg))))
(setq frame
(cond
@@ -1052,30 +1073,23 @@ 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))))
(process-put
proc 'continuation
- (lexical-let ((proc proc)
- (files files)
- (nowait nowait)
- (commands commands)
- (dontkill dontkill)
- (frame frame)
- (dir dir)
- (tty-name tty-name))
- (lambda ()
- (with-current-buffer (get-buffer-create server-buffer)
- ;; Use the same cwd as the emacsclient, if possible, so
- ;; relative file names work correctly, even in `eval'.
- (let ((default-directory
- (if (and dir (file-directory-p dir))
- dir default-directory)))
- (server-execute proc files nowait commands
- dontkill frame tty-name))))))
+ (lambda ()
+ (with-current-buffer (get-buffer-create server-buffer)
+ ;; Use the same cwd as the emacsclient, if possible, so
+ ;; relative file names work correctly, even in `eval'.
+ (let ((default-directory
+ (if (and dir (file-directory-p dir))
+ dir default-directory)))
+ (server-execute proc files nowait commands
+ dontkill frame tty-name)))))
(when (or frame files)
(server-goto-toplevel proc))
@@ -1096,9 +1110,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))
@@ -1134,6 +1146,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)
@@ -1169,8 +1184,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)))
@@ -1182,7 +1202,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)
@@ -1192,7 +1214,10 @@ so don't mark these buffers specially, just visit them normally."
(process-put proc 'buffers
(nconc (process-get proc 'buffers) client-record)))
client-record))
-
+
+(defvar server-kill-buffer-running nil
+ "Non-nil while `server-kill-buffer' or `server-buffer-done' is running.")
+
(defun server-buffer-done (buffer &optional for-killing)
"Mark BUFFER as \"done\" for its client(s).
This buries the buffer, then returns a list of the form (NEXT-BUFFER KILLED).
@@ -1314,9 +1339,6 @@ specifically for the clients and did not exist before their request for it."
(setq live-client t))))
(yes-or-no-p "This Emacs session has clients; exit anyway? ")))
-(defvar server-kill-buffer-running nil
- "Non-nil while `server-kill-buffer' or `server-buffer-done' is running.")
-
(defun server-kill-buffer ()
"Remove the current buffer from its clients' buffer list.
Designed to be added to `kill-buffer-hook'."
@@ -1344,12 +1366,12 @@ If invoked with a prefix argument, or if there is no server process running,
starts server process and that is all. Invoked by \\[server-edit]."
(interactive "P")
(cond
- ((or arg
- (not server-process)
- (memq (process-status server-process) '(signal exit)))
- (server-mode 1))
- (server-clients (apply 'server-switch-buffer (server-done)))
- (t (message "No server editing buffers exist"))))
+ ((or arg
+ (not server-process)
+ (memq (process-status server-process) '(signal exit)))
+ (server-mode 1))
+ (server-clients (apply 'server-switch-buffer (server-done)))
+ (t (message "No server editing buffers exist"))))
(defun server-switch-buffer (&optional next-buffer killed-one filepos)
"Switch to another buffer, preferably one that has a client.
@@ -1462,8 +1484,46 @@ only these files will be asked to be saved."
;; continue standard unloading
nil)
+(defun server-eval-at (server form)
+ "Eval FORM on Emacs Server SERVER."
+ (let ((auth-file (expand-file-name server server-auth-dir))
+ (coding-system-for-read 'binary)
+ (coding-system-for-write 'binary)
+ address port secret process)
+ (unless (file-exists-p auth-file)
+ (error "No such server definition: %s" auth-file))
+ (with-temp-buffer
+ (insert-file-contents auth-file)
+ (unless (looking-at "\\([0-9.]+\\):\\([0-9]+\\)")
+ (error "Invalid auth file"))
+ (setq address (match-string 1)
+ port (string-to-number (match-string 2)))
+ (forward-line 1)
+ (setq secret (buffer-substring (point) (line-end-position)))
+ (erase-buffer)
+ (unless (setq process (open-network-stream "eval-at" (current-buffer)
+ address port))
+ (error "Unable to contact the server"))
+ (set-process-query-on-exit-flag process nil)
+ (process-send-string
+ process
+ (concat "-auth " secret " -eval "
+ (replace-regexp-in-string
+ " " "&_" (format "%S" form))
+ "\n"))
+ (while (memq (process-status process) '(open run))
+ (accept-process-output process 0 10))
+ (goto-char (point-min))
+ ;; If the result is nil, there's nothing in the buffer. If the
+ ;; result is non-nil, it's after "-print ".
+ (when (search-forward "\n-print" nil t)
+ (let ((start (point)))
+ (while (search-forward "&_" nil t)
+ (replace-match " " t t))
+ (goto-char start)
+ (read (current-buffer)))))))
+
(provide 'server)
-;; arch-tag: 1f7ecb42-f00a-49f8-906d-61995d84c8d6
;;; server.el ends here
diff --git a/lisp/ses.el b/lisp/ses.el
index 36a7b8ded04..2fc85d27df9 100644
--- a/lisp/ses.el
+++ b/lisp/ses.el
@@ -1,7 +1,6 @@
;;; ses.el -- Simple Emacs Spreadsheet -*- coding: utf-8 -*-
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Jonathan Yavner <jyavner@member.fsf.org>
;; Maintainer: Jonathan Yavner <jyavner@member.fsf.org>
@@ -3017,5 +3016,4 @@ current column and continues until the next nonblank column."
(provide 'ses)
-;; arch-tag: 88c1ccf0-4293-4824-8c5d-0757b52217f3
;;; ses.el ends here
diff --git a/lisp/sha1.el b/lisp/sha1.el
index 09db2a4ab37..3f2e8f2a69b 100644
--- a/lisp/sha1.el
+++ b/lisp/sha1.el
@@ -1,7 +1,6 @@
;;; sha1.el --- SHA1 Secure Hash Algorithm in Emacs-Lisp
-;; Copyright (C) 1999, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2001-2011 Free Software Foundation, Inc.
;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
;; Keywords: SHA1, FIPS 180-1
@@ -95,7 +94,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 +438,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/shadowfile.el b/lisp/shadowfile.el
index 20d793619ca..1a929ebb58a 100644
--- a/lisp/shadowfile.el
+++ b/lisp/shadowfile.el
@@ -1,7 +1,6 @@
;;; shadowfile.el --- automatic file copying
-;; Copyright (C) 1993, 1994, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1994, 2001-2011 Free Software Foundation, Inc.
;; Author: Boris Goldowsky <boris@gnu.org>
;; Keywords: comm files
@@ -89,7 +88,7 @@
(defcustom shadow-noquery nil
"If t, always copy shadow files without asking.
-If nil \(the default), always ask. If not nil and not t, ask only if there
+If nil (the default), always ask. If not nil and not t, ask only if there
is no buffer currently visiting the file."
:type '(choice (const t) (const nil) (other :tag "Ask if no buffer" maybe))
:group 'shadow)
@@ -126,7 +125,7 @@ Default: ~/.shadow_todo"
;;; The following two variables should in most cases initialize themselves
;;; correctly. They are provided as variables in case the defaults are wrong
-;;; on your machine \(and for efficiency).
+;;; on your machine (and for efficiency).
(defvar shadow-system-name (system-name)
"The complete hostname of this machine.")
@@ -139,7 +138,7 @@ Default: ~/.shadow_todo"
;;;
(defvar shadow-clusters nil
- "List of host clusters \(see `shadow-define-cluster').")
+ "List of host clusters (see `shadow-define-cluster').")
(defvar shadow-literal-groups nil
"List of files that are shared between hosts.
@@ -260,7 +259,7 @@ information defining the cluster. For interactive use, call
;;; SITES
(defun shadow-site-cluster (site)
- "Given a SITE \(hostname or cluster name), return cluster it is in, or nil."
+ "Given a SITE (hostname or cluster name), return cluster it is in, or nil."
(or (assoc site shadow-clusters)
(shadow-find
(function (lambda (x)
@@ -296,7 +295,7 @@ be matched against the primary of SITE2."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun shadow-parse-fullname (fullname)
- "Parse FULLNAME into \(site user path) list.
+ "Parse FULLNAME into (site user path) list.
Leave it alone if it already is one. Return nil if the argument is
not a full ange-ftp pathname."
(if (listp fullname)
@@ -304,7 +303,7 @@ not a full ange-ftp pathname."
(ange-ftp-ftp-name fullname)))
(defun shadow-parse-name (name)
- "Parse any NAME into \(site user name) list.
+ "Parse any NAME into (site user name) list.
Argument can be a simple name, full ange-ftp name, or already a hup list."
(or (shadow-parse-fullname name)
(list shadow-system-name
@@ -338,8 +337,7 @@ return nil."
(defun shadow-expand-cluster-in-file-name (file)
"If hostname part of FILE is a cluster, expand it to cluster's primary hostname.
Will return the name bare if it is a local file."
- (let ((hup (shadow-parse-name file))
- cluster)
+ (let ((hup (shadow-parse-name file)))
(cond ((null hup) file)
((shadow-local-file hup))
((shadow-make-fullname (shadow-site-primary (nth 0 hup))
@@ -406,10 +404,10 @@ filename expansion or contraction, you must do that yourself first."
;;;###autoload
(defun shadow-define-cluster (name)
- "Edit \(or create) the definition of a cluster NAME.
+ "Edit (or create) the definition of a cluster NAME.
This is a group of hosts that share directories, so that copying to or from
one of them is sufficient to update the file on all of them. Clusters are
-defined by a name, the network address of a primary host \(the one we copy
+defined by a name, the network address of a primary host (the one we copy
files to), and a regular expression that matches the hostnames of all the
sites in the cluster."
(interactive (list (completing-read "Cluster name: " shadow-clusters () ())))
@@ -443,7 +441,7 @@ sites in the cluster."
"Declare a single file to be shared between sites.
It may have different filenames on each site. When this file is edited, the
new version will be copied to each of the other locations. Sites can be
-specific hostnames, or names of clusters \(see `shadow-define-cluster')."
+specific hostnames, or names of clusters (see `shadow-define-cluster')."
(interactive)
(let* ((hup (shadow-parse-fullname
(shadow-contract-file-name (buffer-file-name))))
@@ -467,8 +465,8 @@ specific hostnames, or names of clusters \(see `shadow-define-cluster')."
"Make each of a group of files be shared between hosts.
Prompts for regular expression; files matching this are shared between a list
of sites, which are also prompted for. The filenames must be identical on all
-hosts \(if they aren't, use `shadow-define-literal-group' instead of this
-function). Each site can be either a hostname or the name of a cluster \(see
+hosts (if they aren't, use `shadow-define-literal-group' instead of this
+function). Each site can be either a hostname or the name of a cluster (see
`shadow-define-cluster')."
(interactive)
(let ((regexp (read-string
@@ -546,7 +544,7 @@ permanently, remove the group from `shadow-literal-groups' or
(defun shadow-make-group (regexp sites usernames)
"Make a description of a file group---
-actually a list of regexp ange-ftp file names---from REGEXP \(name of file to
+actually a list of regexp ange-ftp file names---from REGEXP (name of file to
be shadowed), list of SITES, and corresponding list of USERNAMES for each
site."
(if sites
@@ -573,7 +571,7 @@ site."
(to (shadow-expand-cluster-in-file-name (cdr s))))
(when buffer
(set-buffer buffer)
- (condition-case i
+ (condition-case nil
(progn
(write-region nil nil to)
(shadow-remove-from-todo s))
@@ -582,7 +580,7 @@ site."
(defun shadow-shadows-of (file)
"Return copy operations needed to update FILE.
Filename should have clusters expanded, but otherwise can have any format.
-Return value is a list of dotted pairs like \(from . to), where from
+Return value is a list of dotted pairs like (from . to), where from
and to are absolute file names."
(or (symbol-value (intern-soft file shadow-hashtable))
(let* ((absolute-file (shadow-expand-file-name
@@ -832,5 +830,4 @@ look for files that have been changed and need to be copied to other systems."
(provide 'shadowfile)
-;; arch-tag: e2f4cdd7-2bab-4def-9130-9e69b412b79e
;;; shadowfile.el ends here
diff --git a/lisp/shell.el b/lisp/shell.el
index 100bbc40376..d6bc685618c 100644
--- a/lisp/shell.el
+++ b/lisp/shell.el
@@ -1,7 +1,6 @@
-;;; shell.el --- specialized comint.el for running the shell
+;;; shell.el --- specialized comint.el for running the shell -*- lexical-binding: t -*-
-;; Copyright (C) 1988, 1993, 1994, 1995, 1996, 1997, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1988, 1993-1997, 2000-2011 Free Software Foundation, Inc.
;; Author: Olin Shivers <shivers@cs.cmu.edu>
;; Simon Marshall <simon@gnu.org>
@@ -70,7 +69,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
@@ -80,7 +79,7 @@
;; Shell Mode Commands:
;; shell Fires up the shell process
-;; tab comint-dynamic-complete Complete filename/command/history
+;; tab completion-at-point Complete filename/command/history
;; m-? comint-dynamic-list-filename-completions
;; List completions in help buffer
;; m-c-f shell-forward-command Forward a shell command
@@ -97,6 +96,7 @@
;;; Code:
+(eval-when-compile (require 'cl))
(require 'comint)
;;; Customization and Buffer Variables
@@ -152,12 +152,14 @@ This is a fine thing to set in your `.emacs' file."
:type '(repeat (string :tag "Suffix"))
:group 'shell)
-(defvar shell-delimiter-argument-list '(?\| ?& ?< ?> ?\( ?\) ?\;)
+(defcustom shell-delimiter-argument-list nil ; '(?\| ?& ?< ?> ?\( ?\) ?\;)
"List of characters to recognize as separate arguments.
This variable is used to initialize `comint-delimiter-argument-list' in the
-shell buffer. The value may depend on the operating system or shell.
-
-This is a fine thing to set in your `.emacs' file.")
+shell buffer. The value may depend on the operating system or shell."
+ :type '(choice (const nil)
+ (repeat :tag "List of characters" character))
+ :version "24.1" ; changed to nil (bug#8027)
+ :group 'shell)
(defvar shell-file-name-chars
(if (memq system-type '(ms-dos windows-nt cygwin))
@@ -180,12 +182,12 @@ shell buffer. The value may depend on the operating system or shell.
This is a fine thing to set in your `.emacs' file.")
(defvar shell-dynamic-complete-functions
- '(comint-replace-by-expanded-history
- shell-dynamic-complete-environment-variable
- shell-dynamic-complete-command
- shell-replace-by-expanded-directory
- shell-dynamic-complete-filename
- comint-dynamic-complete-filename)
+ '(comint-c-a-p-replace-by-expanded-history
+ shell-environment-variable-completion
+ shell-command-completion
+ shell-c-a-p-replace-by-expanded-directory
+ shell-filename-completion
+ comint-filename-completion)
"List of functions called to perform completion.
This variable is used to initialize `comint-dynamic-complete-functions' in the
shell buffer.
@@ -311,7 +313,7 @@ This mirrors the optional behavior of tcsh (its autoexpand and histlit).
If the value is `input', then the expansion is seen on input.
If the value is `history', then the expansion is only when inserting
into the buffer's input ring. See also `comint-magic-space' and
-`comint-dynamic-complete'.
+`comint-dynamic-complete-functions'.
This variable supplies a default for `comint-input-autoexpand',
for Shell mode only."
@@ -334,25 +336,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" 'completion-at-point)
+ (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 +369,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"
@@ -447,7 +460,12 @@ buffer."
;; shell-dependent assignments.
(when (ring-empty-p comint-input-ring)
(let ((shell (file-name-nondirectory (car
- (process-command (get-buffer-process (current-buffer)))))))
+ (process-command (get-buffer-process (current-buffer))))))
+ (hsize (getenv "HISTSIZE")))
+ (and (stringp hsize)
+ (integerp (setq hsize (string-to-number hsize)))
+ (> hsize 0)
+ (set (make-local-variable 'comint-input-ring-size) hsize))
(setq comint-input-ring-file-name
(or (getenv "HISTFILE")
(cond ((string-equal shell "bash") "~/.bash_history")
@@ -469,8 +487,12 @@ buffer."
(t "dirs")))
;; Bypass a bug in certain versions of bash.
(when (string-equal shell "bash")
- (add-hook 'comint-output-filter-functions
+ (add-hook 'comint-preoutput-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)
@@ -483,15 +505,10 @@ started with the `--noediting' option and Select Graphic
Rendition (SGR) control sequences (formerly known as ANSI escape
sequences) are used to color the prompt.
-This function can be put on `comint-output-filter-functions'.
-The argument STRING is ignored."
- (let ((pmark (process-mark (get-buffer-process (current-buffer)))))
- (save-excursion
- (goto-char (or (and (markerp comint-last-output-start)
- (marker-position comint-last-output-start))
- (point-min)))
- (while (re-search-forward "[\C-a\C-b]" pmark t)
- (replace-match "")))))
+This function can be put on `comint-preoutput-filter-functions'."
+ (if (string-match "[\C-a\C-b]" string)
+ (replace-regexp-in-string "[\C-a\C-b]" "" string t t)
+ string))
(defun shell-write-history-on-exit (process event)
"Called when the shell process is stopped.
@@ -549,13 +566,34 @@ 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
+ (read-directory-name
"Default directory: " default-directory default-directory
- t nil 'file-directory-p))))))))
+ t nil))))))))
(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)))
+
+ ;; On remote hosts, the local `shell-file-name' might be useless.
+ (if (and (called-interactively-p 'any)
+ (file-remote-p default-directory)
+ (null explicit-shell-file-name)
+ (null (getenv "ESHELL")))
+ (with-current-buffer buffer
+ (set (make-local-variable 'explicit-shell-file-name)
+ (file-remote-p
+ (expand-file-name
+ (read-file-name
+ "Remote shell path: " default-directory shell-file-name
+ t shell-file-name))
+ 'localname))))
+
;; 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 +656,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.
@@ -636,7 +688,7 @@ and `shell-pushd-dunique' control the behavior of the relevant command.
Environment variables are expanded, see function `substitute-in-file-name'."
(if shell-dirtrackp
;; We fail gracefully if we think the command will fail in the shell.
- (condition-case chdir-failure
+ (condition-case nil
(let ((start (progn (string-match
(concat "^" shell-command-separator-regexp)
str) ; skip whitespace
@@ -700,7 +752,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 +980,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 " "))))
@@ -955,30 +1007,36 @@ candidates. Note that this may not be the same as the shell's idea of the
path.
Completion is dependent on the value of `shell-completion-execonly', plus
-those that effect file completion. See `shell-dynamic-complete-as-command'.
+those that effect file completion.
Returns t if successful."
(interactive)
+ (let ((data (shell-command-completion)))
+ (if data
+ (prog2 (unless (window-minibuffer-p (selected-window))
+ (message "Completing command name..."))
+ (apply #'completion-in-region data)))))
+
+(defun shell-command-completion ()
+ "Return the completion data for the command at point, if any."
(let ((filename (comint-match-partial-filename)))
(if (and filename
(save-match-data (not (string-match "[~/]" filename)))
(eq (match-beginning 0)
(save-excursion (shell-backward-command 1) (point))))
- (prog2 (unless (window-minibuffer-p (selected-window))
- (message "Completing command name..."))
- (shell-dynamic-complete-as-command)))))
-
+ (shell--command-completion-data))))
-(defun shell-dynamic-complete-as-command ()
- "Dynamically complete at point as a command.
-See `shell-dynamic-complete-filename'. Returns t if successful."
+(defun shell--command-completion-data ()
+ "Return the completion data for the command at point."
(let* ((filename (or (comint-match-partial-filename) ""))
+ (start (if (zerop (length filename)) (point) (match-beginning 0)))
+ (end (if (zerop (length filename)) (point) (match-end 0)))
(filenondir (file-name-nondirectory filename))
- (path-dirs (cdr (reverse exec-path)))
+ (path-dirs (cdr (reverse exec-path))) ;FIXME: Why `cdr'?
(cwd (file-name-as-directory (expand-file-name default-directory)))
(ignored-extensions
(and comint-completion-fignore
- (mapconcat (function (lambda (x) (concat (regexp-quote x) "$")))
+ (mapconcat (function (lambda (x) (concat (regexp-quote x) "\\'")))
comint-completion-fignore "\\|")))
(dir "") (comps-in-dir ())
(file "") (abs-file-name "") (completions ()))
@@ -1002,18 +1060,31 @@ See `shell-dynamic-complete-filename'. Returns t if successful."
(setq comps-in-dir (cdr comps-in-dir)))
(setq path-dirs (cdr path-dirs)))
;; OK, we've got a list of completions.
- (let ((success (let ((comint-completion-addsuffix nil))
- (comint-dynamic-simple-complete filenondir completions))))
- (if (and (memq success '(sole shortest)) comint-completion-addsuffix
- (not (file-directory-p (comint-match-partial-filename))))
- (insert " "))
- success)))
+ (list
+ start end
+ (lambda (string pred action)
+ (completion-table-with-terminator
+ " " (lambda (string pred action)
+ (if (string-match "/" string)
+ (completion-file-name-table string pred action)
+ (complete-with-action action completions string pred)))
+ string pred action)))))
+
+;; (defun shell-dynamic-complete-as-command ()
+;; "Dynamically complete at point as a command.
+;; See `shell-dynamic-complete-filename'. Returns t if successful."
+;; (apply #'completion-in-region shell--command-completion-data))
(defun shell-dynamic-complete-filename ()
"Dynamically complete the filename at point.
This completes only if point is at a suitable position for a
filename argument."
(interactive)
+ (let ((data (shell-filename-completion)))
+ (if data (apply #'completion-in-region data))))
+
+(defun shell-filename-completion ()
+ "Return the completion data for file name at point, if any."
(let ((opoint (point))
(beg (comint-line-beginning-position)))
(when (save-excursion
@@ -1021,24 +1092,21 @@ filename argument."
(match-end 0)
beg))
(re-search-forward "[^ \t][ \t]" opoint t))
- (comint-dynamic-complete-as-filename))))
+ (comint-filename-completion))))
(defun shell-match-partial-variable ()
"Return the shell variable at point, or nil if none is found."
(save-excursion
- (let ((limit (point)))
- (if (re-search-backward "[^A-Za-z0-9_{}]" nil 'move)
- (or (looking-at "\\$") (forward-char 1)))
- ;; Anchor the search forwards.
- (if (or (eolp) (looking-at "[^A-Za-z0-9_{}$]"))
- nil
- (re-search-forward "\\$?{?[A-Za-z0-9_]*}?" limit)
- (buffer-substring (match-beginning 0) (match-end 0))))))
+ (if (re-search-backward "[^A-Za-z0-9_{(]" nil 'move)
+ (or (looking-at "\\$") (forward-char 1)))
+ (if (or (eolp) (looking-at "[^A-Za-z0-9_{($]"))
+ nil
+ (looking-at "\\$?[{(]?[A-Za-z0-9_]*[})]?")
+ (buffer-substring (match-beginning 0) (match-end 0)))))
(defun shell-dynamic-complete-environment-variable ()
"Dynamically complete the environment variable at point.
Completes if after a variable, i.e., if it starts with a \"$\".
-See `shell-dynamic-complete-as-environment-variable'.
This function is similar to `comint-dynamic-complete-filename', except that it
searches `process-environment' for completion candidates. Note that this may
@@ -1050,38 +1118,69 @@ called `shell-dynamic-complete-process-environment-variable'.
Returns non-nil if successful."
(interactive)
- (let ((variable (shell-match-partial-variable)))
- (if (and variable (string-match "^\\$" variable))
+ (let ((data (shell-environment-variable-completion)))
+ (if data
(prog2 (unless (window-minibuffer-p (selected-window))
(message "Completing variable name..."))
- (shell-dynamic-complete-as-environment-variable)))))
-
-
-(defun shell-dynamic-complete-as-environment-variable ()
- "Dynamically complete at point as an environment variable.
-Used by `shell-dynamic-complete-environment-variable'.
-Uses `comint-dynamic-simple-complete'."
- (let* ((var (or (shell-match-partial-variable) ""))
- (variable (substring var (or (string-match "[^$({]\\|$" var) 0)))
- (variables (mapcar (function (lambda (x)
- (substring x 0 (string-match "=" x))))
- process-environment))
- (addsuffix comint-completion-addsuffix)
- (comint-completion-addsuffix nil)
- (success (comint-dynamic-simple-complete variable variables)))
- (if (memq success '(sole shortest))
- (let* ((var (shell-match-partial-variable))
- (variable (substring var (string-match "[^$({]" var)))
- (protection (cond ((string-match "{" var) "}")
- ((string-match "(" var) ")")
- (t "")))
- (suffix (cond ((null addsuffix) "")
- ((file-directory-p
- (comint-directory (getenv variable))) "/")
- (t " "))))
- (insert protection suffix)))
- success))
-
+ (apply #'completion-in-region data)))))
+
+
+(defun shell-environment-variable-completion ()
+ "Completion data for an environment variable at point, if any."
+ (let* ((var (shell-match-partial-variable))
+ (end (match-end 0)))
+ (when (and (not (zerop (length var))) (eq (aref var 0) ?$))
+ (let* ((start
+ (save-excursion
+ (goto-char (match-beginning 0))
+ (looking-at "\\$?[({]*")
+ (match-end 0)))
+ (variables (mapcar (lambda (x)
+ (substring x 0 (string-match "=" x)))
+ process-environment))
+ (suffix (case (char-before start) (?\{ "}") (?\( ")") (t ""))))
+ (list
+ start end
+ (apply-partially
+ #'completion-table-with-terminator
+ (cons (lambda (comp)
+ (concat comp
+ suffix
+ (if (file-directory-p
+ (comint-directory (getenv comp)))
+ "/")))
+ "\\`a\\`")
+ variables))))))
+
+
+(defun shell-c-a-p-replace-by-expanded-directory ()
+ "Expand directory stack reference before point.
+For use on `completion-at-point-functions'."
+ (when (comint-match-partial-filename)
+ (save-excursion
+ (goto-char (match-beginning 0))
+ (let ((stack (cons default-directory shell-dirstack))
+ (index (cond ((looking-at "=-/?")
+ (length shell-dirstack))
+ ((looking-at "=\\([0-9]+\\)/?")
+ (string-to-number
+ (buffer-substring
+ (match-beginning 1) (match-end 1)))))))
+ (when index
+ (let ((start (match-beginning 0))
+ (end (match-end 0))
+ (replacement (file-name-as-directory (nth index stack))))
+ (lambda ()
+ (cond
+ ((>= index (length stack))
+ (error "Directory stack not that deep"))
+ (t
+ (save-excursion
+ (goto-char start)
+ (insert replacement)
+ (delete-char (- end start)))
+ (message "Directory item: %d" index)
+ t)))))))))
(defun shell-replace-by-expanded-directory ()
"Expand directory stack reference before point.
@@ -1090,26 +1189,9 @@ See `default-directory' and `shell-dirstack'.
Returns t if successful."
(interactive)
- (if (comint-match-partial-filename)
- (save-excursion
- (goto-char (match-beginning 0))
- (let ((stack (cons default-directory shell-dirstack))
- (index (cond ((looking-at "=-/?")
- (length shell-dirstack))
- ((looking-at "=\\([0-9]+\\)/?")
- (string-to-number
- (buffer-substring
- (match-beginning 1) (match-end 1)))))))
- (cond ((null index)
- nil)
- ((>= index (length stack))
- (error "Directory stack not that deep"))
- (t
- (replace-match (file-name-as-directory (nth index stack)) t t)
- (message "Directory item: %d" index)
- t))))))
+ (let ((f (shell-c-a-p-replace-by-expanded-directory)))
+ (if f (funcall f))))
(provide 'shell)
-;; arch-tag: bcb5f12a-c1f4-4aea-a809-2504bd5bd797
;;; shell.el ends here
diff --git a/lisp/simple.el b/lisp/simple.el
index 8f37c8e5f0b..5efb6769e17 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -1,11 +1,10 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1987, 1993-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -29,13 +28,18 @@
;;; Code:
-;; This is for lexical-let in apply-partially.
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl)) ;For define-minor-mode.
(declare-function widget-convert "wid-edit" (type &rest args))
(declare-function shell-mode "shell" ())
+;;; From compile.el
(defvar compilation-current-error)
+(defvar compilation-context-lines)
+;;; From comint.el
+(defvar comint-file-name-quote-list)
+(defvar comint-file-name-chars)
+(defvar comint-delimiter-argument-list)
(defcustom idle-update-delay 0.5
"Idle time delay before updating various things on the screen.
@@ -401,8 +405,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.
@@ -413,9 +416,11 @@ Other major modes are defined by comparison with this one."
(define-key map " " 'scroll-up)
(define-key map "\C-?" 'scroll-down)
(define-key map "?" 'describe-mode)
+ (define-key map "h" 'describe-mode)
(define-key map ">" 'end-of-buffer)
(define-key map "<" 'beginning-of-buffer)
(define-key map "g" 'revert-buffer)
+ (define-key map "z" 'kill-this-buffer)
map))
(put 'special-mode 'mode-class 'special)
@@ -423,6 +428,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 +464,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 +519,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)
@@ -621,22 +619,32 @@ On nonblank line, delete any immediately following blank lines."
(if (looking-at "^[ \t]*\n\\'")
(delete-region (point) (point-max)))))
-(defun delete-trailing-whitespace ()
+(defun delete-trailing-whitespace (&optional start end)
"Delete all the trailing whitespace across the current buffer.
All whitespace after the last non-whitespace character in a line is deleted.
This respects narrowing, created by \\[narrow-to-region] and friends.
-A formfeed is not considered whitespace by this function."
- (interactive "*")
+A formfeed is not considered whitespace by this function.
+If the region is active, only delete whitespace within the region."
+ (interactive (progn
+ (barf-if-buffer-read-only)
+ (if (use-region-p)
+ (list (region-beginning) (region-end))
+ (list nil nil))))
(save-match-data
(save-excursion
- (goto-char (point-min))
- (while (re-search-forward "\\s-$" nil t)
- (skip-syntax-backward "-" (save-excursion (forward-line 0) (point)))
- ;; Don't delete formfeeds, even if they are considered whitespace.
- (save-match-data
- (if (looking-at ".*\f")
- (goto-char (match-end 0))))
- (delete-region (point) (match-end 0))))))
+ (let ((end-marker (copy-marker (or end (point-max))))
+ (start (or start (point-min))))
+ (goto-char start)
+ (while (re-search-forward "\\s-$" end-marker t)
+ (skip-syntax-backward "-" (save-excursion (forward-line 0) (point)))
+ ;; Don't delete formfeeds, even if they are considered whitespace.
+ (save-match-data
+ (if (looking-at ".*\f")
+ (goto-char (match-end 0))))
+ (delete-region (point) (match-end 0)))
+ (set-marker end-marker nil))))
+ ;; Return nil for the benefit of `write-file-functions'.
+ nil)
(defun newline-and-indent ()
"Insert a newline, then indent according to major mode.
@@ -768,19 +776,23 @@ If BACKWARD-ONLY is non-nil, only delete them before point."
(constrain-to-field nil orig-pos)))))
(defun just-one-space (&optional n)
- "Delete all spaces and tabs around point, leaving one space (or N spaces)."
+ "Delete all spaces and tabs around point, leaving one space (or N spaces).
+If N is negative, delete newlines as well."
(interactive "*p")
- (let ((orig-pos (point)))
- (skip-chars-backward " \t")
+ (unless n (setq n 1))
+ (let ((orig-pos (point))
+ (skip-characters (if (< n 0) " \t\n\r" " \t"))
+ (n (abs n)))
+ (skip-chars-backward skip-characters)
(constrain-to-field nil orig-pos)
- (dotimes (i (or n 1))
+ (dotimes (i n)
(if (= (following-char) ?\s)
(forward-char 1)
(insert ?\s)))
(delete-region
(point)
(progn
- (skip-chars-forward " \t")
+ (skip-chars-forward skip-characters)
(constrain-to-field nil orig-pos t)))))
(defun beginning-of-buffer (&optional arg)
@@ -840,6 +852,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)))
+ (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 +994,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 (called-interactively-p 'interactive)
+ (message "Region has %d words" count))
+ count))
+
(defun count-lines-region (start end)
"Print number of lines and characters in the region."
(interactive "r")
@@ -1055,11 +1154,12 @@ in *Help* buffer. See also the command `describe-char'."
;; Initialize read-expression-map. It is defined at C level.
(let ((m (make-sparse-keymap)))
(define-key m "\M-\t" 'lisp-complete-symbol)
+ ;; Might as well bind TAB to completion, since inserting a TAB char is much
+ ;; too rarely useful.
+ (define-key m "\t" 'lisp-complete-symbol)
(set-keymap-parent m minibuffer-local-map)
(setq read-expression-map m))
-(defvar read-expression-history nil)
-
(defvar minibuffer-completing-symbol nil
"Non-nil means completing a Lisp symbol in the minibuffer.")
@@ -1128,12 +1228,12 @@ this command arranges for all errors to enter the debugger."
current-prefix-arg))
(if (null eval-expression-debug-on-error)
- (setq values (cons (eval eval-expression-arg) values))
+ (push (eval eval-expression-arg lexical-binding) values)
(let ((old-value (make-symbol "t")) new-value)
;; Bind debug-on-error to something unique so that we can
;; detect when evaled code changes it.
(let ((debug-on-error old-value))
- (setq values (cons (eval eval-expression-arg) values))
+ (push (eval eval-expression-arg lexical-binding) values)
(setq new-value debug-on-error))
;; If evaled code has changed the value of debug-on-error,
;; propagate that change to the global binding.
@@ -1212,6 +1312,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.
@@ -1240,7 +1374,7 @@ in this use of the minibuffer.")
(defun minibuffer-history-initialize ()
(setq minibuffer-text-before-history nil))
-(defun minibuffer-avoid-prompt (new old)
+(defun minibuffer-avoid-prompt (_new _old)
"A point-motion hook for the minibuffer, that moves point out of the prompt."
(constrain-to-field nil (point-max)))
@@ -1606,7 +1740,7 @@ in the search status stack."
`(lambda (cmd)
(minibuffer-history-isearch-pop-state cmd ,minibuffer-history-position)))
-(defun minibuffer-history-isearch-pop-state (cmd hist-pos)
+(defun minibuffer-history-isearch-pop-state (_cmd hist-pos)
"Restore the minibuffer history search state.
Go to the history element by the absolute history position HIST-POS."
(goto-history-element hist-pos))
@@ -1798,7 +1932,7 @@ we stop and ignore all further elements."
(undo-list (list nil))
undo-adjusted-markers
some-rejected
- undo-elt undo-elt temp-undo-list delta)
+ undo-elt temp-undo-list delta)
(while undo-list-copy
(setq undo-elt (car undo-list-copy))
(let ((keep-this
@@ -2036,20 +2170,14 @@ to the end of the list of defaults just after the default value."
(defvar shell-delimiter-argument-list)
(defvar shell-file-name-chars)
(defvar shell-file-name-quote-list)
-
-(defun minibuffer-complete-shell-command ()
- "Dynamically complete shell command at point."
- (interactive)
- (require 'shell)
- (let ((comint-delimiter-argument-list shell-delimiter-argument-list)
- (comint-file-name-chars shell-file-name-chars)
- (comint-file-name-quote-list shell-file-name-quote-list))
- (run-hook-with-args-until-success 'shell-dynamic-complete-functions)))
+(defvar shell-dynamic-complete-functions)
+;; shell requires comint.
+(defvar comint-dynamic-complete-functions)
(defvar minibuffer-local-shell-command-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map minibuffer-local-map)
- (define-key map "\t" 'minibuffer-complete-shell-command)
+ (define-key map "\t" 'completion-at-point)
map)
"Keymap used for completing shell commands in minibuffer.")
@@ -2058,8 +2186,18 @@ to the end of the list of defaults just after the default value."
The arguments are the same as the ones of `read-from-minibuffer',
except READ and KEYMAP are missing and HIST defaults
to `shell-command-history'."
+ (require 'shell)
(minibuffer-with-setup-hook
(lambda ()
+ (set (make-local-variable 'comint-delimiter-argument-list)
+ shell-delimiter-argument-list)
+ (set (make-local-variable 'comint-file-name-chars) shell-file-name-chars)
+ (set (make-local-variable 'comint-file-name-quote-list)
+ shell-file-name-quote-list)
+ (set (make-local-variable 'comint-dynamic-complete-functions)
+ shell-dynamic-complete-functions)
+ (add-hook 'completion-at-point-functions
+ 'comint-completion-at-point nil 'local)
(set (make-local-variable 'minibuffer-default-add-function)
'minibuffer-default-add-shell-commands))
(apply 'read-from-minibuffer prompt initial-contents
@@ -2073,7 +2211,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 +2276,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
@@ -2215,7 +2361,11 @@ specifies the value of ERROR-BUFFER."
(error "Shell command in progress")))
(with-current-buffer buffer
(setq buffer-read-only nil)
- (erase-buffer)
+ ;; Setting buffer-read-only to nil doesn't suffice
+ ;; if some text has a non-nil read-only property,
+ ;; which comint sometimes adds for prompts.
+ (let ((inhibit-read-only t))
+ (erase-buffer))
(display-buffer buffer)
(setq default-directory directory)
(setq proc (start-process "Shell" buffer shell-file-name
@@ -2492,7 +2642,7 @@ specifies the value of ERROR-BUFFER."
(with-output-to-string
(with-current-buffer
standard-output
- (call-process shell-file-name nil t nil shell-command-switch command))))
+ (process-file shell-file-name nil t nil shell-command-switch command))))
(defun process-file (program &optional infile buffer display &rest args)
"Process files synchronously in a separate process.
@@ -2553,7 +2703,97 @@ support pty association, if PROGRAM is nil."
(let ((fh (find-file-name-handler default-directory 'start-file-process)))
(if fh (apply fh 'start-file-process name buffer program program-args)
(apply 'start-process name buffer program program-args))))
-
+
+;;;; Process menu
+
+(defvar tabulated-list-format)
+(defvar tabulated-list-entries)
+(defvar tabulated-list-sort-key)
+(declare-function tabulated-list-init-header "tabulated-list" ())
+(declare-function tabulated-list-print "tabulated-list"
+ (&optional remember-pos))
+
+(defvar process-menu-query-only nil)
+
+(define-derived-mode process-menu-mode tabulated-list-mode "Process Menu"
+ "Major mode for listing the processes called by Emacs."
+ (setq tabulated-list-format [("Process" 15 t)
+ ("Status" 7 t)
+ ("Buffer" 15 t)
+ ("TTY" 12 t)
+ ("Command" 0 t)])
+ (make-local-variable 'process-menu-query-only)
+ (setq tabulated-list-sort-key (cons "Process" nil))
+ (add-hook 'tabulated-list-revert-hook 'list-processes--refresh nil t)
+ (tabulated-list-init-header))
+
+(defun list-processes--refresh ()
+ "Recompute the list of processes for the Process List buffer."
+ (setq tabulated-list-entries nil)
+ (dolist (p (process-list))
+ (when (or (not process-menu-query-only)
+ (process-query-on-exit-flag p))
+ (let* ((buf (process-buffer p))
+ (type (process-type p))
+ (name (process-name p))
+ (status (symbol-name (process-status p)))
+ (buf-label (if (buffer-live-p buf)
+ `(,(buffer-name buf)
+ face link
+ help-echo ,(concat "Visit buffer `"
+ (buffer-name buf) "'")
+ follow-link t
+ process-buffer ,buf
+ action process-menu-visit-buffer)
+ "--"))
+ (tty (or (process-tty-name p) "--"))
+ (cmd
+ (if (memq type '(network serial))
+ (let ((contact (process-contact p t)))
+ (if (eq type 'network)
+ (format "(%s %s)"
+ (if (plist-get contact :type)
+ "datagram"
+ "network")
+ (if (plist-get contact :server)
+ (format "server on %s"
+ (plist-get contact :server))
+ (format "connection to %s"
+ (plist-get contact :host))))
+ (format "(serial port %s%s)"
+ (or (plist-get contact :port) "?")
+ (let ((speed (plist-get contact :speed)))
+ (if speed
+ (format " at %s b/s" speed)
+ "")))))
+ (mapconcat 'identity (process-command p) " "))))
+ (push (list p (vector name status buf-label tty cmd))
+ tabulated-list-entries)))))
+
+(defun process-menu-visit-buffer (button)
+ (display-buffer (button-get button 'process-buffer)))
+
+(defun list-processes (&optional query-only buffer)
+ "Display a list of all processes.
+If optional argument QUERY-ONLY is non-nil, only processes with
+the query-on-exit flag set are listed.
+Any process listed as exited or signaled is actually eliminated
+after the listing is made.
+Optional argument BUFFER specifies a buffer to use, instead of
+\"*Process List\".
+The return value is always nil."
+ (interactive)
+ (or (fboundp 'process-list)
+ (error "Asynchronous subprocesses are not supported on this system"))
+ (unless (bufferp buffer)
+ (setq buffer (get-buffer-create "*Process List*")))
+ (with-current-buffer buffer
+ (process-menu-mode)
+ (setq process-menu-query-only query-only)
+ (list-processes--refresh)
+ (tabulated-list-print))
+ (display-buffer buffer)
+ nil)
(defvar universal-argument-map
(let ((map (make-sparse-keymap)))
@@ -2691,6 +2931,15 @@ These commands include \\[set-mark-command] and \\[start-kbd-macro]."
(reset-this-command-lengths)
(restore-overriding-map))
+
+(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 +2949,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 +2990,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 +3080,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")
@@ -3212,16 +3449,16 @@ and KILLP is t if a prefix arg was specified."
(delete-char 1)))
(forward-char -1)
(setq count (1- count))))))
- (delete-backward-char
- (let ((skip (cond ((eq backward-delete-char-untabify-method 'hungry) " \t")
+ (let* ((skip (cond ((eq backward-delete-char-untabify-method 'hungry) " \t")
((eq backward-delete-char-untabify-method 'all)
- " \t\n\r"))))
- (if skip
- (let ((wh (- (point) (save-excursion (skip-chars-backward skip)
- (point)))))
- (+ arg (if (zerop wh) 0 (1- wh))))
- arg))
- killp))
+ " \t\n\r")))
+ (n (if skip
+ (let ((wh (- (point) (save-excursion (skip-chars-backward skip)
+ (point)))))
+ (+ arg (if (zerop wh) 0 (1- wh))))
+ arg)))
+ ;; Avoid warning about delete-backward-char
+ (with-no-warnings (delete-backward-char n killp))))
(defun zap-to-char (arg char)
"Kill up to and including ARGth occurrence of CHAR.
@@ -3460,18 +3697,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 +3764,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 sets the primary 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 +3803,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 +3826,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 +3909,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 +4098,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,31 +4130,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.
-
-Lisp programs may give this variable certain special values:
-
-- A value of `lambda' enables Transient Mark mode temporarily.
- It is disabled again after any subsequent action that would
- normally deactivate the mark (e.g. buffer modification).
-
-- A value of (only . OLDVAL) 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 (e.g. 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.
@@ -3936,6 +4141,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)
@@ -3999,9 +4212,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)
@@ -4029,9 +4243,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)
@@ -4117,11 +4332,6 @@ If nil, `line-move' moves point by logical lines."
;; When already vscrolled, we vscroll some more if we can,
;; or clear vscroll and move forward at end of tall image.
((> (setq vs (window-vscroll nil t)) 0)
-
- ;; If we are vscrolling an image at the top of the screen,
- ;; we could actually advance point if this yields space
- ;; below....
-
(when (> rbot 0)
(set-window-vscroll nil (+ vs (min rbot (frame-char-height))) t)))
;; If cursor just entered the bottom scroll margin, move forward,
@@ -4209,7 +4419,7 @@ If nil, `line-move' moves point by logical lines."
;; This is the guts of next-line and previous-line.
;; Arg says how many lines to move.
;; The value is t if we can move the specified number of lines.
-(defun line-move-1 (arg &optional noerror to-end)
+(defun line-move-1 (arg &optional noerror _to-end)
;; Don't run any point-motion hooks, and disregard intangibility,
;; for intermediate positions.
(let ((inhibit-point-motion-hooks t)
@@ -4345,7 +4555,7 @@ If nil, `line-move' moves point by logical lines."
(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.
@@ -4453,7 +4663,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))))))))
@@ -4476,6 +4686,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))))
@@ -4738,52 +4951,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.
@@ -4973,16 +5141,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)))
@@ -5144,7 +5308,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'
@@ -5152,14 +5316,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 ()
@@ -5258,7 +5415,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
@@ -5267,14 +5424,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
@@ -5287,13 +5439,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.
@@ -5319,6 +5465,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."
@@ -5360,21 +5526,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
@@ -5387,38 +5572,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.
@@ -5461,7 +5637,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;
@@ -5471,7 +5669,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)
@@ -5491,12 +5692,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
@@ -5580,10 +5781,6 @@ appears to have customizations applying to the old default,
:version "23.2"
:group 'mail)
-(define-mail-user-agent 'sendmail-user-agent
- 'sendmail-user-agent-compose
- 'mail-send-and-exit)
-
(defun rfc822-goto-eoh ()
"If the buffer starts with a mail header, move point to the header's end.
Otherwise, moves to `point-min'.
@@ -5594,37 +5791,9 @@ else the end of the last line. This function obeys RFC822."
"^\\([:\n]\\|[^: \t\n]+[ \t\n]\\)" nil 'move)
(goto-char (match-beginning 0))))
-(defun sendmail-user-agent-compose (&optional to subject other-headers continue
- switch-function yank-action
- send-actions)
- (if switch-function
- (let ((special-display-buffer-names nil)
- (special-display-regexps nil)
- (same-window-buffer-names nil)
- (same-window-regexps nil))
- (funcall switch-function "*mail*")))
- (let ((cc (cdr (assoc-string "cc" other-headers t)))
- (in-reply-to (cdr (assoc-string "in-reply-to" other-headers t)))
- (body (cdr (assoc-string "body" other-headers t))))
- (or (mail continue to subject in-reply-to cc yank-action send-actions)
- continue
- (error "Message aborted"))
- (save-excursion
- (rfc822-goto-eoh)
- (while other-headers
- (unless (member-ignore-case (car (car other-headers))
- '("in-reply-to" "cc" "body"))
- (insert (car (car other-headers)) ": "
- (cdr (car other-headers))
- (if use-hard-newlines hard-newline "\n")))
- (setq other-headers (cdr other-headers)))
- (when body
- (forward-line 1)
- (insert body))
- t)))
-
(defun compose-mail (&optional to subject other-headers continue
- switch-function yank-action send-actions)
+ switch-function yank-action send-actions
+ return-action)
"Start composing a mail message to send.
This uses the user's chosen mail composition package
as selected with the variable `mail-user-agent'.
@@ -5649,7 +5818,12 @@ FUNCTION to ARGS, to insert the raw text of the original message.
original text has been inserted in this way.)
SEND-ACTIONS is a list of actions to call when the message is sent.
-Each action has the form (FUNCTION . ARGS)."
+Each action has the form (FUNCTION . ARGS).
+
+RETURN-ACTION, if non-nil, is an action for returning to the
+caller. It has the form (FUNCTION . ARGS). The function is
+called after the mail has been sent or put aside, and the mail
+buffer buried."
(interactive
(list nil nil nil current-prefix-arg))
@@ -5679,25 +5853,27 @@ To disable this warning, set `compose-mail-user-agent-warnings' to nil."
warn-vars " "))))))
(let ((function (get mail-user-agent 'composefunc)))
- (funcall function to subject other-headers continue
- switch-function yank-action send-actions)))
+ (funcall function to subject other-headers continue switch-function
+ yank-action send-actions return-action)))
(defun compose-mail-other-window (&optional to subject other-headers continue
- yank-action send-actions)
+ yank-action send-actions
+ return-action)
"Like \\[compose-mail], but edit the outgoing message in another window."
- (interactive
- (list nil nil nil current-prefix-arg))
+ (interactive (list nil nil nil current-prefix-arg))
(compose-mail to subject other-headers continue
- 'switch-to-buffer-other-window yank-action send-actions))
-
+ 'switch-to-buffer-other-window yank-action send-actions
+ return-action))
(defun compose-mail-other-frame (&optional to subject other-headers continue
- yank-action send-actions)
+ yank-action send-actions
+ return-action)
"Like \\[compose-mail], but edit the outgoing message in another frame."
- (interactive
- (list nil nil nil current-prefix-arg))
+ (interactive (list nil nil nil current-prefix-arg))
(compose-mail to subject other-headers continue
- 'switch-to-buffer-other-frame yank-action send-actions))
+ 'switch-to-buffer-other-frame yank-action send-actions
+ return-action))
+
(defvar set-variable-value-history nil
"History of values entered with `set-variable'.
@@ -5786,6 +5962,7 @@ With a prefix argument, set VARIABLE to VALUE buffer-locally."
(define-key map [left] 'previous-completion)
(define-key map [right] 'next-completion)
(define-key map "q" 'quit-window)
+ (define-key map "z" 'kill-this-buffer)
map)
"Local map for completion list buffers.")
@@ -6103,27 +6280,27 @@ select the completion near point.\n\n"))))))
;; These functions -- which are not commands -- each add one modifier
;; to the following event.
-(defun event-apply-alt-modifier (ignore-prompt)
+(defun event-apply-alt-modifier (_ignore-prompt)
"\\<function-key-map>Add the Alt modifier to the following event.
For example, type \\[event-apply-alt-modifier] & to enter Alt-&."
(vector (event-apply-modifier (read-event) 'alt 22 "A-")))
-(defun event-apply-super-modifier (ignore-prompt)
+(defun event-apply-super-modifier (_ignore-prompt)
"\\<function-key-map>Add the Super modifier to the following event.
For example, type \\[event-apply-super-modifier] & to enter Super-&."
(vector (event-apply-modifier (read-event) 'super 23 "s-")))
-(defun event-apply-hyper-modifier (ignore-prompt)
+(defun event-apply-hyper-modifier (_ignore-prompt)
"\\<function-key-map>Add the Hyper modifier to the following event.
For example, type \\[event-apply-hyper-modifier] & to enter Hyper-&."
(vector (event-apply-modifier (read-event) 'hyper 24 "H-")))
-(defun event-apply-shift-modifier (ignore-prompt)
+(defun event-apply-shift-modifier (_ignore-prompt)
"\\<function-key-map>Add the Shift modifier to the following event.
For example, type \\[event-apply-shift-modifier] & to enter Shift-&."
(vector (event-apply-modifier (read-event) 'shift 25 "S-")))
-(defun event-apply-control-modifier (ignore-prompt)
+(defun event-apply-control-modifier (_ignore-prompt)
"\\<function-key-map>Add the Ctrl modifier to the following event.
For example, type \\[event-apply-control-modifier] & to enter Ctrl-&."
(vector (event-apply-modifier (read-event) 'control 26 "C-")))
-(defun event-apply-meta-modifier (ignore-prompt)
+(defun event-apply-meta-modifier (_ignore-prompt)
"\\<function-key-map>Add the Meta modifier to the following event.
For example, type \\[event-apply-meta-modifier] & to enter Meta-&."
(vector (event-apply-modifier (read-event) 'meta 27 "M-")))
@@ -6425,6 +6602,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))
@@ -6436,7 +6614,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.
@@ -6466,25 +6644,21 @@ 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)))
- (let* ((bindings
- `(([M-delete] [M-backspace])
- ([C-M-delete] [C-M-backspace])
- ([?\e C-delete] [?\e C-backspace])))
- (old-state (lookup-key local-function-key-map [delete])))
+ (let ((bindings
+ `(([M-delete] [M-backspace])
+ ([C-M-delete] [C-M-backspace])
+ ([?\e C-delete] [?\e C-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)
@@ -6508,7 +6682,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,83 +6708,25 @@ saving the value of `buffer-invisibility-spec' and setting it to nil."
buffer-invisibility-spec)
(setq buffer-invisibility-spec nil)))
-;; Partial application of functions (similar to "currying").
-;; This function is here rather than in subr.el because it uses CL.
-(defun apply-partially (fun &rest args)
- "Return a function that is a partial application of FUN to ARGS.
-ARGS is a list of the first N arguments to pass to FUN.
-The result is a new function which does the same as FUN, except that
-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.
-;(defun minibuffer-prompt-modification (start end)
-; (error "You cannot modify the prompt"))
-;
-;
-;(defun minibuffer-prompt-insertion (start end)
-; (let ((inhibit-modification-hooks t))
-; (delete-region start end)
-; ;; Discard undo information for the text insertion itself
-; ;; and for the text deletion.above.
-; (when (consp buffer-undo-list)
-; (setq buffer-undo-list (cddr buffer-undo-list)))
-; (message "You cannot modify the prompt")))
-;
-;
-;(setq minibuffer-prompt-properties
-; (list 'modification-hooks '(minibuffer-prompt-modification)
-; 'insert-in-front-hooks '(minibuffer-prompt-insertion)))
-;
+;;(defun minibuffer-prompt-modification (start end)
+;; (error "You cannot modify the prompt"))
+;;
+;;
+;;(defun minibuffer-prompt-insertion (start end)
+;; (let ((inhibit-modification-hooks t))
+;; (delete-region start end)
+;; ;; Discard undo information for the text insertion itself
+;; ;; and for the text deletion.above.
+;; (when (consp buffer-undo-list)
+;; (setq buffer-undo-list (cddr buffer-undo-list)))
+;; (message "You cannot modify the prompt")))
+;;
+;;
+;;(setq minibuffer-prompt-properties
+;; (list 'modification-hooks '(minibuffer-prompt-modification)
+;; 'insert-in-front-hooks '(minibuffer-prompt-insertion)))
;;;; Problematic external packages.
diff --git a/lisp/skeleton.el b/lisp/skeleton.el
index 59e227002d5..946e0a4480d 100644
--- a/lisp/skeleton.el
+++ b/lisp/skeleton.el
@@ -1,7 +1,6 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1996, 2001-2011 Free Software Foundation, Inc.
;; Author: Daniel Pfeiffer <occitan@esperanto.org>
;; Maintainer: FSF
@@ -108,7 +107,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 +298,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 +319,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 +346,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 +354,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 +371,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 +409,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 +575,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 1c10a7377df..8ea3decb76f 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1986-1987, 1994-1995, 2001-2011
+;; 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/soundex.el b/lisp/soundex.el
index e2b969f6b74..dbe92dc2670 100644
--- a/lisp/soundex.el
+++ b/lisp/soundex.el
@@ -1,7 +1,6 @@
;;; soundex.el --- implement Soundex algorithm
-;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2001-2011 Free Software Foundation, Inc.
;; Author: Christian Plaunt <chris@bliss.berkeley.edu>
;; Maintainer: FSF
@@ -72,5 +71,4 @@ and Searching\", Addison-Wesley (1973), pp. 391-392."
(provide 'soundex)
-;; arch-tag: b2615a98-feb7-430e-a717-171086738953
;;; soundex.el ends here
diff --git a/lisp/speedbar.el b/lisp/speedbar.el
index 31d7ff0a388..3e707ff3832 100644
--- a/lisp/speedbar.el
+++ b/lisp/speedbar.el
@@ -1,8 +1,6 @@
;;; speedbar --- quick access to files and tags in a frame
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: file, tags, tools
@@ -515,7 +513,7 @@ hierarchy would be replaced with the new directory."
:type 'hook)
(defcustom speedbar-mode-hook nil
- "Hooks called after creating a speedbar buffer."
+ "Hook run after creating a speedbar buffer."
:group 'speedbar
:type 'hook)
@@ -616,8 +614,11 @@ state data."
:group 'speedbar
:type 'hook)
-(defvar speedbar-ignored-modes '(fundamental-mode)
- "*List of major modes which speedbar will not switch directories for.")
+(defcustom speedbar-ignored-modes '(fundamental-mode)
+ "List of major modes which speedbar will not switch directories for."
+ :group 'speedbar
+ :type '(choice (const nil)
+ (repeat :tag "List of modes" (symbol :tag "Major mode"))))
(defun speedbar-extension-list-to-regex (extlist)
"Takes EXTLIST, a list of extensions and transforms it into regexp.
@@ -658,7 +659,7 @@ speedbar is loaded. You may place anything you like in this list
before speedbar has been loaded."
:group 'speedbar
:type '(repeat (regexp :tag "Directory Regexp"))
- :set (lambda (sym val)
+ :set (lambda (_sym val)
(setq speedbar-ignored-directory-expressions val
speedbar-ignored-directory-regexp
(speedbar-extension-list-to-regex val))))
@@ -671,7 +672,7 @@ directories here; see `vc-directory-exclusion-list'."
:group 'speedbar
:type 'string)
-(defvar speedbar-file-unshown-regexp
+(defcustom speedbar-file-unshown-regexp
(let ((nstr "") (noext completion-ignored-extensions))
(while noext
(setq nstr (concat nstr (regexp-quote (car noext)) "\\'"
@@ -679,8 +680,10 @@ directories here; see `vc-directory-exclusion-list'."
noext (cdr noext)))
;; backup refdir lockfile
(concat nstr "\\|#[^#]+#$\\|\\.\\.?\\'\\|\\.#"))
- "*Regexp matching files we don't want displayed in a speedbar buffer.
-It is generated from the variable `completion-ignored-extensions'.")
+ "Regexp matching files we don't want displayed in a speedbar buffer.
+It is generated from the variable `completion-ignored-extensions'."
+ :group 'speedbar
+ :type 'string)
(defvar speedbar-file-regexp nil
"Regular expression matching files we know how to expand.
@@ -710,7 +713,7 @@ need to also modify `completion-ignored-extension' which will also help
file completion."
:group 'speedbar
:type '(repeat (regexp :tag "Extension Regexp"))
- :set (lambda (sym val)
+ :set (lambda (_sym val)
(set 'speedbar-supported-extension-expressions val)
(set 'speedbar-file-regexp (speedbar-extension-list-to-regex val))))
@@ -757,111 +760,110 @@ DIRECTORY-EXPRESSION to `speedbar-ignored-directory-expressions'."
speedbar-ignored-directory-regexp (speedbar-extension-list-to-regex
speedbar-ignored-directory-expressions)))
-(defvar speedbar-update-flag dframe-have-timer-flag
- "*Non-nil means to automatically update the display.
+(defcustom speedbar-update-flag dframe-have-timer-flag
+ "Non-nil means to automatically update the display.
When this is nil then speedbar will not follow the attached frame's directory.
-When speedbar is active, use:
-
-\\<speedbar-key-map> `\\[speedbar-toggle-updates]'
-
-to toggle this value.")
+If you want to change this while speedbar is active, either use
+\\[customize] or call \\<speedbar-key-map> `\\[speedbar-toggle-updates]'."
+ :group 'speedbar
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (set sym val)
+ (speedbar-toggle-updates))
+ :type 'boolean)
(defvar speedbar-update-flag-disable nil
"Permanently disable changing of the update flag.")
-(defvar speedbar-syntax-table nil
+(defvar speedbar-mode-syntax-table
+ (let ((st (make-syntax-table)))
+ ;; Turn off paren matching around here.
+ (modify-syntax-entry ?\' " " st)
+ (modify-syntax-entry ?\" " " st)
+ (modify-syntax-entry ?\( " " st)
+ (modify-syntax-entry ?\) " " st)
+ (modify-syntax-entry ?\{ " " st)
+ (modify-syntax-entry ?\} " " st)
+ (modify-syntax-entry ?\[ " " st)
+ (modify-syntax-entry ?\] " " st)
+ st)
"Syntax-table used on the speedbar.")
-
-(if speedbar-syntax-table
- nil
- (setq speedbar-syntax-table (make-syntax-table))
- ;; turn off paren matching around here.
- (modify-syntax-entry ?\' " " speedbar-syntax-table)
- (modify-syntax-entry ?\" " " speedbar-syntax-table)
- (modify-syntax-entry ?( " " speedbar-syntax-table)
- (modify-syntax-entry ?) " " speedbar-syntax-table)
- (modify-syntax-entry ?{ " " speedbar-syntax-table)
- (modify-syntax-entry ?} " " speedbar-syntax-table)
- (modify-syntax-entry ?[ " " speedbar-syntax-table)
- (modify-syntax-entry ?] " " speedbar-syntax-table))
-
-(defvar speedbar-key-map nil
+(define-obsolete-variable-alias
+ 'speedbar-syntax-table 'speedbar-mode-syntax-table "24.1")
+
+
+(defvar speedbar-mode-map
+ (let ((map (make-keymap)))
+ (suppress-keymap map t)
+
+ ;; Control.
+ (define-key map "t" 'speedbar-toggle-updates)
+ (define-key map "g" 'speedbar-refresh)
+
+ ;; Navigation.
+ (define-key map "n" 'speedbar-next)
+ (define-key map "p" 'speedbar-prev)
+ (define-key map "\M-n" 'speedbar-restricted-next)
+ (define-key map "\M-p" 'speedbar-restricted-prev)
+ (define-key map "\C-\M-n" 'speedbar-forward-list)
+ (define-key map "\C-\M-p" 'speedbar-backward-list)
+ ;; These commands never seemed useful.
+ ;; (define-key map " " 'speedbar-scroll-up)
+ ;; (define-key map [delete] 'speedbar-scroll-down)
+
+ ;; Short cuts I happen to find useful.
+ (define-key map "r"
+ (lambda () (interactive)
+ (speedbar-change-initial-expansion-list
+ speedbar-previously-used-expansion-list-name)))
+ (define-key map "b"
+ (lambda () (interactive)
+ (speedbar-change-initial-expansion-list "quick buffers")))
+ (define-key map "f"
+ (lambda () (interactive)
+ (speedbar-change-initial-expansion-list "files")))
+
+ (dframe-update-keymap map)
+ map)
"Keymap used in speedbar buffer.")
-
-(if speedbar-key-map
- nil
- (setq speedbar-key-map (make-keymap))
- (suppress-keymap speedbar-key-map t)
-
- ;; control
- (define-key speedbar-key-map "t" 'speedbar-toggle-updates)
- (define-key speedbar-key-map "g" 'speedbar-refresh)
-
- ;; navigation
- (define-key speedbar-key-map "n" 'speedbar-next)
- (define-key speedbar-key-map "p" 'speedbar-prev)
- (define-key speedbar-key-map "\M-n" 'speedbar-restricted-next)
- (define-key speedbar-key-map "\M-p" 'speedbar-restricted-prev)
- (define-key speedbar-key-map "\C-\M-n" 'speedbar-forward-list)
- (define-key speedbar-key-map "\C-\M-p" 'speedbar-backward-list)
-;; These commands never seemed useful.
-;; (define-key speedbar-key-map " " 'speedbar-scroll-up)
-;; (define-key speedbar-key-map [delete] 'speedbar-scroll-down)
-
- ;; Short cuts I happen to find useful
- (define-key speedbar-key-map "r"
- (lambda () (interactive)
- (speedbar-change-initial-expansion-list
- speedbar-previously-used-expansion-list-name)))
- (define-key speedbar-key-map "b"
- (lambda () (interactive)
- (speedbar-change-initial-expansion-list "quick buffers")))
- (define-key speedbar-key-map "f"
- (lambda () (interactive)
- (speedbar-change-initial-expansion-list "files")))
-
- (dframe-update-keymap speedbar-key-map)
-)
+(define-obsolete-variable-alias 'speedbar-key-map 'speedbar-mode-map "24.1")
(defun speedbar-make-specialized-keymap ()
"Create a keymap for use with a speedbar major or minor display mode.
This basically creates a sparse keymap, and makes its parent be
-`speedbar-key-map'."
+`speedbar-mode-map'."
(let ((k (make-sparse-keymap)))
- (set-keymap-parent k speedbar-key-map)
+ (set-keymap-parent k speedbar-mode-map)
k))
-(defvar speedbar-file-key-map nil
+(defvar speedbar-file-key-map
+ (let ((map (speedbar-make-specialized-keymap)))
+
+ ;; Basic tree features.
+ (define-key map "e" 'speedbar-edit-line)
+ (define-key map "\C-m" 'speedbar-edit-line)
+ (define-key map "+" 'speedbar-expand-line)
+ (define-key map "=" 'speedbar-expand-line)
+ (define-key map "-" 'speedbar-contract-line)
+
+ (define-key map "[" 'speedbar-expand-line-descendants)
+ (define-key map "]" 'speedbar-contract-line-descendants)
+
+ (define-key map " " 'speedbar-toggle-line-expansion)
+
+ ;; File based commands.
+ (define-key map "U" 'speedbar-up-directory)
+ (define-key map "I" 'speedbar-item-info)
+ (define-key map "B" 'speedbar-item-byte-compile)
+ (define-key map "L" 'speedbar-item-load)
+ (define-key map "C" 'speedbar-item-copy)
+ (define-key map "D" 'speedbar-item-delete)
+ (define-key map "O" 'speedbar-item-object-delete)
+ (define-key map "R" 'speedbar-item-rename)
+ (define-key map "M" 'speedbar-create-directory)
+ map)
"Keymap used in speedbar buffer while files are displayed.")
-(if speedbar-file-key-map
- nil
- (setq speedbar-file-key-map (speedbar-make-specialized-keymap))
-
- ;; Basic tree features
- (define-key speedbar-file-key-map "e" 'speedbar-edit-line)
- (define-key speedbar-file-key-map "\C-m" 'speedbar-edit-line)
- (define-key speedbar-file-key-map "+" 'speedbar-expand-line)
- (define-key speedbar-file-key-map "=" 'speedbar-expand-line)
- (define-key speedbar-file-key-map "-" 'speedbar-contract-line)
-
- (define-key speedbar-file-key-map "[" 'speedbar-expand-line-descendants)
- (define-key speedbar-file-key-map "]" 'speedbar-contract-line-descendants)
-
- (define-key speedbar-file-key-map " " 'speedbar-toggle-line-expansion)
-
- ;; file based commands
- (define-key speedbar-file-key-map "U" 'speedbar-up-directory)
- (define-key speedbar-file-key-map "I" 'speedbar-item-info)
- (define-key speedbar-file-key-map "B" 'speedbar-item-byte-compile)
- (define-key speedbar-file-key-map "L" 'speedbar-item-load)
- (define-key speedbar-file-key-map "C" 'speedbar-item-copy)
- (define-key speedbar-file-key-map "D" 'speedbar-item-delete)
- (define-key speedbar-file-key-map "O" 'speedbar-item-object-delete)
- (define-key speedbar-file-key-map "R" 'speedbar-item-rename)
- (define-key speedbar-file-key-map "M" 'speedbar-create-directory)
- )
-
(defvar speedbar-easymenu-definition-base
(append
'("Speedbar"
@@ -1080,7 +1082,7 @@ selected. If the speedbar frame is active, then select the attached frame."
Return nil if it doesn't exist."
(frame-width speedbar-frame))
-(defun speedbar-mode ()
+(define-derived-mode speedbar-mode fundamental-mode "Speedbar"
"Major mode for managing a display of directories and tags.
\\<speedbar-key-map>
The first line represents the default directory of the speedbar frame.
@@ -1120,12 +1122,7 @@ tags start with >. Click the name of the tag to go to that position
in the selected file.
\\{speedbar-key-map}"
- ;; NOT interactive
(save-excursion
- (kill-all-local-variables)
- (setq major-mode 'speedbar-mode)
- (setq mode-name "Speedbar")
- (set-syntax-table speedbar-syntax-table)
(setq font-lock-keywords nil) ;; no font-locking please
(setq truncate-lines t)
(make-local-variable 'frame-title-format)
@@ -1138,8 +1135,7 @@ in the selected file.
(setq dframe-track-mouse-function #'speedbar-track-mouse))
(setq dframe-help-echo-function #'speedbar-item-info
dframe-mouse-click-function #'speedbar-click
- dframe-mouse-position-function #'speedbar-position-cursor-on-line)
- (run-hooks 'speedbar-mode-hook))
+ dframe-mouse-position-function #'speedbar-position-cursor-on-line))
speedbar-buffer)
(defmacro speedbar-message (fmt &rest args)
@@ -1472,7 +1468,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 +1494,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 +1512,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))
@@ -1628,7 +1622,7 @@ Files can be renamed to new names or moved to new directories."
(let ((f (speedbar-line-file)))
(if f
(let* ((basedir (file-name-directory f))
- (nd (read-file-name "Create directory: "
+ (nd (read-directory-name "Create directory: "
basedir)))
;; Make the directory
(make-directory nd t)
@@ -1645,8 +1639,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)
@@ -1928,7 +1922,7 @@ the file-system."
nl))
))
-(defun speedbar-directory-buttons (directory index)
+(defun speedbar-directory-buttons (directory _index)
"Insert a single button group at point for DIRECTORY.
Each directory part is a different button. If part of the directory
matches the user directory ~, then it is replaced with a ~.
@@ -2061,8 +2055,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 +2844,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 +2942,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 +3014,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 +3235,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 +3253,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 +3270,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 +3282,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))))
@@ -3326,7 +3313,7 @@ Optional argument ARG indicates that any cache should be flushed."
;; hidden by default anyway. Yay! It's easy.
)
-(defun speedbar-find-file (text token indent)
+(defun speedbar-find-file (text _token indent)
"Speedbar click handler for filenames.
TEXT, the file will be displayed in the attached frame.
TOKEN is unused, but required by the click handler. INDENT is the
@@ -3346,7 +3333,7 @@ current indentation level."
(speedbar-set-timer dframe-update-speed))
(dframe-maybee-jump-to-attached-frame))
-(defun speedbar-dir-follow (text token indent)
+(defun speedbar-dir-follow (text _token indent)
"Speedbar click handler for directory names.
Clicking a directory will cause the speedbar to list files in
the subdirectory TEXT. TOKEN is an unused requirement. The
@@ -3414,7 +3401,7 @@ expanded. INDENT is the current indentation level."
(speedbar-center-buffer-smartly)
(save-excursion (speedbar-stealthy-updates)))
-(defun speedbar-directory-buttons-follow (text token indent)
+(defun speedbar-directory-buttons-follow (_text token _indent)
"Speedbar click handler for default directory buttons.
TEXT is the button clicked on. TOKEN is the directory to follow.
INDENT is the current indentation level and is unused."
@@ -3435,7 +3422,6 @@ indentation level."
(cond ((string-match "+" text) ;we have to expand this file
(let* ((fn (expand-file-name (concat (speedbar-line-directory indent)
token)))
- (mode nil)
(lst (speedbar-fetch-dynamic-tags fn)))
;; if no list, then remove expando button
(if (not lst)
@@ -3451,7 +3437,7 @@ indentation level."
(t (error "Ooops... not sure what to do")))
(speedbar-center-buffer-smartly))
-(defun speedbar-tag-find (text token indent)
+(defun speedbar-tag-find (_text token indent)
"For the tag TEXT in a file TOKEN, go to that position.
INDENT is the current indentation level."
(let ((file (speedbar-line-directory indent)))
@@ -3664,17 +3650,20 @@ to be at the beginning of a line in the etags buffer.
This variable is ignored if `speedbar-use-imenu-flag' is non-nil.")
-(defvar speedbar-fetch-etags-command "etags"
- "*Command used to create an etags file.
-
-This variable is ignored if `speedbar-use-imenu-flag' is t.")
+(defcustom speedbar-fetch-etags-command "etags"
+ "Command used to create an etags file.
+This variable is ignored if `speedbar-use-imenu-flag' is t."
+ :group 'speedbar
+ :type 'string)
-(defvar speedbar-fetch-etags-arguments '("-D" "-I" "-o" "-")
- "*List of arguments to use with `speedbar-fetch-etags-command'.
+(defcustom speedbar-fetch-etags-arguments '("-D" "-I" "-o" "-")
+ "List of arguments to use with `speedbar-fetch-etags-command'.
This creates an etags output buffer. Use `speedbar-toggle-etags' to
modify this list conveniently.
-
-This variable is ignored if `speedbar-use-imenu-flag' is t.")
+This variable is ignored if `speedbar-use-imenu-flag' is t."
+ :group 'speedbar
+ :type '(choice (const nil)
+ (repeat :tag "List of arguments" string)))
(defun speedbar-toggle-etags (flag)
"Toggle FLAG in `speedbar-fetch-etags-arguments'.
@@ -3763,17 +3752,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 +3770,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 +3786,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)))
@@ -3853,12 +3837,12 @@ regular expression EXPR."
)
"Menu item elements shown when displaying a buffer list.")
-(defun speedbar-buffer-buttons (directory zero)
+(defun speedbar-buffer-buttons (_directory _zero)
"Create speedbar buttons based on the buffers currently loaded.
DIRECTORY is the directory of the currently active buffer, and ZERO is 0."
(speedbar-buffer-buttons-engine nil))
-(defun speedbar-buffer-buttons-temp (directory zero)
+(defun speedbar-buffer-buttons-temp (_directory _zero)
"Create speedbar buttons based on the buffers currently loaded.
DIRECTORY is the directory of the currently active buffer, and ZERO is 0."
(speedbar-buffer-buttons-engine t))
@@ -3916,11 +3900,8 @@ If TEMP is non-nil, then clicking on a buffer restores the previous display."
(defun speedbar-buffers-tail-notes (buffer)
"Add a note to the end of the last tag line.
Argument BUFFER is the buffer being tested."
- (let (mod ro)
- (with-current-buffer buffer
- (setq mod (buffer-modified-p)
- ro buffer-read-only))
- (if ro (speedbar-insert-button "%" nil nil nil nil t))))
+ (when (with-current-buffer buffer buffer-read-only)
+ (speedbar-insert-button "%" nil nil nil nil t)))
(defun speedbar-buffers-item-info ()
"Display information about the current buffer on the current line."
@@ -3935,7 +3916,7 @@ Argument BUFFER is the buffer being tested."
(with-current-buffer buffer (buffer-size))
(or (buffer-file-name buffer) "<No file>"))))))
-(defun speedbar-buffers-line-directory (&optional depth)
+(defun speedbar-buffers-line-directory (&optional _depth)
"Fetch the directory of the file (buffer) specified on the current line.
Optional argument DEPTH specifies the current depth of the back search."
(save-excursion
@@ -3947,14 +3928,12 @@ 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))))))))
-(defun speedbar-buffer-click (text token indent)
+(defun speedbar-buffer-click (text token _indent)
"When the users clicks on a buffer-button in speedbar.
TEXT is the buffer's name, TOKEN and INDENT are unused."
(if dframe-power-click
@@ -3981,14 +3960,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 +3979,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 471b688fbff..14f4c7829d1 100644
--- a/lisp/startup.el
+++ b/lisp/startup.el
@@ -1,11 +1,10 @@
-;;; startup.el --- process Emacs shell arguments
+;;; startup.el --- process Emacs shell arguments -*- lexical-binding: t -*-
-;; Copyright (C) 1985, 1986, 1992, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
-;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1985-1986, 1992, 1994-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -99,6 +98,7 @@ the remaining command-line args are in the variable `command-line-args-left'.")
"List of command-line args not yet processed.")
(defvaralias 'argv 'command-line-args-left
+ ;; FIXME: Bad name for a dynamically bound variable.
"List of command-line args not yet processed.
This is a convenience alias, so that one can write \(pop argv\)
inside of --eval command line arguments in order to access
@@ -199,47 +199,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)
@@ -327,7 +327,7 @@ this variable usefully is to set it while building and dumping Emacs."
:type '(choice (const :tag "none" nil) string)
:group 'initialization
:initialize 'custom-initialize-default
- :set (lambda (variable value)
+ :set (lambda (_variable _value)
(error "Customizing `site-run-file' does not work")))
(defcustom mail-host-address nil
@@ -393,6 +393,15 @@ Warning Warning!!! Pure space overflow !!!Warning Warning
:type 'directory
:initialize 'custom-initialize-delay)
+(defconst package-subdirectory-regexp
+ "\\([^.].*?\\)-\\([0-9]+\\(?:[.][0-9]+\\|\\(?:pre\\|beta\\|alpha\\)[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.
+
+The regexp should not contain a starting \"\\`\" or a trailing
+ \"\\'\"; those are added automatically by callers.")
+
(defun normal-top-level-add-subdirs-to-load-path ()
"Add all subdirectories of current directory to `load-path'.
More precisely, this uses only the subdirectories whose names
@@ -410,34 +419,31 @@ or `CVS', and any subdirectory that contains a file named `.nosearch'."
(default-directory this-dir)
(canonicalized (if (fboundp 'untranslated-canonical-name)
(untranslated-canonical-name this-dir))))
- ;; The Windows version doesn't report meaningful inode
- ;; numbers, so use the canonicalized absolute file name of the
- ;; directory instead.
+ ;; The Windows version doesn't report meaningful inode numbers, so
+ ;; use the canonicalized absolute file name of the directory instead.
(setq attrs (or canonicalized
(nthcdr 10 (file-attributes this-dir))))
(unless (member attrs normal-top-level-add-subdirs-inode-list)
(push attrs normal-top-level-add-subdirs-inode-list)
(dolist (file contents)
- ;; The lower-case variants of RCS and CVS are for DOS/Windows.
- (unless (member file '("." ".." "RCS" "CVS" "rcs" "cvs"))
- (when (and (string-match "\\`[[:alnum:]]" file)
- ;; Avoid doing a `stat' when it isn't necessary
- ;; because that can cause trouble when an NFS server
- ;; is down.
- (not (string-match "\\.elc?\\'" file))
- (file-directory-p file))
- (let ((expanded (expand-file-name file)))
- (unless (file-exists-p (expand-file-name ".nosearch"
- expanded))
- (setq pending (nconc pending (list expanded)))))))))))
+ (and (string-match "\\`[[:alnum:]]" file)
+ ;; The lower-case variants of RCS and CVS are for DOS/Windows.
+ (not (member file '("RCS" "CVS" "rcs" "cvs")))
+ ;; Avoid doing a `stat' when it isn't necessary because
+ ;; that can cause trouble when an NFS server is down.
+ (not (string-match "\\.elc?\\'" file))
+ (file-directory-p file)
+ (let ((expanded (expand-file-name file)))
+ (or (file-exists-p (expand-file-name ".nosearch" expanded))
+ (setq pending (nconc pending (list expanded))))))))))
(normal-top-level-add-to-load-path (cdr (nreverse dirs)))))
-;; This function is called from a subdirs.el file.
-;; It assumes that default-directory is the directory
-;; in which the subdirs.el file exists,
-;; and it adds to load-path the subdirs of that directory
-;; as specified in DIRS. Normally the elements of DIRS are relative.
(defun normal-top-level-add-to-load-path (dirs)
+ "This function is called from a subdirs.el file.
+It assumes that `default-directory' is the directory in which the
+subdirs.el file exists, and it adds to `load-path' the subdirs of
+that directory as specified in DIRS. Normally the elements of
+DIRS are relative."
(let ((tail load-path)
(thisdir (directory-file-name default-directory)))
(while (and tail
@@ -465,9 +471,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,
@@ -617,8 +620,8 @@ function to this list. The function should take no arguments,
and initialize the window system environment to prepare for
opening the first frame (e.g. open a connection to an X server).")
-;; Handle the X-like command-line arguments "-fg", "-bg", "-name", etc.
(defun tty-handle-args (args)
+ "Handle the X-like command-line arguments \"-fg\", \"-bg\", \"-name\", etc."
(let (rest)
(message "%S" args)
(while (and args
@@ -785,15 +788,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 +882,41 @@ 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
+ (put 'cursor 'theme-face
+ `((changed ((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 +926,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
@@ -1001,19 +1017,22 @@ opening the first frame (e.g. open a connection to an X server).")
(if init-file-user
(let ((user-init-file-1
(cond
- ((eq system-type 'ms-dos)
- (concat "~" init-file-user "/_emacs"))
- ((eq system-type 'windows-nt)
- ;; Prefer .emacs on Windows.
- (if (directory-files "~" nil "^\\.emacs\\(\\.elc?\\)?$")
- "~/.emacs"
- ;; Also support _emacs for compatibility.
- (if (directory-files "~" nil "^_emacs\\(\\.elc?\\)?$")
- "~/_emacs"
- ;; But default to .emacs if _emacs does not exist.
- "~/.emacs")))
- (t
- (concat "~" init-file-user "/.emacs")))))
+ ((eq system-type 'ms-dos)
+ (concat "~" init-file-user "/_emacs"))
+ ((not (eq system-type 'windows-nt))
+ (concat "~" init-file-user "/.emacs"))
+ ;; Else deal with the Windows situation
+ ((directory-files "~" nil "^\\.emacs\\(\\.elc?\\)?$")
+ ;; Prefer .emacs on Windows.
+ "~/.emacs")
+ ((directory-files "~" nil "^_emacs\\(\\.elc?\\)?$")
+ ;; Also support _emacs for compatibility, but warn about it.
+ (push '(initialization
+ "`_emacs' init file is deprecated, please use `.emacs'")
+ delayed-warnings-list)
+ "~/_emacs")
+ (t ;; But default to .emacs if _emacs does not exist.
+ "~/.emacs"))))
;; This tells `load' to store the file name found
;; into user-init-file.
(setq user-init-file t)
@@ -1077,7 +1096,8 @@ the `--debug-init' option to view a complete error backtrace."
user-init-file
(get (car error) 'error-message)
(if (cdr error) ": " "")
- (mapconcat (lambda (s) (prin1-to-string s t)) (cdr error) ", "))
+ (mapconcat (lambda (s) (prin1-to-string s t))
+ (cdr error) ", "))
:warning)
(setq init-file-had-error t))))
@@ -1166,6 +1186,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))
+ (string-match
+ (concat "\\`" package-subdirectory-regexp "\\'")
+ subdir))
+ (throw 'package-dir-found t)))))))
+ (package-initialize))
+
(setq after-init-time (current-time))
(run-hooks 'after-init-hook)
@@ -1248,25 +1293,25 @@ If this is nil, no message will be displayed."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defconst fancy-startup-text
- '((:face (variable-pitch (:foreground "red"))
+ `((:face (variable-pitch (:foreground "red"))
"Welcome to "
:link ("GNU Emacs"
- (lambda (button) (browse-url "http://www.gnu.org/software/emacs/"))
+ ,(lambda (_button) (browse-url "http://www.gnu.org/software/emacs/"))
"Browse http://www.gnu.org/software/emacs/")
", one component of the "
:link
- (lambda ()
+ ,(lambda ()
(if (eq system-type 'gnu/linux)
- '("GNU/Linux"
- (lambda (button) (browse-url "http://www.gnu.org/gnu/linux-and-gnu.html"))
+ `("GNU/Linux"
+ ,(lambda (_button) (browse-url "http://www.gnu.org/gnu/linux-and-gnu.html"))
"Browse http://www.gnu.org/gnu/linux-and-gnu.html")
- '("GNU" (lambda (button) (describe-gnu-project))
+ `("GNU" ,(lambda (_button) (describe-gnu-project))
"Display info on the GNU project")))
" operating system.\n\n"
:face variable-pitch
- :link ("Emacs Tutorial" (lambda (button) (help-with-tutorial)))
+ :link ("Emacs Tutorial" ,(lambda (_button) (help-with-tutorial)))
"\tLearn basic keystroke commands"
- (lambda ()
+ ,(lambda ()
(let* ((en "TUTORIAL")
(tut (or (get-language-info current-language-environment
'tutorial)
@@ -1284,19 +1329,20 @@ If this is nil, no message will be displayed."
(concat " (" title ")"))))
"\n"
:link ("Emacs Guided Tour"
- (lambda (button) (browse-url "http://www.gnu.org/software/emacs/tour/"))
+ ,(lambda (_button)
+ (browse-url "http://www.gnu.org/software/emacs/tour/"))
"Browse http://www.gnu.org/software/emacs/tour/")
"\tOverview of Emacs features at gnu.org\n"
- :link ("View Emacs Manual" (lambda (button) (info-emacs-manual)))
+ :link ("View Emacs Manual" ,(lambda (_button) (info-emacs-manual)))
"\tView the Emacs manual using Info\n"
- :link ("Absence of Warranty" (lambda (button) (describe-no-warranty)))
+ :link ("Absence of Warranty" ,(lambda (_button) (describe-no-warranty)))
"\tGNU Emacs comes with "
:face (variable-pitch (:slant oblique))
"ABSOLUTELY NO WARRANTY\n"
:face variable-pitch
- :link ("Copying Conditions" (lambda (button) (describe-copying)))
+ :link ("Copying Conditions" ,(lambda (_button) (describe-copying)))
"\tConditions for redistributing and changing Emacs\n"
- :link ("Ordering Manuals" (lambda (button) (view-order-manuals)))
+ :link ("Ordering Manuals" ,(lambda (_button) (view-order-manuals)))
"\tPurchasing printed copies of manuals\n"
"\n"))
"A list of texts to show in the middle part of splash screens.
@@ -1304,61 +1350,62 @@ Each element in the list should be a list of strings or pairs
`:face FACE', like `fancy-splash-insert' accepts them.")
(defconst fancy-about-text
- '((:face (variable-pitch (:foreground "red"))
+ `((:face (variable-pitch (:foreground "red"))
"This is "
:link ("GNU Emacs"
- (lambda (button) (browse-url "http://www.gnu.org/software/emacs/"))
+ ,(lambda (_button) (browse-url "http://www.gnu.org/software/emacs/"))
"Browse http://www.gnu.org/software/emacs/")
", one component of the "
:link
- (lambda ()
+ ,(lambda ()
(if (eq system-type 'gnu/linux)
- '("GNU/Linux"
- (lambda (button) (browse-url "http://www.gnu.org/gnu/linux-and-gnu.html"))
+ `("GNU/Linux"
+ ,(lambda (_button)
+ (browse-url "http://www.gnu.org/gnu/linux-and-gnu.html"))
"Browse http://www.gnu.org/gnu/linux-and-gnu.html")
- '("GNU" (lambda (button) (describe-gnu-project))
+ `("GNU" ,(lambda (_button) (describe-gnu-project))
"Display info on the GNU project.")))
" operating system.\n"
- :face (lambda ()
+ :face ,(lambda ()
(list 'variable-pitch
(list :foreground
(if (eq (frame-parameter nil 'background-mode) 'dark)
"cyan" "darkblue"))))
"\n"
- (lambda () (emacs-version))
+ ,(lambda () (emacs-version))
"\n"
:face (variable-pitch (:height 0.8))
- (lambda () emacs-copyright)
+ ,(lambda () emacs-copyright)
"\n\n"
:face variable-pitch
:link ("Authors"
- (lambda (button)
+ ,(lambda (_button)
(view-file (expand-file-name "AUTHORS" data-directory))
(goto-char (point-min))))
"\tMany people have contributed code included in GNU Emacs\n"
:link ("Contributing"
- (lambda (button)
+ ,(lambda (_button)
(view-file (expand-file-name "CONTRIBUTE" data-directory))
(goto-char (point-min))))
"\tHow to contribute improvements to Emacs\n"
"\n"
- :link ("GNU and Freedom" (lambda (button) (describe-gnu-project)))
+ :link ("GNU and Freedom" ,(lambda (_button) (describe-gnu-project)))
"\tWhy we developed GNU Emacs, and the GNU operating system\n"
- :link ("Absence of Warranty" (lambda (button) (describe-no-warranty)))
+ :link ("Absence of Warranty" ,(lambda (_button) (describe-no-warranty)))
"\tGNU Emacs comes with "
:face (variable-pitch (:slant oblique))
"ABSOLUTELY NO WARRANTY\n"
:face variable-pitch
- :link ("Copying Conditions" (lambda (button) (describe-copying)))
+ :link ("Copying Conditions" ,(lambda (_button) (describe-copying)))
"\tConditions for redistributing and changing Emacs\n"
- :link ("Getting New Versions" (lambda (button) (describe-distribution)))
+ :link ("Getting New Versions" ,(lambda (_button) (describe-distribution)))
"\tHow to obtain the latest version of Emacs\n"
- :link ("Ordering Manuals" (lambda (button) (view-order-manuals)))
+ :link ("Ordering Manuals" ,(lambda (_button) (view-order-manuals)))
"\tBuying printed manuals from the FSF\n"
"\n"
- :link ("Emacs Tutorial" (lambda (button) (help-with-tutorial)))
+ :link ("Emacs Tutorial" ,(lambda (_button) (help-with-tutorial)))
"\tLearn basic Emacs keystroke commands"
- (lambda ()
+ ,(lambda ()
(let* ((en "TUTORIAL")
(tut (or (get-language-info current-language-environment
'tutorial)
@@ -1376,7 +1423,8 @@ Each element in the list should be a list of strings or pairs
(concat " (" title ")"))))
"\n"
:link ("Emacs Guided Tour"
- (lambda (button) (browse-url "http://www.gnu.org/software/emacs/tour/"))
+ ,(lambda (_button)
+ (browse-url "http://www.gnu.org/software/emacs/tour/"))
"Browse http://www.gnu.org/software/emacs/tour/")
"\tSee an overview of Emacs features at gnu.org"
))
@@ -1483,7 +1531,7 @@ a face or button specification."
(make-button (prog1 (point) (insert-image img)) (point)
'face 'default
'help-echo "mouse-2, RET: Browse http://www.gnu.org/"
- 'action (lambda (button) (browse-url "http://www.gnu.org/"))
+ 'action (lambda (_button) (browse-url "http://www.gnu.org/"))
'follow-link t)
(insert "\n\n")))))
@@ -1495,16 +1543,16 @@ a face or button specification."
(fancy-splash-insert
:face 'variable-pitch
"\nTo start... "
- :link '("Open a File"
- (lambda (button) (call-interactively 'find-file))
+ :link `("Open a File"
+ ,(lambda (_button) (call-interactively 'find-file))
"Specify a new file's name, to edit the file")
" "
- :link '("Open Home Directory"
- (lambda (button) (dired "~"))
+ :link `("Open Home Directory"
+ ,(lambda (_button) (dired "~"))
"Open your home directory, to operate on its files")
" "
- :link '("Customize Startup"
- (lambda (button) (customize-group 'initialization))
+ :link `("Customize Startup"
+ ,(lambda (_button) (customize-group 'initialization))
"Change initialization settings including this screen")
"\n"))
(fancy-splash-insert
@@ -1543,33 +1591,36 @@ a face or button specification."
(when concise
(fancy-splash-insert
:face 'variable-pitch "\n"
- :link '("Dismiss this startup screen"
- (lambda (button)
- (when startup-screen-inhibit-startup-screen
- (customize-set-variable 'inhibit-startup-screen t)
- (customize-mark-to-save 'inhibit-startup-screen)
- (custom-save-all))
- (let ((w (get-buffer-window "*GNU Emacs*")))
- (and w (not (one-window-p)) (delete-window w)))
- (kill-buffer "*GNU Emacs*")))
+ :link `("Dismiss this startup screen"
+ ,(lambda (_button)
+ (when startup-screen-inhibit-startup-screen
+ (customize-set-variable 'inhibit-startup-screen t)
+ (customize-mark-to-save 'inhibit-startup-screen)
+ (custom-save-all))
+ (let ((w (get-buffer-window "*GNU Emacs*")))
+ (and w (not (one-window-p)) (delete-window w)))
+ (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.")))))
@@ -1763,37 +1814,37 @@ To quit a partially entered command, type Control-g.\n")
(insert "\nImportant Help menu items:\n")
(insert-button "Emacs Tutorial"
- 'action (lambda (button) (help-with-tutorial))
+ 'action (lambda (_button) (help-with-tutorial))
'follow-link t)
(insert "\t\tLearn basic Emacs keystroke commands\n")
(insert-button "Read the Emacs Manual"
- 'action (lambda (button) (info-emacs-manual))
+ 'action (lambda (_button) (info-emacs-manual))
'follow-link t)
(insert "\tView the Emacs manual using Info\n")
(insert-button "\(Non)Warranty"
- 'action (lambda (button) (describe-no-warranty))
+ 'action (lambda (_button) (describe-no-warranty))
'follow-link t)
(insert "\t\tGNU Emacs comes with ABSOLUTELY NO WARRANTY\n")
(insert-button "Copying Conditions"
- 'action (lambda (button) (describe-copying))
+ 'action (lambda (_button) (describe-copying))
'follow-link t)
(insert "\tConditions for redistributing and changing Emacs\n")
(insert-button "More Manuals / Ordering Manuals"
- 'action (lambda (button) (view-order-manuals))
+ 'action (lambda (_button) (view-order-manuals))
'follow-link t)
(insert " How to order printed manuals from the FSF\n")
(insert "\nUseful tasks:\n")
(insert-button "Visit New File"
- 'action (lambda (button) (call-interactively 'find-file))
+ 'action (lambda (_button) (call-interactively 'find-file))
'follow-link t)
(insert "\t\tSpecify a new file's name, to edit the file\n")
(insert-button "Open Home Directory"
- 'action (lambda (button) (dired "~"))
+ 'action (lambda (_button) (dired "~"))
'follow-link t)
(insert "\tOpen your home directory, to operate on its files\n")
(insert-button "Customize Startup"
- 'action (lambda (button) (customize-group 'initialization))
+ 'action (lambda (_button) (customize-group 'initialization))
'follow-link t)
(insert "\tChange initialization settings including this screen\n")
@@ -1827,20 +1878,20 @@ To quit a partially entered command, type Control-g.\n")
(where (key-description where))
(t "M-x help")))))
(insert-button "Emacs manual"
- 'action (lambda (button) (info-emacs-manual))
+ 'action (lambda (_button) (info-emacs-manual))
'follow-link t)
(insert (substitute-command-keys"\t \\[info-emacs-manual]\t"))
(insert-button "Browse manuals"
- 'action (lambda (button) (Info-directory))
+ 'action (lambda (_button) (Info-directory))
'follow-link t)
(insert (substitute-command-keys "\t \\[info]\n"))
(insert-button "Emacs tutorial"
- 'action (lambda (button) (help-with-tutorial))
+ 'action (lambda (_button) (help-with-tutorial))
'follow-link t)
(insert (substitute-command-keys
"\t \\[help-with-tutorial]\tUndo changes\t \\[undo]\n"))
(insert-button "Buy manuals"
- 'action (lambda (button) (view-order-manuals))
+ 'action (lambda (_button) (view-order-manuals))
'follow-link t)
(insert (substitute-command-keys
"\t \\[view-order-manuals]\tExit Emacs\t \\[save-buffers-kill-terminal]")))
@@ -1848,7 +1899,7 @@ To quit a partially entered command, type Control-g.\n")
;; Say how to use the menu bar with the keyboard.
(insert "\n")
(insert-button "Activate menubar"
- 'action (lambda (button) (tmm-menubar))
+ 'action (lambda (_button) (tmm-menubar))
'follow-link t)
(if (and (eq (key-binding "\M-`") 'tmm-menubar)
(eq (key-binding [f10]) 'tmm-menubar))
@@ -1864,21 +1915,21 @@ If you have no Meta key, you may instead type ESC followed by the character.)")
(insert "\nUseful tasks:\n")
(insert-button "Visit New File"
- 'action (lambda (button) (call-interactively 'find-file))
+ 'action (lambda (_button) (call-interactively 'find-file))
'follow-link t)
(insert "\t\t\t")
(insert-button "Open Home Directory"
- 'action (lambda (button) (dired "~"))
+ 'action (lambda (_button) (dired "~"))
'follow-link t)
(insert "\n")
(insert-button "Customize Startup"
- 'action (lambda (button) (customize-group 'initialization))
+ 'action (lambda (_button) (customize-group 'initialization))
'follow-link t)
(insert "\t\t")
(insert-button "Open *scratch* buffer"
- 'action (lambda (button) (switch-to-buffer
- (get-buffer-create "*scratch*")))
+ 'action (lambda (_button) (switch-to-buffer
+ (get-buffer-create "*scratch*")))
'follow-link t)
(insert "\n")
(insert "\n" (emacs-version) "\n" emacs-copyright "\n")
@@ -1891,36 +1942,36 @@ If you have no Meta key, you may instead type ESC followed by the character.)")
"
GNU Emacs comes with ABSOLUTELY NO WARRANTY; type C-h C-w for ")
(insert-button "full details"
- 'action (lambda (button) (describe-no-warranty))
+ 'action (lambda (_button) (describe-no-warranty))
'follow-link t)
(insert ".
Emacs is Free Software--Free as in Freedom--so you can redistribute copies
of Emacs and modify it; type C-h C-c to see ")
(insert-button "the conditions"
- 'action (lambda (button) (describe-copying))
+ 'action (lambda (_button) (describe-copying))
'follow-link t)
(insert ".
Type C-h C-d for information on ")
(insert-button "getting the latest version"
- 'action (lambda (button) (describe-distribution))
+ 'action (lambda (_button) (describe-distribution))
'follow-link t)
(insert "."))
(insert (substitute-command-keys
"
GNU Emacs comes with ABSOLUTELY NO WARRANTY; type \\[describe-no-warranty] for "))
(insert-button "full details"
- 'action (lambda (button) (describe-no-warranty))
+ 'action (lambda (_button) (describe-no-warranty))
'follow-link t)
(insert (substitute-command-keys ".
Emacs is Free Software--Free as in Freedom--so you can redistribute copies
of Emacs and modify it; type \\[describe-copying] to see "))
(insert-button "the conditions"
- 'action (lambda (button) (describe-copying))
+ 'action (lambda (_button) (describe-copying))
'follow-link t)
(insert (substitute-command-keys".
Type \\[describe-distribution] for information on "))
(insert-button "getting the latest version"
- 'action (lambda (button) (describe-distribution))
+ 'action (lambda (_button) (describe-distribution))
'follow-link t)
(insert ".")))
@@ -1931,7 +1982,7 @@ Type \\[describe-distribution] for information on "))
(insert-button "Authors"
'action
- (lambda (button)
+ (lambda (_button)
(view-file (expand-file-name "AUTHORS" data-directory))
(goto-char (point-min)))
'follow-link t)
@@ -1939,34 +1990,34 @@ Type \\[describe-distribution] for information on "))
(insert-button "Contributing"
'action
- (lambda (button)
+ (lambda (_button)
(view-file (expand-file-name "CONTRIBUTE" data-directory))
(goto-char (point-min)))
'follow-link t)
(insert "\tHow to contribute improvements to Emacs\n\n")
(insert-button "GNU and Freedom"
- 'action (lambda (button) (describe-gnu-project))
+ 'action (lambda (_button) (describe-gnu-project))
'follow-link t)
(insert "\t\tWhy we developed GNU Emacs and the GNU system\n")
(insert-button "Absence of Warranty"
- 'action (lambda (button) (describe-no-warranty))
+ 'action (lambda (_button) (describe-no-warranty))
'follow-link t)
(insert "\tGNU Emacs comes with ABSOLUTELY NO WARRANTY\n")
(insert-button "Copying Conditions"
- 'action (lambda (button) (describe-copying))
+ 'action (lambda (_button) (describe-copying))
'follow-link t)
(insert "\tConditions for redistributing and changing Emacs\n")
(insert-button "Getting New Versions"
- 'action (lambda (button) (describe-distribution))
+ 'action (lambda (_button) (describe-distribution))
'follow-link t)
(insert "\tHow to get the latest version of GNU Emacs\n")
(insert-button "More Manuals / Ordering Manuals"
- 'action (lambda (button) (view-order-manuals))
+ 'action (lambda (_button) (view-order-manuals))
'follow-link t)
(insert "\tBuying printed manuals from the FSF\n"))
@@ -1982,7 +2033,7 @@ Type \\[describe-distribution] for information on "))
(defun display-startup-echo-area-message ()
(let ((resize-mini-windows t))
- (or noninteractive ;(input-pending-p) init-file-had-error
+ (or noninteractive ;(input-pending-p) init-file-had-error
;; t if the init file says to inhibit the echo area startup message.
(and inhibit-startup-echo-area-message
user-init-file
@@ -1992,24 +2043,21 @@ Type \\[describe-distribution] for information on "))
(user-login-name)
init-file-user)))
;; Wasn't set with custom; see if .emacs has a setq.
- (let ((buffer (get-buffer-create " *temp*")))
- (prog1
- (condition-case nil
- (with-current-buffer buffer
- (insert-file-contents user-init-file)
- (re-search-forward
- (concat
- "([ \t\n]*setq[ \t\n]+"
- "inhibit-startup-echo-area-message[ \t\n]+"
- (regexp-quote
- (prin1-to-string
- (if (equal init-file-user "")
- (user-login-name)
- init-file-user)))
- "[ \t\n]*)")
- nil t))
- (error nil))
- (kill-buffer buffer)))))
+ (condition-case nil
+ (with-temp-buffer
+ (insert-file-contents user-init-file)
+ (re-search-forward
+ (concat
+ "([ \t\n]*setq[ \t\n]+"
+ "inhibit-startup-echo-area-message[ \t\n]+"
+ (regexp-quote
+ (prin1-to-string
+ (if (equal init-file-user "")
+ (user-login-name)
+ init-file-user)))
+ "[ \t\n]*)")
+ nil t))
+ (error nil))))
(message "%s" (startup-echo-area-message)))))
(defun display-startup-screen (&optional concise)
@@ -2035,7 +2083,7 @@ A fancy display is used on graphic displays, normal otherwise."
(defalias 'about-emacs 'display-about-screen)
(defalias 'display-splash-screen 'display-startup-screen)
-(defun command-line-1 (command-line-args-left)
+(defun command-line-1 (args-left)
(display-startup-echo-area-message)
(when (and pure-space-overflow
(not noninteractive))
@@ -2046,14 +2094,12 @@ A fancy display is used on graphic displays, normal otherwise."
:warning))
(let ((file-count 0)
+ (command-line-args-left args-left)
first-file-buffer)
(when command-line-args-left
;; We have command args; process them.
- ;; Note that any local variables in this function affect the
- ;; ability of -f batch-byte-compile to detect free variables.
- ;; So we give some of them with common names a cl1- prefix.
- (let ((cl1-dir command-line-default-directory)
- cl1-tem
+ (let ((dir command-line-default-directory)
+ tem
;; This approach loses for "-batch -L DIR --eval "(require foo)",
;; if foo is intended to be found in DIR.
;;
@@ -2076,8 +2122,8 @@ A fancy display is used on graphic displays, normal otherwise."
"--find-file" "--visit" "--file" "--no-desktop")
(mapcar (lambda (elt) (concat "-" (car elt)))
command-switch-alist)))
- (cl1-line 0)
- (cl1-column 0))
+ (line 0)
+ (column 0))
;; Add the long X options to longopts.
(dolist (tem command-line-x-option-alist)
@@ -2118,12 +2164,12 @@ A fancy display is used on graphic displays, normal otherwise."
argi orig-argi)))))
;; Execute the option.
- (cond ((setq cl1-tem (assoc argi command-switch-alist))
+ (cond ((setq tem (assoc argi command-switch-alist))
(if argval
(let ((command-line-args-left
(cons argval command-line-args-left)))
- (funcall (cdr cl1-tem) argi))
- (funcall (cdr cl1-tem) argi)))
+ (funcall (cdr tem) argi))
+ (funcall (cdr tem) argi)))
((equal argi "-no-splash")
(setq inhibit-startup-screen t))
@@ -2132,22 +2178,22 @@ A fancy display is used on graphic displays, normal otherwise."
"-funcall"
"-e")) ; what the source used to say
(setq inhibit-startup-screen t)
- (setq cl1-tem (intern (or argval (pop command-line-args-left))))
- (if (commandp cl1-tem)
- (command-execute cl1-tem)
- (funcall cl1-tem)))
+ (setq tem (intern (or argval (pop command-line-args-left))))
+ (if (commandp tem)
+ (command-execute tem)
+ (funcall tem)))
((member argi '("-eval" "-execute"))
(setq inhibit-startup-screen t)
(eval (read (or argval (pop command-line-args-left)))))
((member argi '("-L" "-directory"))
- (setq cl1-tem (expand-file-name
+ (setq tem (expand-file-name
(command-line-normalize-file-name
(or argval (pop command-line-args-left)))))
- (cond (splice (setcdr splice (cons cl1-tem (cdr splice)))
+ (cond (splice (setcdr splice (cons tem (cdr splice)))
(setq splice (cdr splice)))
- (t (setq load-path (cons cl1-tem load-path)
+ (t (setq load-path (cons tem load-path)
splice load-path))))
((member argi '("-l" "-load"))
@@ -2171,10 +2217,10 @@ A fancy display is used on graphic displays, normal otherwise."
((equal argi "-insert")
(setq inhibit-startup-screen t)
- (setq cl1-tem (or argval (pop command-line-args-left)))
- (or (stringp cl1-tem)
+ (setq tem (or argval (pop command-line-args-left)))
+ (or (stringp tem)
(error "File name omitted from `-insert' option"))
- (insert-file-contents (command-line-normalize-file-name cl1-tem)))
+ (insert-file-contents (command-line-normalize-file-name tem)))
((equal argi "-kill")
(kill-emacs t))
@@ -2187,42 +2233,47 @@ A fancy display is used on graphic displays, normal otherwise."
(message "\"--no-desktop\" ignored because the Desktop package is not loaded"))
((string-match "^\\+[0-9]+\\'" argi)
- (setq cl1-line (string-to-number argi)))
+ (setq line (string-to-number argi)))
((string-match "^\\+\\([0-9]+\\):\\([0-9]+\\)\\'" argi)
- (setq cl1-line (string-to-number (match-string 1 argi))
- cl1-column (string-to-number (match-string 2 argi))))
+ (setq line (string-to-number (match-string 1 argi))
+ column (string-to-number (match-string 2 argi))))
- ((setq cl1-tem (assoc orig-argi command-line-x-option-alist))
+ ((setq tem (assoc orig-argi command-line-x-option-alist))
;; Ignore X-windows options and their args if not using X.
(setq command-line-args-left
- (nthcdr (nth 1 cl1-tem) command-line-args-left)))
+ (nthcdr (nth 1 tem) command-line-args-left)))
- ((setq cl1-tem (assoc orig-argi command-line-ns-option-alist))
+ ((setq tem (assoc orig-argi command-line-ns-option-alist))
;; Ignore NS-windows options and their args if not using NS.
(setq command-line-args-left
- (nthcdr (nth 1 cl1-tem) command-line-args-left)))
+ (nthcdr (nth 1 tem) command-line-args-left)))
((member argi '("-find-file" "-file" "-visit"))
(setq inhibit-startup-screen t)
;; An explicit option to specify visiting a file.
- (setq cl1-tem (or argval (pop command-line-args-left)))
- (unless (stringp cl1-tem)
+ (setq tem (or argval (pop command-line-args-left)))
+ (unless (stringp tem)
(error "File name omitted from `%s' option" argi))
(setq file-count (1+ file-count))
(let ((file (expand-file-name
- (command-line-normalize-file-name cl1-tem)
- cl1-dir)))
+ (command-line-normalize-file-name tem)
+ dir)))
(if (= file-count 1)
(setq first-file-buffer (find-file file))
(find-file-other-window file)))
- (unless (zerop cl1-line)
+ (unless (zerop line)
(goto-char (point-min))
- (forward-line (1- cl1-line)))
- (setq cl1-line 0)
- (unless (< cl1-column 1)
- (move-to-column (1- cl1-column)))
- (setq cl1-column 0))
+ (forward-line (1- line)))
+ (setq line 0)
+ (unless (< column 1)
+ (move-to-column (1- column)))
+ (setq 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))
@@ -2245,19 +2296,19 @@ A fancy display is used on graphic displays, normal otherwise."
(let ((file
(expand-file-name
(command-line-normalize-file-name orig-argi)
- cl1-dir)))
+ dir)))
(cond ((= file-count 1)
(setq first-file-buffer (find-file file)))
(inhibit-startup-screen
(find-file-other-window file))
(t (find-file file))))
- (unless (zerop cl1-line)
+ (unless (zerop line)
(goto-char (point-min))
- (forward-line (1- cl1-line)))
- (setq cl1-line 0)
- (unless (< cl1-column 1)
- (move-to-column (1- cl1-column)))
- (setq cl1-column 0))))))
+ (forward-line (1- line)))
+ (setq line 0)
+ (unless (< column 1)
+ (move-to-column (1- column)))
+ (setq column 0))))))
;; In unusual circumstances, the execution of Lisp code due
;; to command-line options can cause the last visible frame
;; to be deleted. In this case, kill emacs to avoid an
@@ -2342,5 +2393,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/strokes.el b/lisp/strokes.el
index 4742954b20c..ca0086b3b97 100644
--- a/lisp/strokes.el
+++ b/lisp/strokes.el
@@ -1,7 +1,6 @@
;;; strokes.el --- control Emacs through mouse strokes
-;; Copyright (C) 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2000-2011 Free Software Foundation, Inc.
;; Author: David Bakhash <cadet@alum.mit.edu>
;; Maintainer: FSF
@@ -719,6 +718,14 @@ Returns the corresponding match as (COMMAND . SCORE)."
nil))
nil))
+(defsubst strokes-fill-current-buffer-with-whitespace ()
+ "Erase the contents of the current buffer and fill it with whitespace."
+ (erase-buffer)
+ (loop repeat (frame-height) do
+ (insert-char ?\s (1- (frame-width)))
+ (newline))
+ (goto-char (point-min)))
+
;;;###autoload
(defun strokes-read-stroke (&optional prompt event)
"Read a simple stroke (interactively) and return the stroke.
@@ -736,6 +743,11 @@ Optional EVENT is acceptable as the starting event of the stroke."
;; display the stroke as it's being read
(save-window-excursion
(set-window-configuration strokes-window-configuration)
+ ;; The frame has been resized, so we need to refill the
+ ;; strokes buffer so that the strokes canvas is the whole
+ ;; visible buffer.
+ (unless (> 1 (abs (- (line-end-position) (window-width))))
+ (strokes-fill-current-buffer-with-whitespace))
(when prompt
(message "%s" prompt)
(setq event (read-event))
@@ -1000,7 +1012,7 @@ If you'd like to create graphical files with strokes, you'll have to
be running a version of Emacs with XPM support. You use the binding
to `strokes-compose-complex-stroke' to start drawing your strokes.
These are just complex strokes, and thus continue drawing with mouse-1
-or mouse-2 and end with mouse-3. Then the stroke image gets inserted
+or mouse-2 and end with mouse-3. Then the stroke image gets inserted
into the buffer. You treat it somewhat like any other character,
which you can copy, paste, delete, move, etc. When all is done, you
may want to send the file, or save it. This is done with
@@ -1030,15 +1042,7 @@ o Strokes are a bit computer-dependent in that they depend somewhat on
(help-mode)
(help-print-return-message)))
-(defalias 'strokes-report-bug 'report-emacs-bug)
-
-(defsubst strokes-fill-current-buffer-with-whitespace ()
- "Erase the contents of the current buffer and fill it with whitespace."
- (erase-buffer)
- (loop repeat (frame-height) do
- (insert-char ?\s (1- (frame-width)))
- (newline))
- (goto-char (point-min)))
+(define-obsolete-function-alias 'strokes-report-bug 'report-emacs-bug "24.1")
(defun strokes-window-configuration-changed-p ()
"Non-nil if the `strokes-window-configuration' frame properties changed.
@@ -1627,7 +1631,7 @@ Optional FORCE non-nil will ignore the buffer's read-only status."
(let ((inhibit-read-only t))
(message "Strokifying %s..." buffer)
(goto-char (point-min))
- (let (ext string image)
+ (let (string image)
;; The comment below is what I'd have to do if I wanted to
;; deal with random newlines in the midst of the compressed
;; strings. If I do this, I'll also have to change
@@ -1749,5 +1753,4 @@ Store XPM in buffer BUFNAME if supplied \(default is ` *strokes-xpm*'\)"
(run-hooks 'strokes-load-hook)
(provide 'strokes)
-;; arch-tag: 8377f60e-43fb-467a-bbcd-2774f91f833e
;;; strokes.el ends here
diff --git a/lisp/subr.el b/lisp/subr.el
index 391510c4acb..7f0066548a4 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -1,11 +1,11 @@
;;; 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, 2011
+;; Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2011
;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -59,7 +59,7 @@ function-definitions that `check-declare' does not recognize, e.g.
`defstruct'.
To specify a value for FILEONLY without passing an argument list,
-set ARGLIST to `t'. This is necessary because `nil' means an
+set ARGLIST to t. This is necessary because nil means an
empty argument list, rather than an unspecified one.
Note that for the purposes of `check-declare', this statement
@@ -116,6 +116,17 @@ BODY should be a list of Lisp expressions.
;; depend on backquote.el.
(list 'function (cons 'lambda cdr)))
+;; Partial application of functions (similar to "currying").
+;; This function is here rather than in subr.el because it uses CL.
+(defun apply-partially (fun &rest args)
+ "Return a function that is a partial application of FUN to ARGS.
+ARGS is a list of the first N arguments to pass to FUN.
+The result is a new function which does the same as FUN, except that
+the first N arguments are fixed at the values with which this function
+was called."
+ `(closure (t) (&rest args)
+ (apply ',fun ,@(mapcar (lambda (arg) `',arg) args) args)))
+
(if (null (featurep 'cl))
(progn
;; If we reload subr.el after having loaded CL, be careful not to
@@ -163,8 +174,6 @@ value of last one, or nil if there are none.
;; If we reload subr.el after having loaded CL, be careful not to
;; overwrite CL's extended definition of `dolist', `dotimes',
;; `declare', `push' and `pop'.
-(defvar --dolist-tail-- nil
- "Temporary variable used in `dolist' expansion.")
(defmacro dolist (spec &rest body)
"Loop over a list.
@@ -176,18 +185,29 @@ Then evaluate RESULT to get return value, default nil.
;; It would be cleaner to create an uninterned symbol,
;; but that uses a lot more space when many functions in many files
;; use dolist.
+ ;; FIXME: This cost disappears in byte-compiled lexical-binding files.
(let ((temp '--dolist-tail--))
- `(let ((,temp ,(nth 1 spec))
- ,(car spec))
- (while ,temp
- (setq ,(car spec) (car ,temp))
- ,@body
- (setq ,temp (cdr ,temp)))
- ,@(if (cdr (cdr spec))
- `((setq ,(car spec) nil) ,@(cdr (cdr spec)))))))
-
-(defvar --dotimes-limit-- nil
- "Temporary variable used in `dotimes' expansion.")
+ ;; This is not a reliable test, but it does not matter because both
+ ;; semantics are acceptable, tho one is slightly faster with dynamic
+ ;; scoping and the other is slightly faster (and has cleaner semantics)
+ ;; with lexical scoping.
+ (if lexical-binding
+ `(let ((,temp ,(nth 1 spec)))
+ (while ,temp
+ (let ((,(car spec) (car ,temp)))
+ ,@body
+ (setq ,temp (cdr ,temp))))
+ ,@(if (cdr (cdr spec))
+ ;; FIXME: This let often leads to "unused var" warnings.
+ `((let ((,(car spec) nil)) ,@(cdr (cdr spec))))))
+ `(let ((,temp ,(nth 1 spec))
+ ,(car spec))
+ (while ,temp
+ (setq ,(car spec) (car ,temp))
+ ,@body
+ (setq ,temp (cdr ,temp)))
+ ,@(if (cdr (cdr spec))
+ `((setq ,(car spec) nil) ,@(cdr (cdr spec))))))))
(defmacro dotimes (spec &rest body)
"Loop a certain number of times.
@@ -200,17 +220,32 @@ the return value (nil if RESULT is omitted).
;; It would be cleaner to create an uninterned symbol,
;; but that uses a lot more space when many functions in many files
;; use dotimes.
+ ;; FIXME: This cost disappears in byte-compiled lexical-binding files.
(let ((temp '--dotimes-limit--)
(start 0)
(end (nth 1 spec)))
- `(let ((,temp ,end)
- (,(car spec) ,start))
- (while (< ,(car spec) ,temp)
- ,@body
- (setq ,(car spec) (1+ ,(car spec))))
- ,@(cdr (cdr spec)))))
-
-(defmacro declare (&rest specs)
+ ;; This is not a reliable test, but it does not matter because both
+ ;; semantics are acceptable, tho one is slightly faster with dynamic
+ ;; scoping and the other has cleaner semantics.
+ (if lexical-binding
+ (let ((counter '--dotimes-counter--))
+ `(let ((,temp ,end)
+ (,counter ,start))
+ (while (< ,counter ,temp)
+ (let ((,(car spec) ,counter))
+ ,@body)
+ (setq ,counter (1+ ,counter)))
+ ,@(if (cddr spec)
+ ;; FIXME: This let often leads to "unused var" warnings.
+ `((let ((,(car spec) ,counter)) ,@(cddr spec))))))
+ `(let ((,temp ,end)
+ (,(car spec) ,start))
+ (while (< ,(car spec) ,temp)
+ ,@body
+ (setq ,(car spec) (1+ ,(car spec))))
+ ,@(cdr (cdr spec))))))
+
+(defmacro declare (&rest _specs)
"Do not evaluate any arguments and return nil.
Treated as a declaration when used at the right place in a
`defmacro' form. \(See Info anchor `(elisp)Definition of declare'.)"
@@ -225,7 +260,7 @@ Otherwise, return result of last form in BODY."
;;;; Basic Lisp functions.
-(defun ignore (&rest ignore)
+(defun ignore (&rest _ignore)
"Do nothing and return nil.
This function accepts any number of arguments, but ignores them."
(interactive)
@@ -249,20 +284,6 @@ Any list whose car is `frame-configuration' is assumed to be a frame
configuration."
(and (consp object)
(eq (car object) 'frame-configuration)))
-
-(defun functionp (object)
- "Non-nil if OBJECT is a function."
- (or (and (symbolp object) (fboundp object)
- (condition-case nil
- (setq object (indirect-function object))
- (error nil))
- (eq (car-safe object) 'autoload)
- (not (car-safe (cdr-safe (cdr-safe (cdr-safe (cdr-safe object)))))))
- (and (subrp object)
- ;; Filter out special forms.
- (not (eq 'unevalled (cdr (subr-arity object)))))
- (byte-code-function-p object)
- (eq (car-safe object) 'lambda)))
;;;; List functions.
@@ -288,14 +309,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."
@@ -485,6 +503,7 @@ saving keyboard macros (see `edmacro-mode')."
(read-kbd-macro keys))
(defun undefined ()
+ "Beep to tell the user this binding is undefined."
(interactive)
(ding))
@@ -1035,7 +1054,6 @@ be a list of the form returned by `event-start' and `event-end'."
(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)
@@ -1076,7 +1094,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")
@@ -1105,13 +1122,14 @@ is converted into a string by expressing it in decimal."
(make-obsolete-variable 'define-key-rebound-commands nil "23.2")
(make-obsolete-variable 'redisplay-end-trigger-functions 'jit-lock-register "23.1")
+(make-obsolete-variable 'deferred-action-list 'post-command-hook "24.1")
+(make-obsolete-variable 'deferred-action-function 'post-command-hook "24.1")
(make-obsolete 'window-redisplay-end-trigger nil "23.1")
(make-obsolete 'set-window-redisplay-end-trigger nil "23.1")
(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."
@@ -1178,37 +1196,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.
@@ -1292,6 +1279,67 @@ the hook's buffer-local value rather than its default value."
(kill-local-variable hook)
(set hook hook-value))))))
+(defmacro letrec (binders &rest body)
+ "Bind variables according to BINDERS then eval BODY.
+The value of the last form in BODY is returned.
+Each element of BINDERS is a list (SYMBOL VALUEFORM) which binds
+SYMBOL to the value of VALUEFORM.
+All symbols are bound before the VALUEFORMs are evalled."
+ ;; Only useful in lexical-binding mode.
+ ;; As a special-form, we could implement it more efficiently (and cleanly,
+ ;; making the vars actually unbound during evaluation of the binders).
+ (declare (debug let) (indent 1))
+ `(let ,(mapcar #'car binders)
+ ,@(mapcar (lambda (binder) `(setq ,@binder)) binders)
+ ,@body))
+
+(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"))
+ (runrestofhook (make-symbol "runrestofhook")))
+ ;; 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.
+ `(letrec ((,runrestofhook
+ (lambda (,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).
+ (if (consp ,funs)
+ (if (eq t (car ,funs))
+ (funcall ,runrestofhook
+ (append ,global (cdr ,funs)) nil ,argssym)
+ (apply (car ,funs)
+ (apply-partially
+ (lambda (,funs ,global &rest ,argssym)
+ (funcall ,runrestofhook ,funs ,global ,argssym))
+ (cdr ,funs) ,global)
+ ,argssym))
+ ;; Once there are no more functions on the hook, run
+ ;; the original body.
+ (apply (lambda ,args ,@body) ,argssym)))))
+ (funcall ,runrestofhook ,var
+ ;; The global part of the hook, if any.
+ ,(if (symbolp var)
+ `(if (local-variable-p ',var)
+ (default-value ',var)))
+ (list ,@args)))))
+
(defun add-to-list (list-var element &optional append compare-fn)
"Add ELEMENT to the value of LIST-VAR if it isn't there yet.
The test for presence of ELEMENT is done with `equal',
@@ -1498,8 +1546,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
@@ -1528,31 +1575,10 @@ 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
-;; (defvar symbol-file-load-history-loaded nil
-;; "Non-nil means we have loaded the file `fns-VERSION.el' in `exec-directory'.
-;; That file records the part of `load-history' for preloaded files,
-;; which is cleared out before dumping to make Emacs smaller.")
-
-;; (defun load-symbol-file-load-history ()
-;; "Load the file `fns-VERSION.el' in `exec-directory' if not already done.
-;; That file records the part of `load-history' for preloaded files,
-;; which is cleared out before dumping to make Emacs smaller."
-;; (unless symbol-file-load-history-loaded
-;; (load (expand-file-name
-;; ;; fns-XX.YY.ZZ.el does not work on DOS filesystem.
-;; (if (eq system-type 'ms-dos)
-;; "fns.el"
-;; (format "fns-%s.el" emacs-version))
-;; exec-directory)
-;; ;; The file name fns-%s.el already has a .el extension.
-;; nil nil t)
-;; (setq symbol-file-load-history-loaded t)))
-
(defun symbol-file (symbol &optional type)
"Return the name of the file that defined SYMBOL.
The value is normally an absolute file name. It can also be nil,
@@ -1647,6 +1673,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.
@@ -1669,11 +1696,7 @@ extension for a compressed format \(e.g. \".gz\") on FILE will not affect
this name matching.
Alternatively, FILE can be a feature (i.e. a symbol), in which case FORM
-is evaluated whenever that feature is `provide'd. Note that although
-provide statements are usually at the end of files, this is not always
-the case (e.g., sometimes they are at the start to avoid a recursive
-load error). If your FORM should not be evaluated until the code in
-FILE has been, do not use the symbol form for FILE in such cases.
+is evaluated at the end of any file that `provide's this feature.
Usually FILE is just a library name like \"font-lock\" or a feature name
like 'font-lock.
@@ -1682,11 +1705,29 @@ This function makes or adds to an entry on `after-load-alist'."
;; Add this FORM into after-load-alist (regardless of whether we'll be
;; evaluating it now).
(let* ((regexp-or-feature
- (if (stringp file) (setq file (purecopy (load-history-regexp file))) file))
+ (if (stringp file)
+ (setq file (purecopy (load-history-regexp file)))
+ file))
(elt (assoc regexp-or-feature after-load-alist)))
(unless elt
(setq elt (list regexp-or-feature))
(push elt after-load-alist))
+ ;; Make sure `form' is evalled in the current lexical/dynamic code.
+ (setq form `(funcall ',(eval `(lambda () ,form) lexical-binding)))
+ (when (symbolp regexp-or-feature)
+ ;; For features, the after-load-alist elements get run when `provide' is
+ ;; called rather than at the end of the file. So add an indirection to
+ ;; make sure that `form' is really run "after-load" in case the provide
+ ;; call happens early.
+ (setq form
+ `(when load-file-name
+ (let ((fun (make-symbol "eval-after-load-helper")))
+ (fset fun `(lambda (file)
+ (if (not (equal file ',load-file-name))
+ nil
+ (remove-hook 'after-load-functions ',fun)
+ ,',form)))
+ (add-hook 'after-load-functions fun)))))
;; Add FORM to the element unless it's already there.
(unless (member form (cdr elt))
(nconc elt (purecopy (list form))))
@@ -1731,6 +1772,19 @@ This makes or adds to an entry on `after-load-alist'.
FILE should be the name of a library, with no directory name."
(eval-after-load file (read)))
(make-obsolete 'eval-next-after-load `eval-after-load "23.2")
+
+(defun display-delayed-warnings ()
+ "Display delayed warnings from `delayed-warnings-list'.
+This is the default value of `delayed-warnings-hook'."
+ (dolist (warning (nreverse delayed-warnings-list))
+ (apply 'display-warning warning))
+ (setq delayed-warnings-list nil))
+
+(defvar delayed-warnings-hook '(display-delayed-warnings)
+ "Normal hook run to process delayed warnings.
+Functions in this hook should access the `delayed-warnings-list'
+variable (which see) and remove from it the warnings they process.")
+
;;;; Process stuff.
@@ -1751,35 +1805,13 @@ Signal an error if the program returns with a non-zero exit status."
(forward-line 1))
(nreverse lines)))))
-;; open-network-stream is a wrapper around make-network-process.
-
-(when (featurep 'make-network-process)
- (defun open-network-stream (name buffer host service)
- "Open a TCP connection for a service to a host.
-Returns a subprocess-object to represent the connection.
-Input and output work as for subprocesses; `delete-process' closes it.
-
-NAME is the name for the 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. BUFFER may
- be nil, meaning that this process is not associated with any buffer.
-HOST is the name or IP address of the host to connect to.
-SERVICE is the name of the service desired, or an integer specifying
- a port number to connect to.
-
-This is a wrapper around `make-network-process', and only offers a
-subset of its functionality."
- (make-network-process :name name :buffer buffer
- :host host :service service)))
-
;; compatibility
(make-obsolete
'process-kill-without-query
"use `process-query-on-exit-flag' or `set-process-query-on-exit-flag'."
"22.1")
-(defun process-kill-without-query (process &optional flag)
+(defun process-kill-without-query (process &optional _flag)
"Say no query needed if PROCESS is running when Emacs is exited.
Optional second argument if non-nil says to require a query.
Value is t if a query was formerly required."
@@ -1942,7 +1974,7 @@ This function echoes `.' for each character that the user types.
The user ends with RET, LFD, or ESC. DEL or C-h rubs out.
C-y yanks the current kill. C-u kills line.
C-g quits; if `inhibit-quit' was non-nil around this function,
-then it returns nil if the user types C-g, but quit-flag remains set.
+then it returns nil if the user types C-g, but `quit-flag' remains set.
Once the caller uses the password, it can erase the password
by doing (clear-string STRING)."
@@ -2040,6 +2072,35 @@ The value of DEFAULT is inserted into PROMPT."
t)))
n))
+(defun read-char-choice (prompt chars &optional inhibit-keyboard-quit)
+ "Read and return one of CHARS, prompting for PROMPT.
+Any input that is not one of CHARS is ignored.
+
+If optional argument INHIBIT-KEYBOARD-QUIT is non-nil, ignore
+keyboard-quit events while waiting for a valid input."
+ (unless (consp chars)
+ (error "Called `read-char-choice' without valid char choices"))
+ (let (char done)
+ (let ((cursor-in-echo-area t)
+ (executing-kbd-macro executing-kbd-macro))
+ (while (not done)
+ (unless (get-text-property 0 'face prompt)
+ (setq prompt (propertize prompt 'face 'minibuffer-prompt)))
+ (setq char (let ((inhibit-quit inhibit-keyboard-quit))
+ (read-key prompt)))
+ (cond
+ ((not (numberp char)))
+ ((memq char chars)
+ (setq done t))
+ ((and executing-kbd-macro (= char -1))
+ ;; read-event returns -1 if we are in a kbd macro and
+ ;; there are no more events in the macro. Attempt to
+ ;; get an event interactively.
+ (setq executing-kbd-macro nil)))))
+ ;; Display the question with the answer. But without cursor-in-echo-area.
+ (message "%s%s" prompt (char-to-string char))
+ char))
+
(defun sit-for (seconds &optional nodisp obsolete)
"Perform redisplay, then wait for SECONDS seconds or until input is available.
SECONDS may be a floating-point value.
@@ -2081,6 +2142,56 @@ floating point support."
(push read unread-command-events)
nil))))))
(set-advertised-calling-convention 'sit-for '(seconds &optional nodisp) "22.1")
+
+(defun y-or-n-p (prompt)
+ "Ask user a \"y or n\" question. Return t if answer is \"y\".
+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)))
+
;;; Atomic change groups.
@@ -2407,27 +2518,63 @@ Note: :data and :device are currently not supported on Windows."
(defun shell-quote-argument (argument)
"Quote ARGUMENT for passing as argument to an inferior shell."
- (if (or (eq system-type 'ms-dos)
- (and (eq system-type 'windows-nt) (w32-shell-dos-semantics)))
- ;; Quote using double quotes, but escape any existing quotes in
- ;; the argument with backslashes.
- (let ((result "")
- (start 0)
- end)
- (if (or (null (string-match "[^\"]" argument))
- (< (match-end 0) (length argument)))
- (while (string-match "[\"]" argument start)
- (setq end (match-beginning 0)
- result (concat result (substring argument start end)
- "\\" (substring argument end (1+ end)))
- start (1+ end))))
- (concat "\"" result (substring argument start) "\""))
+ (cond
+ ((eq system-type 'ms-dos)
+ ;; Quote using double quotes, but escape any existing quotes in
+ ;; the argument with backslashes.
+ (let ((result "")
+ (start 0)
+ end)
+ (if (or (null (string-match "[^\"]" argument))
+ (< (match-end 0) (length argument)))
+ (while (string-match "[\"]" argument start)
+ (setq end (match-beginning 0)
+ result (concat result (substring argument start end)
+ "\\" (substring argument end (1+ end)))
+ start (1+ end))))
+ (concat "\"" result (substring argument start) "\"")))
+
+ ((and (eq system-type 'windows-nt) (w32-shell-dos-semantics))
+
+ ;; First, quote argument so that CommandLineToArgvW will
+ ;; understand it. See
+ ;; http://msdn.microsoft.com/en-us/library/17w5ykft%28v=vs.85%29.aspx
+ ;; After we perform that level of quoting, escape shell
+ ;; metacharacters so that cmd won't mangle our argument. If the
+ ;; argument contains no double quote characters, we can just
+ ;; surround it with double quotes. Otherwise, we need to prefix
+ ;; each shell metacharacter with a caret.
+
+ (setq argument
+ ;; escape backslashes at end of string
+ (replace-regexp-in-string
+ "\\(\\\\*\\)$"
+ "\\1\\1"
+ ;; escape backslashes and quotes in string body
+ (replace-regexp-in-string
+ "\\(\\\\*\\)\""
+ "\\1\\1\\\\\""
+ argument)))
+
+ (if (string-match "[%!\"]" argument)
+ (concat
+ "^\""
+ (replace-regexp-in-string
+ "\\([%!()\"<>&|^]\\)"
+ "^\\1"
+ argument)
+ "^\"")
+ (concat "\"" argument "\"")))
+
+ (t
(if (equal argument "")
"''"
;; Quote everything except POSIX filename characters.
;; This should be safe enough even for really weird shells.
- (replace-regexp-in-string "\n" "'\n'"
- (replace-regexp-in-string "[^-0-9a-zA-Z_./\n]" "\\\\\\&" argument)))))
+ (replace-regexp-in-string
+ "\n" "'\n'"
+ (replace-regexp-in-string "[^-0-9a-zA-Z_./\n]" "\\\\\\&" argument))))
+ ))
(defun string-or-null-p (object)
"Return t if OBJECT is a string or nil.
@@ -2435,8 +2582,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."
@@ -2484,7 +2632,7 @@ Replaces `category' properties with their defined properties."
(defvar yank-undo-function)
(defun insert-for-yank (string)
- "Calls `insert-for-yank-1' repetitively for each `yank-handler' segment.
+ "Call `insert-for-yank-1' repetitively for each `yank-handler' segment.
See `insert-for-yank-1' for more details."
(let (to)
@@ -2726,11 +2874,76 @@ nor the buffer list."
(when (buffer-live-p ,old-buffer)
(set-buffer ,old-buffer))))))
+(defmacro save-window-excursion (&rest body)
+ "Execute BODY, preserving window sizes and contents.
+Return the value of the last form in BODY.
+Restore which buffer appears in which window, where display starts,
+and the value of point and mark for each window.
+Also restore the choice of selected window.
+Also restore which buffer is current.
+Does not restore the value of point in current buffer.
+
+BEWARE: Most uses of this macro introduce bugs.
+E.g. it should not be used to try and prevent some code from opening
+a new window, since that window may sometimes appear in another frame,
+in which case `save-window-excursion' cannot help."
+ (declare (indent 0) (debug t))
+ (let ((c (make-symbol "wconfig")))
+ `(let ((,c (current-window-configuration)))
+ (unwind-protect (progn ,@body)
+ (set-window-configuration ,c)))))
+
+(defmacro with-output-to-temp-buffer (bufname &rest body)
+ "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
+
+This construct makes buffer BUFNAME empty before running BODY.
+It does not make the buffer current for BODY.
+Instead it binds `standard-output' to that buffer, so that output
+generated with `prin1' and similar functions in BODY goes into
+the buffer.
+
+At the end of BODY, this marks buffer BUFNAME unmodifed and displays
+it in a window, but does not select it. The normal way to do this is
+by calling `display-buffer', then running `temp-buffer-show-hook'.
+However, if `temp-buffer-show-function' is non-nil, it calls that
+function instead (and does not run `temp-buffer-show-hook'). The
+function gets one argument, the buffer to display.
+
+The return value of `with-output-to-temp-buffer' is the value of the
+last form in BODY. If BODY does not finish normally, the buffer
+BUFNAME is not displayed.
+
+This runs the hook `temp-buffer-setup-hook' before BODY,
+with the buffer BUFNAME temporarily current. It runs the hook
+`temp-buffer-show-hook' after displaying buffer BUFNAME, with that
+buffer temporarily current, and the window that was used to display it
+temporarily selected. But it doesn't run `temp-buffer-show-hook'
+if it uses `temp-buffer-show-function'."
+ (let ((old-dir (make-symbol "old-dir"))
+ (buf (make-symbol "buf")))
+ `(let* ((,old-dir default-directory)
+ (,buf
+ (with-current-buffer (get-buffer-create ,bufname)
+ (prog1 (current-buffer)
+ (kill-all-local-variables)
+ ;; FIXME: delete_all_overlays
+ (setq default-directory ,old-dir)
+ (setq buffer-read-only nil)
+ (setq buffer-file-name nil)
+ (setq buffer-undo-list t)
+ (let ((inhibit-read-only t)
+ (inhibit-modification-hooks t))
+ (erase-buffer)
+ (run-hooks 'temp-buffer-setup-hook)))))
+ (standard-output ,buf))
+ (prog1 (progn ,@body)
+ (internal-temp-output-buffer-show ,buf)))))
+
(defmacro with-temp-file (file &rest body)
"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)
@@ -2752,7 +2965,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)
@@ -2868,7 +3081,7 @@ but which should be robust in the unexpected case that an error is signaled."
(let ((err (make-symbol "err")))
`(condition-case-no-debug ,err
(progn ,@body)
- (error (message "Error: %s" ,err) nil))))
+ (error (message "Error: %S" ,err) nil))))
(defmacro combine-after-change-calls (&rest body)
"Execute BODY, but don't call the after-change functions till the end.
@@ -3168,7 +3381,7 @@ is non-nil, start replacements at that index in STRING.
REP is either a string used as the NEWTEXT arg of `replace-match' or a
function. If it is a function, it is called with the actual text of each
match, and its value is used as the replacement text. When REP is called,
-the match-data are the result of matching REGEXP against a substring
+the match data are the result of matching REGEXP against a substring
of STRING.
To replace only the first match (if any), make REGEXP match up to \\'
@@ -3244,7 +3457,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))
@@ -3281,7 +3494,7 @@ If SYNTAX is nil, return nil."
;;;; Text clones
-(defun text-clone-maintain (ol1 after beg end &optional len)
+(defun text-clone-maintain (ol1 after beg end &optional _len)
"Propagate the changes made under the overlay OL1 to the other clones.
This is used on the `modification-hooks' property of text clones."
(when (and after (not undo-in-progress) (overlay-start ol1))
@@ -3433,51 +3646,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'.
-(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."
+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.
+
+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)
@@ -3489,12 +3710,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))
@@ -3502,15 +3722,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.
@@ -3518,26 +3738,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."
@@ -3574,18 +3809,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
@@ -3677,8 +3912,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)))))
@@ -3730,7 +3970,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)))
@@ -3772,7 +4012,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)))
@@ -3781,7 +4021,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/t-mouse.el b/lisp/t-mouse.el
index bd9bccb4dce..059024c4bce 100644
--- a/lisp/t-mouse.el
+++ b/lisp/t-mouse.el
@@ -4,8 +4,7 @@
;; Maintainer: FSF
;; Keywords: mouse gpm linux
-;; Copyright (C) 1994, 1995, 1998, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1994-1995, 1998, 2006-2011 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
@@ -84,5 +83,4 @@ It relies on the `gpm' daemon being activated."
(provide 't-mouse)
-;; arch-tag: a63163b3-bfbe-4eb2-ab4f-201cd164b05d
;;; t-mouse.el ends here
diff --git a/lisp/tabify.el b/lisp/tabify.el
index d6731c032fd..da1038a2164 100644
--- a/lisp/tabify.el
+++ b/lisp/tabify.el
@@ -1,9 +1,9 @@
;;; tabify.el --- tab conversion commands for Emacs
-;; Copyright (C) 1985, 1994, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1994, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -89,5 +89,4 @@ The variable `tab-width' controls the spacing of tab stops."
(provide 'tabify)
-;; arch-tag: c83893b1-e0cc-4e57-8a09-73fd03466416
;;; tabify.el ends here
diff --git a/lisp/talk.el b/lisp/talk.el
index 0999b21db49..c16255f7742 100644
--- a/lisp/talk.el
+++ b/lisp/talk.el
@@ -1,7 +1,6 @@
;;; talk.el --- allow several users to talk to each other through Emacs
-;; Copyright (C) 1995, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: comm, frames
@@ -48,10 +47,9 @@ Each element has the form (DISPLAY FRAME BUFFER).")
(defun talk ()
"Connect to the Emacs talk group from the current X display or tty frame."
(interactive)
- (let ((type (frame-live-p (selected-frame)))
- (display (frame-terminal (selected-frame))))
+ (let ((type (frame-live-p (selected-frame))))
(if (or (eq type t) (eq type 'x))
- (talk-add-display
+ (talk-add-display
(terminal-name (frame-terminal (selected-frame))))
(error "Unknown frame type")))
(talk-update-buffers))
@@ -120,5 +118,4 @@ Select the first of these windows, displaying the first of the buffers."
(provide 'talk)
-;; arch-tag: 7ab0ad88-1788-4886-a44c-ae685e6f8a1a
;;; talk.el ends here
diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el
index ba9294a846a..39855a1c8cc 100644
--- a/lisp/tar-mode.el
+++ b/lisp/tar-mode.el
@@ -1,8 +1,6 @@
-;;; tar-mode.el --- simple editing of tar files from GNU emacs
+;;; tar-mode.el --- simple editing of tar files from GNU Emacs
-;; Copyright (C) 1990, 1991, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1990-1991, 1993-2011 Free Software Foundation, Inc.
;; Author: Jamie Zawinski <jwz@lucid.com>
;; Maintainer: FSF
@@ -137,7 +135,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)
@@ -223,7 +220,7 @@ Preserve the modified states of the buffers and set `buffer-swapped-with'."
(defun tar-roundup-512 (s)
"Round S up to the next multiple of 512."
(ash (ash (+ s 511) -9) 9))
-
+
(defun tar-header-block-tokenize (pos coding)
"Return a `tar-header' structure.
This is a list of name, mode, uid, gid, size,
@@ -286,7 +283,7 @@ write-date, checksum, link-type, and link-name."
(let* ((size (tar-parse-octal-integer
string tar-size-offset tar-time-offset))
;; -1 so as to strip the terminating 0 byte.
- (name (decode-coding-string
+ (name (decode-coding-string
(buffer-substring pos (+ pos size -1)) coding))
(descriptor (tar-header-block-tokenize
(+ pos (tar-roundup-512 size))
@@ -301,7 +298,7 @@ write-date, checksum, link-type, and link-name."
(setf (tar-header-header-start descriptor)
(copy-marker (- pos 512) t))
descriptor)
-
+
(make-tar-header
(copy-marker pos nil)
name
@@ -504,7 +501,7 @@ MODE should be an integer which is a file mode value."
;;(tar-header-block-check-checksum
;; hblock (tar-header-block-checksum hblock)
;; (tar-header-name descriptor))
-
+
(push descriptor result)
(setq pos (tar-header-data-end descriptor))
(progress-reporter-update progress-reporter pos)))
@@ -535,13 +532,11 @@ MODE should be an integer which is a file mode value."
(define-key map "\C-m" 'tar-extract)
(define-key map [mouse-2] 'tar-mouse-extract)
(define-key map "g" 'revert-buffer)
- (define-key map "h" 'describe-mode)
(define-key map "n" 'tar-next-line)
(define-key map "\^N" 'tar-next-line)
(define-key map [down] 'tar-next-line)
(define-key map "o" 'tar-extract-other-window)
(define-key map "p" 'tar-previous-line)
- (define-key map "q" 'quit-window)
(define-key map "\^P" 'tar-previous-line)
(define-key map [up] 'tar-previous-line)
(define-key map "R" 'tar-rename-entry)
@@ -617,7 +612,7 @@ MODE should be an integer which is a file mode value."
(if (buffer-live-p tar-data-buffer) (kill-buffer tar-data-buffer)))
;;;###autoload
-(define-derived-mode tar-mode nil "Tar"
+(define-derived-mode tar-mode special-mode "Tar"
"Major mode for viewing a tar file as a dired-like listing of its contents.
You can move around using the usual cursor motion commands.
Letters no longer insert themselves.
@@ -673,29 +668,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 +840,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 ()
@@ -1167,7 +1152,6 @@ to make your changes permanent."
subfile-size)
(with-current-buffer tar-superior-buffer
(let* ((start (tar-header-data-start descriptor))
- (name (tar-header-name descriptor))
(size (tar-header-size descriptor))
(head (memq descriptor tar-parse-info)))
(if (not head)
@@ -1247,7 +1231,7 @@ Leaves the region wide."
;; Used in write-region-annotate-functions to write tar-files out correctly.
-(defun tar-write-region-annotate (start end)
+(defun tar-write-region-annotate (start _end)
;; When called from write-file (and auto-save), `start' is nil.
;; When called from M-x write-region, we assume the user wants to save
;; (part of) the summary, not the tar data.
@@ -1258,5 +1242,4 @@ Leaves the region wide."
(provide 'tar-mode)
-;; arch-tag: 8a585a4a-340e-42c2-89e7-d3b1013a4b78
;;; tar-mode.el ends here
diff --git a/lisp/tempo.el b/lisp/tempo.el
index dca6ac14d2c..9b997f3387c 100644
--- a/lisp/tempo.el
+++ b/lisp/tempo.el
@@ -1,7 +1,6 @@
;;; tempo.el --- Flexible template insertion
-;; Copyright (C) 1994, 1995, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1995, 2001-2011 Free Software Foundation, Inc.
;; Author: David K}gedal <davidk@lysator.liu.se>
;; Created: 16 Feb 1994
@@ -763,5 +762,4 @@ space bar, and looks something like this:
(provide 'tempo)
-;; arch-tag: b3c0ee36-db3b-47bc-875f-091b4e27a063
;;; tempo.el ends here
diff --git a/lisp/term.el b/lisp/term.el
index 555a5f748e1..df95ca830ab 100644
--- a/lisp/term.el
+++ b/lisp/term.el
@@ -1,7 +1,7 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1988, 1990, 1992, 1994-1995, 2001-2011
+;; Free Software Foundation, Inc.
;; Author: Per Bothner <per@bothner.com>
;; Maintainer: Dan Nicolaescu <dann@ics.uci.edu>, Per Bothner <per@bothner.com>
@@ -762,11 +762,13 @@ Buffer local variable.")
"magenta3" "cyan3" "white"])
;; Inspiration came from comint.el -mm
-(defvar term-buffer-maximum-size 2048
- "*The maximum size in lines for term buffers.
+(defcustom term-buffer-maximum-size 2048
+ "The maximum size in lines for term buffers.
Term buffers are truncated from the top to be no greater than this number.
Notice that a setting of 0 means \"don't truncate anything\". This variable
-is buffer-local.")
+is buffer-local."
+ :group 'term
+ :type 'integer)
(when (featurep 'xemacs)
(defvar term-terminal-menu
@@ -1170,7 +1172,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 +1233,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)
@@ -1537,29 +1538,24 @@ See also `term-input-ignoredups' and `term-write-input-ring'."
(message "Cannot read history file %s"
term-input-ring-file-name)))
(t
- (let ((history-buf (get-buffer-create " *temp*"))
- (file term-input-ring-file-name)
+ (let ((file term-input-ring-file-name)
(count 0)
(ring (make-ring term-input-ring-size)))
- (unwind-protect
- (with-current-buffer history-buf
- (widen)
- (erase-buffer)
- (insert-file-contents file)
- ;; Save restriction in case file is already visited...
- ;; Watch for those date stamps in history files!
- (goto-char (point-max))
- (while (and (< count term-input-ring-size)
- (re-search-backward "^[ \t]*\\([^#\n].*\\)[ \t]*$"
- nil t))
- (let ((history (buffer-substring (match-beginning 1)
- (match-end 1))))
- (when (or (null term-input-ignoredups)
- (ring-empty-p ring)
- (not (string-equal (ring-ref ring 0) history)))
- (ring-insert-at-beginning ring history)))
- (setq count (1+ count))))
- (kill-buffer history-buf))
+ (with-temp-buffer
+ (insert-file-contents file)
+ ;; Save restriction in case file is already visited...
+ ;; Watch for those date stamps in history files!
+ (goto-char (point-max))
+ (while (and (< count term-input-ring-size)
+ (re-search-backward "^[ \t]*\\([^#\n].*\\)[ \t]*$"
+ nil t))
+ (let ((history (buffer-substring (match-beginning 1)
+ (match-end 1))))
+ (when (or (null term-input-ignoredups)
+ (ring-empty-p ring)
+ (not (string-equal (ring-ref ring 0) history)))
+ (ring-insert-at-beginning ring history)))
+ (setq count (1+ count))))
(setq term-input-ring ring
term-input-ring-index nil)))))
@@ -1799,15 +1795,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 +2105,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)))))
@@ -2219,9 +2211,11 @@ Security bug: your string can still be temporarily recovered with
;;; Low-level process communication
-(defvar term-input-chunk-size 512
- "*Long inputs send to term processes are broken up into chunks of this size.
-If your process is choking on big inputs, try lowering the value.")
+(defcustom term-input-chunk-size 512
+ "Long inputs send to term processes are broken up into chunks of this size.
+If your process is choking on big inputs, try lowering the value."
+ :group 'term
+ :type 'integer)
(defun term-send-string (proc str)
"Send to PROC the contents of STR as input.
@@ -2472,11 +2466,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 +2609,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 +3787,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
@@ -3925,27 +3913,38 @@ This is a good place to put keybindings.")
;; Commands like this are fine things to put in load hooks if you
;; want them present in specific modes.
-(defvar term-completion-autolist nil
- "*If non-nil, automatically list possibilities on partial completion.
-This mirrors the optional behavior of tcsh.")
+(defcustom term-completion-autolist nil
+ "If non-nil, automatically list possibilities on partial completion.
+This mirrors the optional behavior of tcsh."
+ :group 'term
+ :type 'boolean)
-(defvar term-completion-addsuffix t
- "*If non-nil, add a `/' to completed directories, ` ' to file names.
+(defcustom term-completion-addsuffix t
+ "If non-nil, add a `/' to completed directories, ` ' to file names.
If a cons pair, it should be of the form (DIRSUFFIX . FILESUFFIX) where
DIRSUFFIX and FILESUFFIX are strings added on unambiguous or exact
-completion. This mirrors the optional behavior of tcsh.")
+completion. This mirrors the optional behavior of tcsh."
+ :group 'term
+ :type '(choice (const :tag "No suffix" nil)
+ (cons (string :tag "dirsuffix") (string :tag "filesuffix"))
+ (other :tag "Suffix" t)))
-(defvar term-completion-recexact nil
- "*If non-nil, use shortest completion if characters cannot be added.
+(defcustom term-completion-recexact nil
+ "If non-nil, use shortest completion if characters cannot be added.
This mirrors the optional behavior of tcsh.
-A non-nil value is useful if `term-completion-autolist' is non-nil too.")
+A non-nil value is useful if `term-completion-autolist' is non-nil too."
+ :group 'term
+ :type 'boolean)
-(defvar term-completion-fignore nil
- "*List of suffixes to be disregarded during file completion.
+(defcustom term-completion-fignore nil
+ "List of suffixes to be disregarded during file completion.
This mirrors the optional behavior of bash and tcsh.
-Note that this applies to `term-dynamic-complete-filename' only.")
+Note that this applies to `term-dynamic-complete-filename' only."
+ :group 'term
+ :type '(choice (const nil)
+ (repeat :tag "List of suffixes" string)))
(defvar term-file-name-prefix ""
"Prefix prepended to absolute file names taken from process input.
@@ -4233,7 +4232,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 +4534,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/AT386.el b/lisp/term/AT386.el
index 90725a781f5..4453c9e3b8c 100644
--- a/lisp/term/AT386.el
+++ b/lisp/term/AT386.el
@@ -1,7 +1,6 @@
;;; AT386.el --- terminal support package for IBM AT keyboards -*- no-byte-compile: t -*-
-;; Copyright (C) 1992, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 2001-2011 Free Software Foundation, Inc.
;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
;; Keywords: terminals
@@ -57,5 +56,4 @@
(define-key local-function-key-map [ALT] [27])
))
-;; arch-tag: abec1b03-582f-49f8-b8cb-e2fd52ea4bd7
;;; AT386.el ends here
diff --git a/lisp/term/README b/lisp/term/README
index 385acee908c..6d2e0acbd20 100644
--- a/lisp/term/README
+++ b/lisp/term/README
@@ -1,5 +1,4 @@
-Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
- Free Software Foundation, Inc.
+Copyright (C) 1993, 2001-2011 Free Software Foundation, Inc.
See the end of the file for license conditions.
diff --git a/lisp/term/apollo.el b/lisp/term/apollo.el
index fc75a3e5599..c570a20112b 100644
--- a/lisp/term/apollo.el
+++ b/lisp/term/apollo.el
@@ -3,5 +3,4 @@
"Terminal initialization function for apollo."
(tty-run-terminal-initialization (selected-frame) "vt100"))
-;; arch-tag: c72f446f-e6b7-4749-90a4-bd68632adacf
;;; apollo.el ends here
diff --git a/lisp/term/bobcat.el b/lisp/term/bobcat.el
index e7723b0706d..d9ab1a5fb16 100644
--- a/lisp/term/bobcat.el
+++ b/lisp/term/bobcat.el
@@ -6,5 +6,4 @@
(keyboard-translate ?\177 ?\^h)
(keyboard-translate ?\^h ?\177))
-;; arch-tag: 754e4520-0a3e-4e6e-8ca5-9481b1f85cf7
;;; bobcat.el ends here
diff --git a/lisp/term/common-win.el b/lisp/term/common-win.el
index c185e36346c..c13d22dde71 100644
--- a/lisp/term/common-win.el
+++ b/lisp/term/common-win.el
@@ -1,7 +1,6 @@
;;; common-win.el --- common part of handling window systems
-;; Copyright (C) 1993, 1994, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1994, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: terminals
@@ -25,54 +24,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 +169,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 +197,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 +207,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 +218,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 +226,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 +253,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 +287,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/cygwin.el b/lisp/term/cygwin.el
index df857ba6625..cfce07035cf 100644
--- a/lisp/term/cygwin.el
+++ b/lisp/term/cygwin.el
@@ -6,5 +6,4 @@
"Terminal initialization function for cygwin."
(tty-no-underline))
-;; arch-tag: ca81ce67-3c41-4883-a29b-4c3d64a21191
;;; cygwin.el ends here
diff --git a/lisp/term/internal.el b/lisp/term/internal.el
index ab4c5ec39d5..43b799df1c9 100644
--- a/lisp/term/internal.el
+++ b/lisp/term/internal.el
@@ -1,7 +1,7 @@
;;; internal.el --- support for PC internal terminal
-;; Copyright (C) 1993, 1994, 1998, 1999, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1994, 1998-1999, 2001-2011
+;; Free Software Foundation, Inc.
;; Author: Morten Welinder <terra@diku.dk>
@@ -604,5 +604,4 @@ list. You can (and should) also run it if and when the value of
(run-hooks 'dos-codepage-setup-hook)
))
-;; arch-tag: eea04c06-7311-4b5a-b531-3c1be1b070af
;;; internal.el ends here
diff --git a/lisp/term/iris-ansi.el b/lisp/term/iris-ansi.el
index 82da165e0fa..490c06148a9 100644
--- a/lisp/term/iris-ansi.el
+++ b/lisp/term/iris-ansi.el
@@ -1,7 +1,6 @@
;;; iris-ansi.el --- configure Emacs for SGI xwsh and winterm apps -*- no-byte-compile: t -*-
-;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Dan Nicolaescu <dann@ics.uci.edu>
@@ -328,5 +327,4 @@
(set-keymap-parent m (keymap-parent input-decode-map))
(set-keymap-parent input-decode-map m)))
-;; arch-tag: b1d0e73a-bb7d-47be-9fb2-6fb126469a1b
;;; iris-ansi.el ends here
diff --git a/lisp/term/linux.el b/lisp/term/linux.el
index 5ac369721a4..76115e7d58a 100644
--- a/lisp/term/linux.el
+++ b/lisp/term/linux.el
@@ -18,5 +18,4 @@
;; The arg only matters in that it is not t or nil.
(set-input-meta-mode 'iso-latin-1))
-;; arch-tag: 5d0c4f63-739b-4862-abf3-041fe42adb8f
;;; linux.el ends here
diff --git a/lisp/term/lk201.el b/lisp/term/lk201.el
index 7bcbd8d754c..e1da0f6f1db 100644
--- a/lisp/term/lk201.el
+++ b/lisp/term/lk201.el
@@ -1,75 +1,77 @@
;; -*- no-byte-compile: t -*-
;; Define function key sequences for DEC terminals.
-(defvar lk201-function-map (make-sparse-keymap)
- "Function key definitions for DEC terminals.")
+(defvar lk201-function-map
+ (let ((map (make-sparse-keymap)))
-;; Termcap or terminfo should set these.
-;; (define-key lk201-function-map "\e[A" [up])
-;; (define-key lk201-function-map "\e[B" [down])
-;; (define-key lk201-function-map "\e[C" [right])
-;; (define-key lk201-function-map "\e[D" [left])
+ ;; Termcap or terminfo should set these.
+ ;; (define-key map "\e[A" [up])
+ ;; (define-key map "\e[B" [down])
+ ;; (define-key map "\e[C" [right])
+ ;; (define-key map "\e[D" [left])
-(define-key lk201-function-map "\e[1~" [find])
-(define-key lk201-function-map "\e[2~" [insert])
-(define-key lk201-function-map "\e[3~" [delete])
-(define-key lk201-function-map "\e[4~" [select])
-(define-key lk201-function-map "\e[5~" [prior])
-(define-key lk201-function-map "\e[6~" [next])
-(define-key lk201-function-map "\e[11~" [f1])
-(define-key lk201-function-map "\e[12~" [f2])
-(define-key lk201-function-map "\e[13~" [f3])
-(define-key lk201-function-map "\e[14~" [f4])
-(define-key lk201-function-map "\e[15~" [f5])
-(define-key lk201-function-map "\e[17~" [f6])
-(define-key lk201-function-map "\e[18~" [f7])
-(define-key lk201-function-map "\e[19~" [f8])
-(define-key lk201-function-map "\e[20~" [f9])
-(define-key lk201-function-map "\e[21~" [f10])
-;; Customarily F11 is used as the ESC key.
-;; The file that includes this one, takes care of that.
-(define-key lk201-function-map "\e[23~" [f11])
-(define-key lk201-function-map "\e[24~" [f12])
-(define-key lk201-function-map "\e[25~" [f13])
-(define-key lk201-function-map "\e[26~" [f14])
-(define-key lk201-function-map "\e[28~" [help])
-(define-key lk201-function-map "\e[29~" [menu])
-(define-key lk201-function-map "\e[31~" [f17])
-(define-key lk201-function-map "\e[32~" [f18])
-(define-key lk201-function-map "\e[33~" [f19])
-(define-key lk201-function-map "\e[34~" [f20])
+ (define-key map "\e[1~" [find])
+ (define-key map "\e[2~" [insert])
+ (define-key map "\e[3~" [delete])
+ (define-key map "\e[4~" [select])
+ (define-key map "\e[5~" [prior])
+ (define-key map "\e[6~" [next])
+ (define-key map "\e[11~" [f1])
+ (define-key map "\e[12~" [f2])
+ (define-key map "\e[13~" [f3])
+ (define-key map "\e[14~" [f4])
+ (define-key map "\e[15~" [f5])
+ (define-key map "\e[17~" [f6])
+ (define-key map "\e[18~" [f7])
+ (define-key map "\e[19~" [f8])
+ (define-key map "\e[20~" [f9])
+ (define-key map "\e[21~" [f10])
+ ;; Customarily F11 is used as the ESC key.
+ ;; The file that includes this one, takes care of that.
+ (define-key map "\e[23~" [f11])
+ (define-key map "\e[24~" [f12])
+ (define-key map "\e[25~" [f13])
+ (define-key map "\e[26~" [f14])
+ (define-key map "\e[28~" [help])
+ (define-key map "\e[29~" [menu])
+ (define-key map "\e[31~" [f17])
+ (define-key map "\e[32~" [f18])
+ (define-key map "\e[33~" [f19])
+ (define-key map "\e[34~" [f20])
-;; Termcap or terminfo should set these.
-;; (define-key lk201-function-map "\eOA" [up])
-;; (define-key lk201-function-map "\eOB" [down])
-;; (define-key lk201-function-map "\eOC" [right])
-;; (define-key lk201-function-map "\eOD" [left])
+ ;; Termcap or terminfo should set these.
+ ;; (define-key map "\eOA" [up])
+ ;; (define-key map "\eOB" [down])
+ ;; (define-key map "\eOC" [right])
+ ;; (define-key map "\eOD" [left])
-;; Termcap or terminfo should set these, but doesn't properly.
-;; Termcap sets these to k1-k4, which get mapped to f1-f4 in term.c
-(define-key lk201-function-map "\eOP" [kp-f1])
-(define-key lk201-function-map "\eOQ" [kp-f2])
-(define-key lk201-function-map "\eOR" [kp-f3])
-(define-key lk201-function-map "\eOS" [kp-f4])
+ ;; Termcap or terminfo should set these, but doesn't properly.
+ ;; Termcap sets these to k1-k4, which get mapped to f1-f4 in term.c
+ (define-key map "\eOP" [kp-f1])
+ (define-key map "\eOQ" [kp-f2])
+ (define-key map "\eOR" [kp-f3])
+ (define-key map "\eOS" [kp-f4])
-(define-key lk201-function-map "\eOI" [kp-tab])
-(define-key lk201-function-map "\eOj" [kp-multiply])
-(define-key lk201-function-map "\eOk" [kp-add])
-(define-key lk201-function-map "\eOl" [kp-separator])
-(define-key lk201-function-map "\eOM" [kp-enter])
-(define-key lk201-function-map "\eOm" [kp-subtract])
-(define-key lk201-function-map "\eOn" [kp-decimal])
-(define-key lk201-function-map "\eOo" [kp-divide])
-(define-key lk201-function-map "\eOp" [kp-0])
-(define-key lk201-function-map "\eOq" [kp-1])
-(define-key lk201-function-map "\eOr" [kp-2])
-(define-key lk201-function-map "\eOs" [kp-3])
-(define-key lk201-function-map "\eOt" [kp-4])
-(define-key lk201-function-map "\eOu" [kp-5])
-(define-key lk201-function-map "\eOv" [kp-6])
-(define-key lk201-function-map "\eOw" [kp-7])
-(define-key lk201-function-map "\eOx" [kp-8])
-(define-key lk201-function-map "\eOy" [kp-9])
+ (define-key map "\eOI" [kp-tab])
+ (define-key map "\eOj" [kp-multiply])
+ (define-key map "\eOk" [kp-add])
+ (define-key map "\eOl" [kp-separator])
+ (define-key map "\eOM" [kp-enter])
+ (define-key map "\eOm" [kp-subtract])
+ (define-key map "\eOn" [kp-decimal])
+ (define-key map "\eOo" [kp-divide])
+ (define-key map "\eOp" [kp-0])
+ (define-key map "\eOq" [kp-1])
+ (define-key map "\eOr" [kp-2])
+ (define-key map "\eOs" [kp-3])
+ (define-key map "\eOt" [kp-4])
+ (define-key map "\eOu" [kp-5])
+ (define-key map "\eOv" [kp-6])
+ (define-key map "\eOw" [kp-7])
+ (define-key map "\eOx" [kp-8])
+ (define-key map "\eOy" [kp-9])
+ map)
+ "Function key definitions for DEC terminals.")
(defun terminal-init-lk201 ()
;; Use inheritance to let the main keymap override these defaults.
@@ -79,5 +81,4 @@
(set-keymap-parent m (keymap-parent input-decode-map))
(set-keymap-parent input-decode-map m)))
-;; arch-tag: 7ffb4444-6a23-43e1-b457-43cf4f673c0d
;;; lk201.el ends here
diff --git a/lisp/term/news.el b/lisp/term/news.el
index 8918bee3b81..ba6346997c5 100644
--- a/lisp/term/news.el
+++ b/lisp/term/news.el
@@ -1,7 +1,6 @@
;;; news.el --- keypad and function key bindings for the Sony NEWS keyboard -*- no-byte-compile: t -*-
-;; Copyright (C) 1989, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1989, 1993, 2001-2011 Free Software Foundation, Inc.
;; Author: FSF
;; Keywords: terminals
@@ -69,5 +68,4 @@
(define-key news-fkey-prefix "x" [kp-8])
))
-;; arch-tag: bfe141a0-623b-4b42-b753-5d9353776c5e
;;; news.el ends here
diff --git a/lisp/term/ns-win.el b/lisp/term/ns-win.el
index 6880fdb8807..712929ecec0 100644
--- a/lisp/term/ns-win.el
+++ b/lisp/term/ns-win.el
@@ -1,7 +1,6 @@
;;; ns-win.el --- lisp side of interface with NeXT/Open/GNUstep/MacOS X window system
-;; Copyright (C) 1993, 1994, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1993-1994, 2005-2011 Free Software Foundation, Inc.
;; Authors: Carl Edman
;; Christian Limpach
@@ -41,131 +40,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 +97,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 +153,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])
@@ -285,196 +180,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 +252,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 +348,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 +381,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 +437,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,13 +487,12 @@ 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 (expand-file-name (car ns-input-file)
- command-line-default-directory)))
- (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
+ (expand-file-name (pop ns-input-file)
+ command-line-default-directory)))
+ (file (find-file-noselect f))
+ (bufwin1 (get-buffer-window file 'visible))
+ (bufwin2 (get-buffer-window "*scratch*" 'visibile)))
(cond
(bufwin1
(select-frame (window-frame bufwin1))
@@ -811,13 +511,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)
@@ -884,10 +588,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."
@@ -905,7 +607,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
@@ -950,17 +651,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
@@ -1009,7 +709,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))
@@ -1017,43 +717,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)
@@ -1074,7 +752,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)
@@ -1135,27 +812,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))
@@ -1243,7 +899,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)
@@ -1262,12 +918,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 d1efd0f1644..4cb88f6bd23 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 1996-1997, 1999, 2001-2011
+;; 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/rxvt.el b/lisp/term/rxvt.el
index 18ceff62def..0e9de519c8c 100644
--- a/lisp/term/rxvt.el
+++ b/lisp/term/rxvt.el
@@ -1,7 +1,6 @@
;;; rxvt.el --- define function key sequences and standard colors for rxvt
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Eli Zaretskii
;; Keywords: terminals
@@ -310,5 +309,4 @@ for the currently selected frame."
(* (apply '+ (car (cddr (nth 15 rxvt-standard-colors)))) 0.6))
(set-terminal-parameter nil 'background-mode 'dark)))))
-;; arch-tag: 20cf2fb6-6318-4bab-9dbf-1d15048f2257
;;; rxvt.el ends here
diff --git a/lisp/term/screen.el b/lisp/term/screen.el
new file mode 100644
index 00000000000..4931a422e09
--- /dev/null
+++ b/lisp/term/screen.el
@@ -0,0 +1,11 @@
+;; -*- no-byte-compile: t -*-
+;; Treat a screen terminal similar to an xterm.
+(load "term/xterm")
+
+(defun terminal-init-screen ()
+ "Terminal initialization function for screen."
+ ;; Use the xterm color initialization code.
+ (xterm-register-default-colors)
+ (tty-set-up-initial-frame-faces))
+
+;; screen.el ends here
diff --git a/lisp/term/sun.el b/lisp/term/sun.el
index 705d67a2133..d375656569c 100644
--- a/lisp/term/sun.el
+++ b/lisp/term/sun.el
@@ -1,7 +1,6 @@
;;; sun.el --- keybinding for standard default sunterm keys
-;; Copyright (C) 1987, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1987, 2001-2011 Free Software Foundation, Inc.
;; Author: Jeff Peck <peck@sun.com>
;; Keywords: terminals
@@ -155,5 +154,4 @@
(eval (car hooks))
(setq hooks (cdr hooks))))))
-;; arch-tag: db761d47-fd7d-42b4-aae1-04fa116b6ba6
;;; sun.el ends here
diff --git a/lisp/term/sup-mouse.el b/lisp/term/sup-mouse.el
index 84b4a8d2702..6d77241008c 100644
--- a/lisp/term/sup-mouse.el
+++ b/lisp/term/sup-mouse.el
@@ -1,7 +1,6 @@
;;; sup-mouse.el --- supdup mouse support for lisp machines
-;; Copyright (C) 1985, 1986, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1986, 2001-2011 Free Software Foundation, Inc.
;; Author: Wolfgang Rupprecht
;; Maintainer: FSF
@@ -31,8 +30,11 @@
;;; User customization option:
-(defvar sup-mouse-fast-select-window nil
- "*Non-nil for mouse hits to select new window, then execute; else just select.")
+(defcustom sup-mouse-fast-select-window nil
+ "Non-nil means mouse hits select new window, then execute.
+Otherwise just select."
+ :type 'boolean
+ :group 'mouse)
(defconst mouse-left 0)
(defconst mouse-center 1)
@@ -195,5 +197,4 @@ X and Y are 0-based character positions on the frame."
(get-window-with-predicate (lambda (w)
(coordinates-in-window-p (cons x y) w))))
-;; arch-tag: ec644ed4-cac4-43b8-b3db-cfe83e9098d7
;;; sup-mouse.el ends here
diff --git a/lisp/term/tty-colors.el b/lisp/term/tty-colors.el
index d0e688da5f7..9a900916830 100644
--- a/lisp/term/tty-colors.el
+++ b/lisp/term/tty-colors.el
@@ -1,7 +1,6 @@
;;; tty-colors.el --- color support for character terminals
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
;; Author: Eli Zaretskii
;; Maintainer: FSF
@@ -768,11 +767,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 +1033,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 ecc22d94d59..5d852e52105 100644
--- a/lisp/term/tvi970.el
+++ b/lisp/term/tvi970.el
@@ -1,7 +1,6 @@
;;; tvi970.el --- terminal support for the Televideo 970
-;; Copyright (C) 1992, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 2001-2011 Free Software Foundation, Inc.
;; Author: Jim Blandy <jimb@occs.cs.oberlin.edu>
;; Keywords: terminals
@@ -28,6 +27,8 @@
;;; Code:
+(eval-when-compile (require 'cl))
+
(defvar tvi970-terminal-map
(let ((map (make-sparse-keymap)))
@@ -102,7 +103,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 +112,8 @@ 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>"))))
-
-;; arch-tag: c1334cf0-1462-41c3-a963-c077d175f8f0
+ :variable (terminal-parameter nil 'tvi970-keypad-numeric)
+ (send-string-to-terminal
+ (if (terminal-parameter nil 'tvi970-keypad-numeric) "\e=" "\e>")))
+
;;; tvi970.el ends here
diff --git a/lisp/term/vt100.el b/lisp/term/vt100.el
index 58dfaeae934..406c20a0e81 100644
--- a/lisp/term/vt100.el
+++ b/lisp/term/vt100.el
@@ -1,7 +1,6 @@
;;; vt100.el --- define VT100 function key sequences in function-key-map
-;; Copyright (C) 1989, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1989, 1993, 2001-2011 Free Software Foundation, Inc.
;; Author: FSF
;; Keywords: terminals
@@ -41,19 +40,12 @@
(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)))
-
-;; arch-tag: 9ff41f24-a7c9-4dee-9cf2-fbaa951eb840
+ :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)))
+
;;; vt100.el ends here
diff --git a/lisp/term/vt102.el b/lisp/term/vt102.el
index 1f9bb00efab..0f2e3805f58 100644
--- a/lisp/term/vt102.el
+++ b/lisp/term/vt102.el
@@ -4,5 +4,4 @@
"Terminal initialization function for vt102."
(tty-run-terminal-initialization (selected-frame) "vt100"))
-;; arch-tag: 6e839cfc-125a-4574-82f1-c23a51f7c50f
;;; vt102.el ends here
diff --git a/lisp/term/vt125.el b/lisp/term/vt125.el
index b5a31e8a0f6..029f762ef3f 100644
--- a/lisp/term/vt125.el
+++ b/lisp/term/vt125.el
@@ -4,5 +4,4 @@
"Terminal initialization function for vt125."
(tty-run-terminal-initialization (selected-frame) "vt100"))
-;; arch-tag: 1d92d70f-dd55-4a1d-9088-e215a4883801
;;; vt125.el ends here
diff --git a/lisp/term/vt200.el b/lisp/term/vt200.el
index 78c65c084ce..09ad64d01f6 100644
--- a/lisp/term/vt200.el
+++ b/lisp/term/vt200.el
@@ -8,5 +8,4 @@
(define-key input-decode-map "\e[23~" [f11]) ;Probably redundant.
(define-key local-function-key-map [f11] [?\e]))
-;; arch-tag: 0f78f583-9f32-4237-b106-28bcfff21d89
;;; vt200.el ends here
diff --git a/lisp/term/vt201.el b/lisp/term/vt201.el
index 987aee09f3b..cbeba00b651 100644
--- a/lisp/term/vt201.el
+++ b/lisp/term/vt201.el
@@ -8,5 +8,4 @@
(define-key input-decode-map "\e[23~" [f11]) ;Probably redundant.
(define-key local-function-key-map [f11] [?\e]))
-;; arch-tag: a6abb38f-60ea-449e-a9e9-3fb8572c52ae
;;; vt201.el ends here
diff --git a/lisp/term/vt220.el b/lisp/term/vt220.el
index f9439e0eff7..647b79ea357 100644
--- a/lisp/term/vt220.el
+++ b/lisp/term/vt220.el
@@ -8,5 +8,4 @@
(define-key input-decode-map "\e[23~" [f11]) ;Probably redundant.
(define-key local-function-key-map [f11] [?\e]))
-;; arch-tag: 98fc4867-a20d-46a1-a276-d7be31e49871
;;; vt220.el ends here
diff --git a/lisp/term/vt240.el b/lisp/term/vt240.el
index 0aea10bf982..2da4e7ed3c7 100644
--- a/lisp/term/vt240.el
+++ b/lisp/term/vt240.el
@@ -8,5 +8,4 @@
(define-key input-decode-map "\e[23~" [f11]) ;Probably redundant.
(define-key local-function-key-map [f11] [?\e]))
-;; arch-tag: d9f88e9c-02dc-49ff-871c-a415f08e4eb7
;;; vt240.el ends here
diff --git a/lisp/term/vt300.el b/lisp/term/vt300.el
index d19f847588b..52198d840ae 100644
--- a/lisp/term/vt300.el
+++ b/lisp/term/vt300.el
@@ -6,5 +6,4 @@
(define-key input-decode-map "\e[23~" [f11]) ;Probably redundant.
(define-key local-function-key-map [f11] [?\e]))
-;; arch-tag: 876831c9-a6f2-444a-b033-706e6fbc149f
;;; vt300.el ends here
diff --git a/lisp/term/vt320.el b/lisp/term/vt320.el
index 1d36c9d933a..9b04a5d6ee4 100644
--- a/lisp/term/vt320.el
+++ b/lisp/term/vt320.el
@@ -6,5 +6,4 @@
(define-key input-decode-map "\e[23~" [f11]) ;Probably redundant.
(define-key local-function-key-map [f11] [?\e]))
-;; arch-tag: f9f4c954-0b9e-45f9-b450-a320d32abd9c
;;; vt320.el ends here
diff --git a/lisp/term/vt400.el b/lisp/term/vt400.el
index 78af2a37197..4c5870c5ad8 100644
--- a/lisp/term/vt400.el
+++ b/lisp/term/vt400.el
@@ -6,5 +6,4 @@
(define-key input-decode-map "\e[23~" [f11]) ;Probably redundant.
(define-key local-function-key-map [f11] [?\e]))
-;; arch-tag: a70809c5-6b21-42cc-ba20-536683e5e7d5
;;; vt400.el ends here
diff --git a/lisp/term/vt420.el b/lisp/term/vt420.el
index 69b1b31abd7..0476b639c23 100644
--- a/lisp/term/vt420.el
+++ b/lisp/term/vt420.el
@@ -6,5 +6,4 @@
(define-key input-decode-map "\e[23~" [f11]) ;Probably redundant.
(define-key local-function-key-map [f11] [?\e]))
-;; arch-tag: df2f897c-3a12-4b3c-9259-df089f96c160
;;; vt420.el ends here
diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el
index b6d0330b7a4..e4bf031d422 100644
--- a/lisp/term/w32-win.el
+++ b/lisp/term/w32-win.el
@@ -1,7 +1,6 @@
;;; w32-win.el --- parse switches controlling interface with W32 window system
-;; Copyright (C) 1993, 1994, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1994, 2001-2011 Free Software Foundation, Inc.
;; Author: Kevin Gallo
;; Keywords: terminals
@@ -148,18 +147,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 +185,11 @@ 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)
+(defvar libpng-version) ; image.c #ifdef HAVE_NTGUI
-;;; Set default known names for image libraries
-(setq image-library-alist
+;;; Set default known names for external libraries
+(setq dynamic-library-alist
(list
'(xpm "libxpm.dll" "xpm4.dll" "libXpm-nox4.dll")
;; Versions of libpng 1.4.x and later are incompatible with
@@ -212,13 +202,14 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.")
'(png "libpng12d.dll" "libpng12.dll" "libpng3.dll" "libpng.dll"
;; these are libpng 1.2.8 from GTK+
"libpng13d.dll" "libpng13.dll"))
- '(jpeg "jpeg62.dll" "libjpeg.dll" "jpeg-62.dll" "jpeg.dll")
- '(tiff "libtiff3.dll" "libtiff.dll")
- '(gif "giflib4.dll" "libungif4.dll" "libungif.dll")
- '(svg "librsvg-2-2.dll")
- '(gdk-pixbuf "libgdk_pixbuf-2.0-0.dll")
- '(glib "libglib-2.0-0.dll")
- '(gobject "libgobject-2.0-0.dll")))
+ '(jpeg "jpeg62.dll" "libjpeg.dll" "jpeg-62.dll" "jpeg.dll")
+ '(tiff "libtiff3.dll" "libtiff.dll")
+ '(gif "giflib4.dll" "libungif4.dll" "libungif.dll")
+ '(svg "librsvg-2-2.dll")
+ '(gdk-pixbuf "libgdk_pixbuf-2.0-0.dll")
+ '(glib "libglib-2.0-0.dll")
+ '(gobject "libgobject-2.0-0.dll")
+ '(gnutls "libgnutls-26.dll")))
;;; multi-tty support
(defvar w32-initialized nil
@@ -324,5 +315,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 f62f6aca0d6..cd5aed31982 100644
--- a/lisp/term/w32console.el
+++ b/lisp/term/w32console.el
@@ -1,6 +1,6 @@
;;; w32console.el -- Setup w32 console keys and colors.
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: FSF
;; Keywords: terminals
@@ -45,7 +45,8 @@
("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))
+(declare-function get-screen-color "w32console.c" ())
(defun terminal-init-w32console ()
"Terminal initialization function for w32 console."
@@ -59,7 +60,20 @@
(setq colors (cdr colors)
color (car colors))))
(clear-face-cache)
+ ;; Figure out what are the colors of the console window, and set up
+ ;; the background-mode correspondingly.
+ (let* ((screen-color (get-screen-color))
+ (bg (cadr screen-color))
+ (descr (tty-color-by-index bg))
+ r g b bg-mode)
+ (setq r (nth 2 descr)
+ g (nth 3 descr)
+ b (nth 4 descr))
+ (if (< (+ r g b) (* .6 (+ 65535 65535 65535)))
+ (setq bg-mode 'dark)
+ (setq bg-mode 'light))
+ (set-terminal-parameter nil 'background-mode bg-mode))
(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/wyse50.el b/lisp/term/wyse50.el
index 813f6be2485..b818c769bab 100644
--- a/lisp/term/wyse50.el
+++ b/lisp/term/wyse50.el
@@ -1,7 +1,6 @@
;;; wyse50.el --- terminal support code for Wyse 50 -*- no-byte-compile: t -*-
-;; Copyright (C) 1989, 1993, 1994, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1989, 1993-1994, 2001-2011 Free Software Foundation, Inc.
;; Author: Daniel Pfeiffer <occitan@esperanto.org>,
;; Jim Blandy <jimb@occs.cs.oberlin.edu>
@@ -156,5 +155,4 @@ M-r M-x move-to-window-line, Funct up-arrow or down-arrow are similar"
;; (nth 1 key-definition)))
(fset 'enable-arrow-keys nil))
-;; arch-tag: b6a05d37-eead-4cf6-b997-0f956c68881c
;;; wyse50.el ends here
diff --git a/lisp/term/x-win.el b/lisp/term/x-win.el
index 8a2b01cf9be..e3c42626a3f 100644
--- a/lisp/term/x-win.el
+++ b/lisp/term/x-win.el
@@ -1,7 +1,6 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1994, 2001-2011 Free Software Foundation, Inc.
;; Author: FSF
;; Keywords: terminals, i18n
@@ -252,50 +251,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,105 +1147,55 @@ 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)
+ :group 'killing
+ :version "24.1")
-(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))))
-
-(defvar x-select-request-type nil
- "*Data type request for X selection.
+(defcustom x-select-request-type nil
+ "Data type request for X selection.
The value is one of the following data types, a list of them, or nil:
`COMPOUND_TEXT', `UTF8_STRING', `STRING', `TEXT'
-If the value is one of the above symbols, try only the specified
-type.
+If the value is one of the above symbols, try only the specified type.
If the value is a list of them, try each of them in the specified
order until succeed.
-The value nil is the same as this list:
- \(UTF8_STRING COMPOUND_TEXT STRING)
-")
+The value nil is the same as the list (UTF8_STRING COMPOUND_TEXT STRING)."
+ :type '(choice (const :tag "Default" nil)
+ (const COMPOUND_TEXT)
+ (const UTF8_STRING)
+ (const STRING)
+ (const TEXT)
+ (set :tag "List of values"
+ (const COMPOUND_TEXT)
+ (const UTF8_STRING)
+ (const STRING)
+ (const TEXT)))
+ :group 'killing)
;; Get a selection value of type TYPE by calling x-get-selection with
;; an appropriate DATA-TYPE argument decided by `x-select-request-type'.
;; 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 +1213,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 +1241,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 +1258,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 +1353,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 +1437,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 +1582,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/term/xterm.el b/lisp/term/xterm.el
index aacee8dd7bb..0db33b5a4de 100644
--- a/lisp/term/xterm.el
+++ b/lisp/term/xterm.el
@@ -1,7 +1,6 @@
;;; xterm.el --- define function key sequences and standard colors for xterm
-;; Copyright (C) 1995, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 2001-2011 Free Software Foundation, Inc.
;; Author: FSF
;; Keywords: terminals
@@ -682,5 +681,4 @@ versions of xterm."
(set-terminal-parameter nil 'background-mode 'dark)
t))
-;; arch-tag: 12e7ebdd-1e6c-4b25-b0f9-35ace25e855a
;;; xterm.el ends here
diff --git a/lisp/terminal.el b/lisp/terminal.el
index 26778fcd5ad..0bde04eb2ec 100644
--- a/lisp/terminal.el
+++ b/lisp/terminal.el
@@ -1,7 +1,7 @@
;;; terminal.el --- terminal emulator for GNU Emacs
-;; Copyright (C) 1986, 1987, 1988, 1989, 1993, 1994, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1986-1989, 1993-1994, 2001-2011
+;; Free Software Foundation, Inc.
;; Author: Richard Mlynarik <mly@eddie.mit.edu>
;; Maintainer: FSF
@@ -1005,7 +1005,7 @@ move to start of new line, clear to end of line."
(unwind-protect
(progn
(set-process-filter te-process
- (function (lambda (p s)
+ (function (lambda (_p s)
(or (eq (length s) 1)
(setq te-pending-output (list 1 s)))
(throw 'char (aref s 0)))))
@@ -1327,7 +1327,7 @@ in the directory specified by `te-terminfo-directory'."
"im=:ei=:dm=:ed=:mi:do=^p^j:nl=^p^j:bs:")
)
-(defun te-tic-sentinel (proc state-change)
+(defun te-tic-sentinel (_proc state-change)
"If tic has finished, delete the .tif file"
(if (equal state-change "finished
")
@@ -1335,5 +1335,4 @@ in the directory specified by `te-terminfo-directory'."
(provide 'terminal)
-;; arch-tag: 0ae1d7d7-90ef-4566-a531-6e7ff8c79b2f
;;; terminal.el ends here
diff --git a/lisp/textmodes/artist.el b/lisp/textmodes/artist.el
index f7ef5584410..2325d7b26ff 100644
--- a/lisp/textmodes/artist.el
+++ b/lisp/textmodes/artist.el
@@ -1,7 +1,6 @@
;;; artist.el --- draw ascii graphics with your mouse
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Author: Tomas Abrahamsson <tab@lysator.liu.se>
;; Maintainer: Tomas Abrahamsson <tab@lysator.liu.se>
@@ -423,7 +422,7 @@ be in `artist-spray-chars', or spraying will behave strangely.")
(defvar artist-mode-name " Artist"
"Name of Artist mode beginning with a space (appears in the mode-line).")
-(defvar artist-curr-go 'pen-char
+(defvar artist-curr-go 'pen-line
"Current selected graphics operation.")
(make-variable-buffer-local 'artist-curr-go)
@@ -503,6 +502,49 @@ This variable is initialized by the `artist-make-prev-next-op-alist' function.")
(defvar artist-arrow-point-1 nil)
(defvar artist-arrow-point-2 nil)
+(defvar artist-menu-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [spray-chars]
+ '(menu-item "Characters for Spray" artist-select-spray-chars
+ :help "Choose characters for sprayed by the spray-can"))
+ (define-key map [borders]
+ '(menu-item "Draw Shape Borders" artist-toggle-borderless-shapes
+ :help "Toggle whether shapes are drawn with borders"
+ :button (:toggle . (not artist-borderless-shapes))))
+ (define-key map [trimming]
+ '(menu-item "Trim Line Endings" artist-toggle-trim-line-endings
+ :help "Toggle trimming of line-endings"
+ :button (:toggle . artist-trim-line-endings)))
+ (define-key map [rubber-band]
+ '(menu-item "Rubber-banding" artist-toggle-rubber-banding
+ :help "Toggle rubber-banding"
+ :button (:toggle . artist-rubber-banding)))
+ (define-key map [set-erase]
+ '(menu-item "Character to Erase..." artist-select-erase-char
+ :help "Choose a specific character to erase"))
+ (define-key map [set-line]
+ '(menu-item "Character for Line..." artist-select-line-char
+ :help "Choose the character to insert when drawing lines"))
+ (define-key map [set-fill]
+ '(menu-item "Character for Fill..." artist-select-fill-char
+ :help "Choose the character to insert when filling in shapes"))
+ (define-key map [artist-separator] '(menu-item "--"))
+ (dolist (op '(("Vaporize" artist-select-op-vaporize-lines vaporize-lines)
+ ("Erase" artist-select-op-erase-rectangle erase-rect)
+ ("Spray-can" artist-select-op-spray-set-size spray-get-size)
+ ("Text" artist-select-op-text-overwrite text-ovwrt)
+ ("Ellipse" artist-select-op-circle circle)
+ ("Poly-line" artist-select-op-straight-poly-line spolyline)
+ ("Rectangle" artist-select-op-square square)
+ ("Line" artist-select-op-straight-line s-line)
+ ("Pen" artist-select-op-pen-line pen-line)))
+ (define-key map (vector (nth 2 op))
+ `(menu-item ,(nth 0 op)
+ ,(nth 1 op)
+ :help ,(format "Draw using the %s style" (nth 0 op))
+ :button (:radio . (eq artist-curr-go ',(nth 2 op))))))
+ map))
+
(defvar artist-mode-map
(let ((map (make-sparse-keymap)))
(setq artist-mode-map (make-sparse-keymap))
@@ -555,6 +597,7 @@ This variable is initialized by the `artist-make-prev-next-op-alist' function.")
(define-key map "\C-c\C-a\C-y" 'artist-select-op-paste)
(define-key map "\C-c\C-af" 'artist-select-op-flood-fill)
(define-key map "\C-c\C-a\C-b" 'artist-submit-bug-report)
+ (define-key map [menu-bar artist] (cons "Artist" artist-menu-map))
map)
"Keymap for `artist-minor-mode'.")
@@ -1899,7 +1942,7 @@ Return a list (RETURN-CODE STDOUT STDERR)."
;;
;; Example: In the figure below, the `X' is the very last
;; character in the buffer ("a non-empty line at the
- ;; end"). Suppose point is at at P. Then (forward-line 1)
+ ;; end"). Suppose point is at P. Then (forward-line 1)
;; returns 0 and puts point after the `X'.
;;
;; --------top of buffer--------
@@ -1957,24 +2000,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."
@@ -4000,7 +4030,7 @@ The 2-point shape SHAPE is drawn from X1, Y1 to X2, Y2."
(defun artist-draw-region-trim-line-endings (min-y max-y)
"Trim lines in current draw-region from MIN-Y to MAX-Y.
Trimming here means removing white space at end of a line."
- ;; Safetyc check: switch min-y and max-y if if max-y is smaller
+ ;; Safety check: switch min-y and max-y if max-y is smaller
(if (< max-y min-y)
(let ((tmp min-y))
(setq min-y max-y)
@@ -4615,6 +4645,10 @@ If optional argument STATE is positive, turn borders on."
(artist-arrow-point-set-state artist-arrow-point-2 new-state)))))
+(defun artist-select-op-pen-line ()
+ "Select drawing pen lines."
+ (interactive)
+ (artist-select-operation "Pen Line"))
(defun artist-select-op-line ()
"Select drawing lines."
@@ -5570,5 +5604,4 @@ The event, EV, is the mouse event."
;; Don't hesitate to ask me any questions.
-;; arch-tag: 3e63b881-aaaa-4b83-a072-220d4661a8a3
;;; artist.el ends here
diff --git a/lisp/textmodes/bib-mode.el b/lisp/textmodes/bib-mode.el
index dcd6baa53b3..17ddd1de954 100644
--- a/lisp/textmodes/bib-mode.el
+++ b/lisp/textmodes/bib-mode.el
@@ -1,7 +1,6 @@
;;; bib-mode.el --- major mode for editing bib files
-;; Copyright (C) 1989, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1989, 2001-2011 Free Software Foundation, Inc.
;; Author: Henry Kautz
;; (according to authors.el)
@@ -48,11 +47,14 @@
:type 'file
:group 'bib)
-(defvar bib-mode-map (copy-keymap text-mode-map))
-(define-key bib-mode-map "\C-M" 'return-key-bib)
-(define-key bib-mode-map "\C-c\C-u" 'unread-bib)
-(define-key bib-mode-map "\C-c\C-@" 'mark-bib)
-(define-key bib-mode-map "\e`" 'abbrev-mode)
+(defvar bib-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map text-mode-map)
+ (define-key map "\C-M" 'return-key-bib)
+ (define-key map "\C-c\C-u" 'unread-bib)
+ (define-key map "\C-c\C-@" 'mark-bib)
+ (define-key map "\e`" 'abbrev-mode)
+ map))
(defun addbib ()
"Set up editor to add to troff bibliography file specified
@@ -236,5 +238,4 @@ named by variable `unread-bib-file'."
(provide 'bib-mode)
-;; arch-tag: e3a97958-3c2c-487f-9557-fafc3c98452d
;;; bib-mode.el ends here
diff --git a/lisp/textmodes/bibtex-style.el b/lisp/textmodes/bibtex-style.el
index e5ded8b15ca..bc5326240a3 100644
--- a/lisp/textmodes/bibtex-style.el
+++ b/lisp/textmodes/bibtex-style.el
@@ -1,6 +1,6 @@
-;;; bibtex-style.el --- Major mode for BibTeX Style files
+;;; bibtex-style.el --- Major mode for BibTeX Style files -*- lexical-binding: t -*-
-;; Copyright (C) 2005, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2005, 2007-2011 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: tex
@@ -63,8 +63,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."
@@ -143,7 +141,7 @@
(looking-at "if\\$"))
(scan-error nil))))
(save-excursion
- (condition-case err
+ (condition-case nil
(while (progn
(backward-sexp 1)
(save-excursion (skip-chars-backward " \t{") (not (bolp)))))
@@ -153,5 +151,4 @@
(provide 'bibtex-style)
-;; arch-tag: b20ad41a-fd36-466e-8fd2-cc6137f9c55c
;;; bibtex-style.el ends here
diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el
index 191ceedf041..e49d7549776 100644
--- a/lisp/textmodes/bibtex.el
+++ b/lisp/textmodes/bibtex.el
@@ -1,8 +1,6 @@
;;; bibtex.el --- BibTeX mode for GNU Emacs
-;; Copyright (C) 1992, 1994, 1995, 1996, 1997, 1998, 1999, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1992, 1994-1999, 2001-2011 Free Software Foundation, Inc.
;; Author: Stefan Schoef <schoef@offis.uni-oldenburg.de>
;; Bengt Martensson <bengt@mathematik.uni-Bremen.de>
@@ -2095,7 +2093,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 +3026,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)
@@ -4313,8 +4313,7 @@ If optional arg MOVE is non-nil move point to end of field."
(goto-char (bibtex-start-of-field bounds))
(forward-char) ; leading comma
(bibtex-delete-whitespace)
- (open-line 1)
- (forward-char)
+ (insert "\n")
(indent-to-column (+ bibtex-entry-offset
bibtex-field-indentation))
(re-search-forward "[ \t\n]*=" end-field)
@@ -4352,7 +4351,6 @@ column `bibtex-text-indentation' and continuation lines start here, too.
If `bibtex-align-at-equal-sign' is non-nil, align equal signs, too."
(interactive "*")
(let ((pnt (copy-marker (point)))
- (end (copy-marker (bibtex-end-of-entry)))
(beg (bibtex-beginning-of-entry)) ; move point
bounds)
(bibtex-delete-whitespace)
@@ -4364,8 +4362,7 @@ If `bibtex-align-at-equal-sign' is non-nil, align equal signs, too."
(forward-char))
(skip-chars-backward " \t\n")
(bibtex-delete-whitespace)
- (open-line 1)
- (forward-char)
+ (insert "\n")
(indent-to-column bibtex-entry-offset)
(goto-char pnt)))
diff --git a/lisp/textmodes/conf-mode.el b/lisp/textmodes/conf-mode.el
index 38df3b58a5f..4e6c8bd6b05 100644
--- a/lisp/textmodes/conf-mode.el
+++ b/lisp/textmodes/conf-mode.el
@@ -1,7 +1,6 @@
;;; conf-mode.el --- Simple major mode for editing conf/ini/properties files
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: Daniel Pfeiffer <occitan@esperanto.org>
;; Keywords: conf ini windows java
@@ -178,7 +177,7 @@ not align (only setting space according to `conf-assignment-space')."
(defvar conf-font-lock-keywords
- `(;; [section] (do this first because it may look like a parameter)
+ '(;; [section] (do this first because it may look like a parameter)
("^[ \t]*\\[\\(.+\\)\\]" 1 'font-lock-type-face)
;; var=val or var[index]=val
("^[ \t]*\\(.+?\\)\\(?:\\[\\(.*?\\)\\]\\)?[ \t]*="
@@ -621,5 +620,4 @@ For details see `conf-mode'. Example:
(provide 'conf-mode)
-;; arch-tag: 0a3805b2-0371-4d3a-8498-8897116b2356
;;; conf-mode.el ends here
diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el
index a0e9a06bd10..ef51fb25035 100644
--- a/lisp/textmodes/css-mode.el
+++ b/lisp/textmodes/css-mode.el
@@ -1,6 +1,6 @@
-;;; css-mode.el --- Major mode to edit CSS files
+;;; css-mode.el --- Major mode to edit CSS files -*- lexical-binding: t -*-
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: hypermedia
@@ -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."
@@ -477,5 +483,4 @@
(indent-line-to indent)))))
(provide 'css-mode)
-;; arch-tag: b4d8b8e2-b130-4e74-b3aa-cd8f1ab659d0
;;; css-mode.el ends here
diff --git a/lisp/textmodes/dns-mode.el b/lisp/textmodes/dns-mode.el
index dbd91817670..0d5d28f8e5d 100644
--- a/lisp/textmodes/dns-mode.el
+++ b/lisp/textmodes/dns-mode.el
@@ -1,7 +1,6 @@
;;; dns-mode.el --- a mode for viewing/editing Domain Name System master files
-;; Copyright (C) 2000, 2001, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2000-2001, 2004-2011 Free Software Foundation, Inc.
;; Author: Simon Josefsson <simon@josefsson.org>
;; Keywords: DNS master zone file SOA comm
@@ -28,11 +27,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 +216,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 19dd446420c..357b9d6c94e 100644
--- a/lisp/textmodes/enriched.el
+++ b/lisp/textmodes/enriched.el
@@ -1,7 +1,6 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1996, 2001-2011 Free Software Foundation, Inc.
;; Author: Boris Goldowsky <boris@gnu.org>
;; Keywords: wp, faces
@@ -50,7 +49,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)
@@ -165,6 +164,24 @@ The value is a list of \(VAR VALUE VAR VALUE...).")
(defvar enriched-rerun-flag nil)
;;;
+;;; Keybindings
+;;;
+
+(defvar enriched-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [remap move-beginning-of-line] 'beginning-of-line-text)
+ (define-key map "\C-m" 'reindent-then-newline-and-indent)
+ (define-key map
+ [remap newline-and-indent] 'reindent-then-newline-and-indent)
+ (define-key map "\M-j" 'facemenu-justification-menu)
+ (define-key map "\M-S" 'set-justification-center)
+ (define-key map "\C-x\t" 'increase-left-margin)
+ (define-key map "\C-c[" 'set-left-margin)
+ (define-key map "\C-c]" 'set-right-margin)
+ map)
+ "Keymap for Enriched mode.")
+
+;;;
;;; Define the mode
;;;
@@ -185,6 +202,8 @@ Commands:
:group 'enriched :lighter " Enriched"
(cond ((null enriched-mode)
;; Turn mode off
+ (remove-hook 'change-major-mode-hook
+ 'enriched-before-change-major-mode 'local)
(setq buffer-file-format (delq 'text/enriched buffer-file-format))
;; restore old variable values
(while enriched-old-bindings
@@ -200,6 +219,8 @@ Commands:
nil)
(t ; Turn mode on
+ (add-hook 'change-major-mode-hook
+ 'enriched-before-change-major-mode nil 'local)
(add-to-list 'buffer-file-format 'text/enriched)
;; Save old variable values before we change them.
;; These will be restored if we exit Enriched mode.
@@ -227,8 +248,6 @@ Commands:
(while enriched-old-bindings
(set (pop enriched-old-bindings) (pop enriched-old-bindings)))))
-(add-hook 'change-major-mode-hook 'enriched-before-change-major-mode)
-
(defun enriched-after-change-major-mode ()
(when enriched-mode
(let ((enriched-rerun-flag t))
@@ -236,30 +255,8 @@ Commands:
(add-hook 'after-change-major-mode-hook 'enriched-after-change-major-mode)
-;;;
-;;; Keybindings
-;;;
-
-(defvar enriched-mode-map nil
- "Keymap for Enriched mode.")
-
-(if (null enriched-mode-map)
- (fset 'enriched-mode-map (setq enriched-mode-map (make-sparse-keymap))))
-
-(if (not (assq 'enriched-mode minor-mode-map-alist))
- (setq minor-mode-map-alist
- (cons (cons 'enriched-mode enriched-mode-map)
- minor-mode-map-alist)))
-(define-key enriched-mode-map [remap move-beginning-of-line] 'beginning-of-line-text)
-(define-key enriched-mode-map "\C-m" 'reindent-then-newline-and-indent)
-(define-key enriched-mode-map
- [remap newline-and-indent] 'reindent-then-newline-and-indent)
-(define-key enriched-mode-map "\M-j" 'facemenu-justification-menu)
-(define-key enriched-mode-map "\M-S" 'set-justification-center)
-(define-key enriched-mode-map "\C-x\t" 'increase-left-margin)
-(define-key enriched-mode-map "\C-c[" 'set-left-margin)
-(define-key enriched-mode-map "\C-c]" 'set-right-margin)
+(fset 'enriched-mode-map enriched-mode-map)
;;;
;;; Some functions dealing with text-properties, especially indentation
@@ -502,5 +499,4 @@ the range of text to assign text property SYMBOL with value VALUE."
(message "Warning: invalid <x-display> parameter %s" param))
(list start end 'display prop)))
-;; arch-tag: 05cae488-3fea-45cd-ac29-5b02cb64e42b
;;; enriched.el ends here
diff --git a/lisp/textmodes/fill.el b/lisp/textmodes/fill.el
index 044806ef5b0..2b7e9a19baa 100644
--- a/lisp/textmodes/fill.el
+++ b/lisp/textmodes/fill.el
@@ -1,10 +1,11 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1986, 1992, 1994-1997, 1999, 2001-2011
+;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: wp
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -136,7 +137,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 +658,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 +1290,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 +1517,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 7b7787466f8..99c9a83e4fb 100644
--- a/lisp/textmodes/flyspell.el
+++ b/lisp/textmodes/flyspell.el
@@ -1,7 +1,6 @@
;;; flyspell.el --- on-the-fly spell checker
-;; Copyright (C) 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 2000-2011 Free Software Foundation, Inc.
;; Author: Manuel Serrano <Manuel.Serrano@sophia.inria.fr>
;; Maintainer: FSF
@@ -72,13 +71,23 @@ Detection of repeated words is not implemented in
:type 'boolean)
(defcustom flyspell-mark-duplications-exceptions
- '(("francais" . ("nous" "vous")))
+ '((nil . ("that" "had")) ; Common defaults for English.
+ ("\\`francais" . ("nous" "vous")))
"A list of exceptions for duplicated words.
-It should be a list of (LANGUAGE . EXCEPTION-LIST). LANGUAGE is matched
-against the current dictionary and EXCEPTION-LIST is a list of strings.
-The duplicated word is downcased before it is compared with the exceptions."
+It should be a list of (LANGUAGE . EXCEPTION-LIST).
+
+LANGUAGE is nil, which means the exceptions apply regardless of
+the current dictionary, or a regular expression matching the
+dictionary name (`ispell-local-dictionary' or
+`ispell-dictionary') for which the exceptions should apply.
+
+EXCEPTION-LIST is a list of strings. The checked word is
+downcased before comparing with these exceptions."
:group 'flyspell
- :type '(alist :key-type string :value-type (repeat string)))
+ :type '(alist :key-type (choice (const :tag "All dictionaries" nil)
+ string)
+ :value-type (repeat string))
+ :version "24.1")
(defcustom flyspell-sort-corrections nil
"Non-nil means, sort the corrections alphabetically before popping them."
@@ -199,9 +208,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 +389,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 +504,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 +1023,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
@@ -1042,12 +1054,14 @@ than preceding) word when the cursor is not over a word."
(not (memq (char-after (1- start)) '(?\} ?\\)))))
flyspell-mark-duplications-flag
(not (catch 'exception
- (dolist (except flyspell-mark-duplications-exceptions)
- (and (string= (or ispell-local-dictionary
- ispell-dictionary)
- (car except))
- (member (downcase word) (cdr except))
- (throw 'exception t)))))
+ (let ((dict (or ispell-local-dictionary
+ ispell-dictionary)))
+ (dolist (except flyspell-mark-duplications-exceptions)
+ (and (or (null (car except))
+ (and (stringp dict)
+ (string-match (car except) dict)))
+ (member (downcase word) (cdr except))
+ (throw 'exception t))))))
(save-excursion
(goto-char start)
(let* ((bound
@@ -1078,29 +1092,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 +1453,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 +1485,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 +1837,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 +2374,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 7feccde54ec..c196218feec 100644
--- a/lisp/textmodes/ispell.el
+++ b/lisp/textmodes/ispell.el
@@ -1,7 +1,6 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1995, 1997-2011 Free Software Foundation, Inc.
;; Author: Ken Stevens <k.stevens@ieee.org>
;; Maintainer: Ken Stevens <k.stevens@ieee.org>
@@ -221,10 +220,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 +309,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 +358,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 +515,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 +662,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 +740,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 +769,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 +964,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 +982,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 +1035,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 +1116,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 +1126,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 +1181,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 +1199,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 +1279,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 +1303,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 +1410,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 +1891,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 +2061,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 +2159,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,71 +2280,75 @@ 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))
(look-p (and ispell-look-p ; Only use look for an exact match.
(or ispell-have-new-look (not wild-p))))
- (ispell-grep-buffer (get-buffer-create "*Ispell-Temp*")) ; result buf
(prog (if look-p ispell-look-command ispell-grep-command))
(args (if look-p ispell-look-options ispell-grep-options))
status results loc)
- (unwind-protect
- (save-window-excursion
- (message "Starting \"%s\" process..." (file-name-nondirectory prog))
- (set-buffer ispell-grep-buffer)
- (if look-p
- nil
- ;; convert * to .*
- (insert "^" word "$")
- (while (search-backward "*" nil t) (insert "."))
- (setq word (buffer-string))
- (erase-buffer))
- (setq status (apply 'ispell-call-process prog nil t nil
- (nconc (if (and args (> (length args) 0))
- (list args)
- (if look-p nil
- (list "-e")))
- (list word)
- (if lookup-dict (list lookup-dict)))))
- ;; grep returns status 1 and no output when word not found, which
- ;; is a perfectly normal thing.
- (if (stringp status)
- (setq results (cons (format "error: %s exited with signal %s"
- (file-name-nondirectory prog) status)
- results))
- ;; else collect words into `results' in FIFO order
- (goto-char (point-max))
- ;; assure we've ended with \n
- (or (bobp) (= (preceding-char) ?\n) (insert ?\n))
- (while (not (bobp))
- (setq loc (point))
- (forward-line -1)
- (setq results (cons (buffer-substring-no-properties (point)
- (1- loc))
- results)))))
- ;; protected
- (kill-buffer ispell-grep-buffer)
- (if (and results (string-match ".+: " (car results)))
- (error "%s error: %s" ispell-grep-command (car results))))
+ (with-temp-buffer
+ (message "Starting \"%s\" process..." (file-name-nondirectory prog))
+ (if look-p
+ nil
+ ;; Convert * to .*
+ (insert "^" word "$")
+ (while (search-backward "*" nil t) (insert "."))
+ (setq word (buffer-string))
+ (erase-buffer))
+ (setq status (apply 'ispell-call-process prog nil t nil
+ (nconc (if (and args (> (length args) 0))
+ (list args)
+ (if look-p nil
+ (list "-e")))
+ (list word)
+ (if lookup-dict (list lookup-dict)))))
+ ;; `grep' returns status 1 and no output when word not found, which
+ ;; is a perfectly normal thing.
+ (if (stringp status)
+ (error "error: %s exited with signal %s"
+ (file-name-nondirectory prog) status)
+ ;; Else collect words into `results' in FIFO order.
+ (goto-char (point-max))
+ ;; Assure we've ended with \n.
+ (or (bobp) (= (preceding-char) ?\n) (insert ?\n))
+ (while (not (bobp))
+ (setq loc (point))
+ (forward-line -1)
+ (push (buffer-substring-no-properties (point)
+ (1- loc))
+ results))))
+ (if (and results (string-match ".+: " (car results)))
+ (error "%s error: %s" ispell-grep-command (car results)))
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 +2548,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 +2580,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 +2617,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 +2629,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 +2762,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 +2822,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 +2857,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 +2903,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 +2952,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 +3118,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 +3147,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 +3176,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 +3279,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 +3358,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 +3380,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 +3449,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 +3456,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 +3467,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 +3733,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 +3806,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 +3823,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 +3842,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 +3850,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 +3874,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 +3890,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,8 +3915,18 @@ 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))
- (if (> (length comment-end) 0)
+ (insert (if comment-start
+ (concat
+ (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 (and comment-end (> (length comment-end) 0))
(save-excursion
(newline)
(insert comment-end)))))
@@ -3918,5 +3971,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 951aa7271d3..4d701a9d268 100644
--- a/lisp/textmodes/makeinfo.el
+++ b/lisp/textmodes/makeinfo.el
@@ -1,7 +1,6 @@
;;; makeinfo.el --- run makeinfo conveniently
-;; Copyright (C) 1991, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1991, 1993, 2001-2011 Free Software Foundation, Inc.
;; Author: Robert J. Chassell
;; Maintainer: FSF
@@ -58,13 +57,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'."
@@ -289,5 +288,4 @@ line LINE of the window, or centered if LINE is nil."
;;; Place `provide' at end of file.
(provide 'makeinfo)
-;; arch-tag: 5f810713-3de2-4e20-8030-4bc3dd0d9604
;;; makeinfo.el ends here
diff --git a/lisp/textmodes/nroff-mode.el b/lisp/textmodes/nroff-mode.el
index 8c2751dc0ca..8fb0bd85dab 100644
--- a/lisp/textmodes/nroff-mode.el
+++ b/lisp/textmodes/nroff-mode.el
@@ -1,7 +1,7 @@
;;; nroff-mode.el --- GNU Emacs major mode for editing nroff source
-;; Copyright (C) 1985, 1986, 1994, 1995, 1997, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1986, 1994-1995, 1997, 2001-2011
+;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: wp
@@ -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")
@@ -310,5 +331,4 @@ turns it on if arg is positive, otherwise off."
(provide 'nroff-mode)
-;; arch-tag: 6e276340-6c65-4f65-b4e3-0ca431ddfb6c
;;; nroff-mode.el ends here
diff --git a/lisp/textmodes/page-ext.el b/lisp/textmodes/page-ext.el
index a12a81e89b9..6e73fda662b 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1991, 1993-1994, 2001-2011
+;; 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 a758a9ba998..95ba7ebd86f 100644
--- a/lisp/textmodes/page.el
+++ b/lisp/textmodes/page.el
@@ -1,10 +1,10 @@
;;; page.el --- page motion commands for Emacs
-;; Copyright (C) 1985, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: wp convenience
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -163,5 +163,4 @@ thus showing a page other than the one point was originally in."
;;; Place `provide' at end of file.
(provide 'page)
-;; arch-tag: e8d7a0bd-8655-4b6e-b852-f2ee25316a1d
;;; page.el ends here
diff --git a/lisp/textmodes/paragraphs.el b/lisp/textmodes/paragraphs.el
index 95ff1327b42..a0892b5ebba 100644
--- a/lisp/textmodes/paragraphs.el
+++ b/lisp/textmodes/paragraphs.el
@@ -1,11 +1,11 @@
;;; paragraphs.el --- paragraph and sentence parsing
-;; Copyright (C) 1985, 1986, 1987, 1991, 1994, 1995, 1996, 1997, 1999, 2000,
-;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+;; Copyright (C) 1985-1987, 1991, 1994-1997, 1999-2011
;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: wp
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -528,5 +528,4 @@ the current sentence with the one containing the mark."
;; coding: utf-8
;; End:
-;; arch-tag: e727eb1a-527a-4464-b9d7-9d3ec0d1a575
;;; paragraphs.el ends here
diff --git a/lisp/textmodes/picture.el b/lisp/textmodes/picture.el
index 029e75afde0..8148378cee3 100644
--- a/lisp/textmodes/picture.el
+++ b/lisp/textmodes/picture.el
@@ -1,7 +1,6 @@
;;; picture.el --- "Picture mode" -- editing using quarter-plane screen model
-;; Copyright (C) 1985, 1994, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1994, 2001-2011 Free Software Foundation, Inc.
;; Author: K. Shane Hartman
;; Maintainer: FSF
@@ -34,30 +33,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 +376,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 +451,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 +788,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/po.el b/lisp/textmodes/po.el
index fe3a2494589..7810cc6d57a 100644
--- a/lisp/textmodes/po.el
+++ b/lisp/textmodes/po.el
@@ -1,7 +1,6 @@
;;; po.el --- basic support of PO translation files -*- coding: latin-1; -*-
-;; Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-1998, 2000-2011 Free Software Foundation, Inc.
;; Authors: Franois Pinard <pinard@iro.umontreal.ca>,
;; Greg McGary <gkm@magilla.cichlid.com>,
@@ -131,5 +130,4 @@ Called through `file-coding-system-alist', before the file is visited for real."
(provide 'po)
-;; arch-tag: 56748a57-d64c-4200-8f6b-c3a70496eb8c
;;; po.el ends here
diff --git a/lisp/textmodes/refbib.el b/lisp/textmodes/refbib.el
index 611a1de5d0a..557978395c1 100644
--- a/lisp/textmodes/refbib.el
+++ b/lisp/textmodes/refbib.el
@@ -1,7 +1,6 @@
;;; refbib.el --- convert refer-style references to ones usable by Latex bib
-;; Copyright (C) 1989, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1989, 2001-2011 Free Software Foundation, Inc.
;; Author: Henry Kautz <kautz@research.att.com>
;; Maintainer: FSF
@@ -746,5 +745,4 @@ Please send bug reports and suggestions to
(provide 'refbib)
(provide 'refer-to-bibtex)
-;; arch-tag: 664afee2-6e76-4408-ba56-981d8a179586
;;; refbib.el ends here
diff --git a/lisp/textmodes/refer.el b/lisp/textmodes/refer.el
index 74823ed7172..7ee0fcf9da6 100644
--- a/lisp/textmodes/refer.el
+++ b/lisp/textmodes/refer.el
@@ -1,7 +1,6 @@
;;; refer.el --- look up references in bibliography files
-;; Copyright (C) 1992, 1996, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 1996, 2001-2011 Free Software Foundation, Inc.
;; Author: Ashwin Ram <ashwin@cc.gatech.edu>
;; Maintainer: Gernot Heiser <gernot@acm.org>
@@ -96,7 +95,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 +114,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 +122,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
@@ -396,5 +395,4 @@ found on the last `refer-find-entry' or `refer-find-next-entry'."
(setq refer-bib-files files))
files))
-;; arch-tag: 151f641b-e79b-462b-9a29-a95c3793f300
;;; refer.el ends here
diff --git a/lisp/textmodes/refill.el b/lisp/textmodes/refill.el
index 7e4570c399c..474872955b4 100644
--- a/lisp/textmodes/refill.el
+++ b/lisp/textmodes/refill.el
@@ -1,7 +1,6 @@
;;; refill.el --- `auto-fill' by refilling paragraphs on changes
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Author: Dave Love <fx@gnu.org>
;; Maintainer: Miles Bader <miles@gnu.org>
@@ -258,5 +257,4 @@ refilling if they would cause auto-filling."
(provide 'refill)
-;; arch-tag: 2c4ce9e8-1daa-4a3b-b6f8-fd6ac5bf6138
;;; refill.el ends here
diff --git a/lisp/textmodes/reftex-auc.el b/lisp/textmodes/reftex-auc.el
index 33a3e2e0d35..eba19c25ef6 100644
--- a/lisp/textmodes/reftex-auc.el
+++ b/lisp/textmodes/reftex-auc.el
@@ -1,11 +1,11 @@
;;; reftex-auc.el --- RefTeX's interface to AUCTeX
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2011 Free Software Foundation, Inc.
;; 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 +58,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)))
@@ -223,5 +223,4 @@ of ENTRY-LIST is a list of cons cells (\"MACRONAME\" . LEVEL). See
(defun reftex-notice-new-section ()
(reftex-notice-new 1 'force))
-;; arch-tag: 4a798e68-3405-421c-a09b-0269aac64ab4
;;; reftex-auc.el ends here
diff --git a/lisp/textmodes/reftex-cite.el b/lisp/textmodes/reftex-cite.el
index fd41d25590e..78d80da41ac 100644
--- a/lisp/textmodes/reftex-cite.el
+++ b/lisp/textmodes/reftex-cite.el
@@ -1,11 +1,11 @@
;;; reftex-cite.el --- creating citations with RefTeX
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2011 Free Software Foundation, Inc.
;; 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 +357,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 +1146,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
@@ -1171,5 +1173,4 @@ The sequence in the new file is the same as it was in the old database."
(length entries))))
-;; arch-tag: d53d0a5a-ab32-4b52-a846-2a7c3527cd89
;;; reftex-cite.el ends here
diff --git a/lisp/textmodes/reftex-dcr.el b/lisp/textmodes/reftex-dcr.el
index 1a0d18df699..9b924ba7ad9 100644
--- a/lisp/textmodes/reftex-dcr.el
+++ b/lisp/textmodes/reftex-dcr.el
@@ -1,11 +1,11 @@
;;; reftex-dcr.el --- viewing cross references and citations with RefTeX
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <dominik@science.uva.nl>
;; Maintainer: auctex-devel@gnu.org
;; Version: 4.31
+;; Package: reftex
;; This file is part of GNU Emacs.
@@ -34,7 +34,7 @@
(defun reftex-view-crossref (&optional arg auto-how fail-quietly)
"View cross reference of macro at point. Point must be on the KEY
-argument. When at at `\\ref' macro, show corresponding `\\label'
+argument. When at a `\\ref' macro, show corresponding `\\label'
definition, also in external documents (`xr'). When on a label, show
a locations where KEY is referenced. Subsequent calls find additional
locations. When on a `\\cite', show the associated `\\bibitem' macro or
@@ -481,5 +481,4 @@ Calling this function several times find successive citation locations."
(move-marker reftex-global-search-marker nil)
(error "All files processed"))))
-;; arch-tag: d2f52b56-744e-44ad-830d-1fc193b90eda
;;; reftex-dcr.el ends here
diff --git a/lisp/textmodes/reftex-global.el b/lisp/textmodes/reftex-global.el
index 111d52b2ec3..ccdab49750b 100644
--- a/lisp/textmodes/reftex-global.el
+++ b/lisp/textmodes/reftex-global.el
@@ -1,11 +1,11 @@
;;; reftex-global.el --- operations on entire documents with RefTeX
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <dominik@science.uva.nl>
;; Maintainer: auctex-devel@gnu.org
;; Version: 4.31
+;; Package: reftex
;; This file is part of GNU Emacs.
@@ -474,5 +474,4 @@ With no argument, this command toggles
(add-minor-mode 'reftex-isearch-minor-mode "/I" nil nil
'reftex-isearch-minor-mode)
-;; arch-tag: 2dbf7633-92c8-4340-8656-7aa019d0f80d
;;; reftex-global.el ends here
diff --git a/lisp/textmodes/reftex-index.el b/lisp/textmodes/reftex-index.el
index 6c37667c3f6..79df6135806 100644
--- a/lisp/textmodes/reftex-index.el
+++ b/lisp/textmodes/reftex-index.el
@@ -1,11 +1,11 @@
;;; reftex-index.el --- index support with RefTeX
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <dominik@science.uva.nl>
;; Maintainer: auctex-devel@gnu.org
;; Version: 4.31
+;; Package: reftex
;; This file is part of GNU Emacs.
@@ -274,8 +274,111 @@ will prompt for other arguments."
(and newtag (cdr cell) (not (member newtag (cdr cell)))
(push newtag (cdr cell)))))
-(defvar reftex-index-map (make-sparse-keymap)
+(defvar reftex-index-mode-map
+ (let ((map (make-sparse-keymap)))
+ ;; Index map
+ (define-key map (if (featurep 'xemacs) [(button2)] [(mouse-2)])
+ 'reftex-index-mouse-goto-line-and-hide)
+ (define-key map [follow-link] 'mouse-face)
+
+ (substitute-key-definition
+ 'next-line 'reftex-index-next map global-map)
+ (substitute-key-definition
+ 'previous-line 'reftex-index-previous map global-map)
+
+ (loop for x in
+ '(("n" . reftex-index-next)
+ ("p" . reftex-index-previous)
+ ("?" . reftex-index-show-help)
+ (" " . reftex-index-view-entry)
+ ("\C-m" . reftex-index-goto-entry-and-hide)
+ ("\C-i" . reftex-index-goto-entry)
+ ("\C-k" . reftex-index-kill)
+ ("r" . reftex-index-rescan)
+ ("R" . reftex-index-Rescan)
+ ("g" . revert-buffer)
+ ("q" . reftex-index-quit)
+ ("k" . reftex-index-quit-and-kill)
+ ("f" . reftex-index-toggle-follow)
+ ("s" . reftex-index-switch-index-tag)
+ ("e" . reftex-index-edit)
+ ("^" . reftex-index-level-up)
+ ("_" . reftex-index-level-down)
+ ("}" . reftex-index-restrict-to-section)
+ ("{" . reftex-index-widen)
+ (">" . reftex-index-restriction-forward)
+ ("<" . reftex-index-restriction-backward)
+ ("(" . reftex-index-toggle-range-beginning)
+ (")" . reftex-index-toggle-range-end)
+ ("|" . reftex-index-edit-attribute)
+ ("@" . reftex-index-edit-visual)
+ ("*" . reftex-index-edit-key)
+ ("\C-c=". reftex-index-goto-toc)
+ ("c" . reftex-index-toggle-context))
+ do (define-key map (car x) (cdr x)))
+
+ (loop for key across "0123456789" do
+ (define-key map (vector (list key)) 'digit-argument))
+ (define-key map "-" 'negative-argument)
+
+ ;; The capital letters and the exclamation mark
+ (loop for key across (concat "!" reftex-index-section-letters) do
+ (define-key map (vector (list key))
+ (list 'lambda '() '(interactive)
+ (list 'reftex-index-goto-letter key))))
+
+ (easy-menu-define reftex-index-menu map
+ "Menu for Index buffer"
+ '("Index"
+ ["Goto section A-Z"
+ (message "To go to a section, just press any of: !%s"
+ reftex-index-section-letters) t]
+ ["Show Entry" reftex-index-view-entry t]
+ ["Go To Entry" reftex-index-goto-entry t]
+ ["Exit & Go To Entry" reftex-index-goto-entry-and-hide t]
+ ["Table of Contents" reftex-index-goto-toc t]
+ ["Quit" reftex-index-quit t]
+ "--"
+ ("Update"
+ ["Rebuilt *Index* Buffer" revert-buffer t]
+ "--"
+ ["Rescan One File" reftex-index-rescan reftex-enable-partial-scans]
+ ["Rescan Entire Document" reftex-index-Rescan t])
+ ("Restrict"
+ ["Restrict to section" reftex-index-restrict-to-section t]
+ ["Widen" reftex-index-widen reftex-index-restriction-indicator]
+ ["Next Section" reftex-index-restriction-forward
+ reftex-index-restriction-indicator]
+ ["Previous Section" reftex-index-restriction-backward
+ reftex-index-restriction-indicator])
+ ("Edit"
+ ["Edit Entry" reftex-index-edit t]
+ ["Edit Key" reftex-index-edit-key t]
+ ["Edit Attribute" reftex-index-edit-attribute t]
+ ["Edit Visual" reftex-index-edit-visual t]
+ "--"
+ ["Add Parentkey" reftex-index-level-down t]
+ ["Remove Parentkey " reftex-index-level-up t]
+ "--"
+ ["Make Start-of-Range" reftex-index-toggle-range-beginning t]
+ ["Make End-of-Range" reftex-index-toggle-range-end t]
+ "--"
+ ["Kill Entry" reftex-index-kill nil]
+ "--"
+ ["Undo" reftex-index-undo nil])
+ ("Options"
+ ["Context" reftex-index-toggle-context :style toggle
+ :selected reftex-index-include-context]
+ "--"
+ ["Follow Mode" reftex-index-toggle-follow :style toggle
+ :selected reftex-index-follow-mode])
+ "--"
+ ["Help" reftex-index-show-help t]))
+
+ map)
"Keymap used for *Index* buffers.")
+(define-obsolete-variable-alias
+ 'reftex-index-map 'reftex-index-mode-map "24.1")
(defvar reftex-index-menu)
@@ -290,19 +393,14 @@ will prompt for other arguments."
(defvar reftex-index-restriction-indicator nil)
(defvar reftex-index-restriction-data nil)
-(defun reftex-index-mode ()
+(define-derived-mode reftex-index-mode fundamental-mode "RefTeX Index"
"Major mode for managing Index buffers for LaTeX files.
This buffer was created with RefTeX.
Press `?' for a summary of important key bindings, or check the menu.
Here are all local bindings.
-\\{reftex-index-map}"
- (interactive)
- (kill-all-local-variables)
- (setq major-mode 'reftex-index-mode
- mode-name "RefTeX Index")
- (use-local-map reftex-index-map)
+\\{reftex-index-mode-map}"
(set (make-local-variable 'revert-buffer-function) 'reftex-index-revert)
(set (make-local-variable 'reftex-index-restriction-data) nil)
(set (make-local-variable 'reftex-index-restriction-indicator) nil)
@@ -317,10 +415,9 @@ Here are all local bindings.
(make-local-hook 'post-command-hook)
(make-local-hook 'pre-command-hook))
(make-local-variable 'reftex-last-follow-point)
- (easy-menu-add reftex-index-menu reftex-index-map)
+ (easy-menu-add reftex-index-menu reftex-index-mode-map)
(add-hook 'post-command-hook 'reftex-index-post-command-hook nil t)
- (add-hook 'pre-command-hook 'reftex-index-pre-command-hook nil t)
- (run-hooks 'reftex-index-mode-hook))
+ (add-hook 'pre-command-hook 'reftex-index-pre-command-hook nil t))
(defconst reftex-index-help
" AVAILABLE KEYS IN INDEX BUFFER
@@ -1031,57 +1128,6 @@ When index is restricted, select the previous section as restriction criterion."
(setq reftex-last-follow-point 1)
(and message (message "%s" message))))
-;; Index map
-(define-key reftex-index-map (if (featurep 'xemacs) [(button2)] [(mouse-2)])
- 'reftex-index-mouse-goto-line-and-hide)
-(define-key reftex-index-map [follow-link] 'mouse-face)
-
-(substitute-key-definition
- 'next-line 'reftex-index-next reftex-index-map global-map)
-(substitute-key-definition
- 'previous-line 'reftex-index-previous reftex-index-map global-map)
-
-(loop for x in
- '(("n" . reftex-index-next)
- ("p" . reftex-index-previous)
- ("?" . reftex-index-show-help)
- (" " . reftex-index-view-entry)
- ("\C-m" . reftex-index-goto-entry-and-hide)
- ("\C-i" . reftex-index-goto-entry)
- ("\C-k" . reftex-index-kill)
- ("r" . reftex-index-rescan)
- ("R" . reftex-index-Rescan)
- ("g" . revert-buffer)
- ("q" . reftex-index-quit)
- ("k" . reftex-index-quit-and-kill)
- ("f" . reftex-index-toggle-follow)
- ("s" . reftex-index-switch-index-tag)
- ("e" . reftex-index-edit)
- ("^" . reftex-index-level-up)
- ("_" . reftex-index-level-down)
- ("}" . reftex-index-restrict-to-section)
- ("{" . reftex-index-widen)
- (">" . reftex-index-restriction-forward)
- ("<" . reftex-index-restriction-backward)
- ("(" . reftex-index-toggle-range-beginning)
- (")" . reftex-index-toggle-range-end)
- ("|" . reftex-index-edit-attribute)
- ("@" . reftex-index-edit-visual)
- ("*" . reftex-index-edit-key)
- ("\C-c=". reftex-index-goto-toc)
- ("c" . reftex-index-toggle-context))
- do (define-key reftex-index-map (car x) (cdr x)))
-
-(loop for key across "0123456789" do
- (define-key reftex-index-map (vector (list key)) 'digit-argument))
-(define-key reftex-index-map "-" 'negative-argument)
-
-;; The capital letters and the exclamation mark
-(loop for key across (concat "!" reftex-index-section-letters) do
- (define-key reftex-index-map (vector (list key))
- (list 'lambda '() '(interactive)
- (list 'reftex-index-goto-letter key))))
-
(defun reftex-index-goto-letter (char)
"Go to the CHAR section in the index."
(let ((pos (point))
@@ -1100,55 +1146,6 @@ When index is restricted, select the previous section as restriction criterion."
(error "This <%s> index does not contain entries starting with `%c'"
reftex-index-tag char)))))
-(easy-menu-define
- reftex-index-menu reftex-index-map
- "Menu for Index buffer"
- `("Index"
- ["Goto section A-Z"
- (message "To go to a section, just press any of: !%s"
- reftex-index-section-letters) t]
- ["Show Entry" reftex-index-view-entry t]
- ["Go To Entry" reftex-index-goto-entry t]
- ["Exit & Go To Entry" reftex-index-goto-entry-and-hide t]
- ["Table of Contents" reftex-index-goto-toc t]
- ["Quit" reftex-index-quit t]
- "--"
- ("Update"
- ["Rebuilt *Index* Buffer" revert-buffer t]
- "--"
- ["Rescan One File" reftex-index-rescan reftex-enable-partial-scans]
- ["Rescan Entire Document" reftex-index-Rescan t])
- ("Restrict"
- ["Restrict to section" reftex-index-restrict-to-section t]
- ["Widen" reftex-index-widen reftex-index-restriction-indicator]
- ["Next Section" reftex-index-restriction-forward
- reftex-index-restriction-indicator]
- ["Previous Section" reftex-index-restriction-backward
- reftex-index-restriction-indicator])
- ("Edit"
- ["Edit Entry" reftex-index-edit t]
- ["Edit Key" reftex-index-edit-key t]
- ["Edit Attribute" reftex-index-edit-attribute t]
- ["Edit Visual" reftex-index-edit-visual t]
- "--"
- ["Add Parentkey" reftex-index-level-down t]
- ["Remove Parentkey " reftex-index-level-up t]
- "--"
- ["Make Start-of-Range" reftex-index-toggle-range-beginning t]
- ["Make End-of-Range" reftex-index-toggle-range-end t]
- "--"
- ["Kill Entry" reftex-index-kill nil]
- "--"
- ["Undo" reftex-index-undo nil])
- ("Options"
- ["Context" reftex-index-toggle-context :style toggle
- :selected reftex-index-include-context]
- "--"
- ["Follow Mode" reftex-index-toggle-follow :style toggle
- :selected reftex-index-follow-mode])
- "--"
- ["Help" reftex-index-show-help t]))
-
;;----------------------------------------------------------------------
;; The Index Phrases File
@@ -1182,8 +1179,73 @@ This gets refreshed in every phrases command.")
"Font lock keywords for reftex-index-phrases-mode.")
(defvar reftex-index-phrases-font-lock-defaults nil
"Font lock defaults for reftex-index-phrases-mode.")
-(defvar reftex-index-phrases-map (make-sparse-keymap)
+(defvar reftex-index-phrases-mode-map
+ (let ((map (make-sparse-keymap)))
+ ;; Keybindings and Menu for phrases buffer
+ (loop for x in
+ '(("\C-c\C-c" . reftex-index-phrases-save-and-return)
+ ("\C-c\C-x" . reftex-index-this-phrase)
+ ("\C-c\C-f" . reftex-index-next-phrase)
+ ("\C-c\C-r" . reftex-index-region-phrases)
+ ("\C-c\C-a" . reftex-index-all-phrases)
+ ("\C-c\C-d" . reftex-index-remaining-phrases)
+ ("\C-c\C-s" . reftex-index-sort-phrases)
+ ("\C-c\C-n" . reftex-index-new-phrase)
+ ("\C-c\C-m" . reftex-index-phrases-set-macro-key)
+ ("\C-c\C-i" . reftex-index-phrases-info)
+ ("\C-c\C-t" . reftex-index-find-next-conflict-phrase)
+ ("\C-i" . self-insert-command))
+ do (define-key map (car x) (cdr x)))
+
+ (easy-menu-define reftex-index-phrases-menu map
+ "Menu for Phrases buffer"
+ '("Phrases"
+ ["New Phrase" reftex-index-new-phrase t]
+ ["Set Phrase Macro" reftex-index-phrases-set-macro-key t]
+ ["Recreate File Header" reftex-index-initialize-phrases-buffer t]
+ "--"
+ ("Sort Phrases"
+ ["Sort" reftex-index-sort-phrases t]
+ "--"
+ "Sort Options"
+ ["by Search Phrase" (setq reftex-index-phrases-sort-prefers-entry nil)
+ :style radio :selected (not reftex-index-phrases-sort-prefers-entry)]
+ ["by Index Entry" (setq reftex-index-phrases-sort-prefers-entry t)
+ :style radio :selected reftex-index-phrases-sort-prefers-entry]
+ ["in Blocks" (setq reftex-index-phrases-sort-in-blocks
+ (not reftex-index-phrases-sort-in-blocks))
+ :style toggle :selected reftex-index-phrases-sort-in-blocks])
+ ["Describe Phrase" reftex-index-phrases-info t]
+ ["Next Phrase Conflict" reftex-index-find-next-conflict-phrase t]
+ "--"
+ ("Find and Index in Document"
+ ["Current Phrase" reftex-index-this-phrase t]
+ ["Next Phrase" reftex-index-next-phrase t]
+ ["Current and Following" reftex-index-remaining-phrases t]
+ ["Region Phrases" reftex-index-region-phrases t]
+ ["All Phrases" reftex-index-all-phrases t]
+ "--"
+ "Options"
+ ["Match Whole Words" (setq reftex-index-phrases-search-whole-words
+ (not reftex-index-phrases-search-whole-words))
+ :style toggle :selected reftex-index-phrases-search-whole-words]
+ ["Case Sensitive Search" (setq reftex-index-phrases-case-fold-search
+ (not reftex-index-phrases-case-fold-search))
+ :style toggle :selected (not
+ reftex-index-phrases-case-fold-search)]
+ ["Wrap Long Lines" (setq reftex-index-phrases-wrap-long-lines
+ (not reftex-index-phrases-wrap-long-lines))
+ :style toggle :selected reftex-index-phrases-wrap-long-lines]
+ ["Skip Indexed Matches" (setq reftex-index-phrases-skip-indexed-matches
+ (not reftex-index-phrases-skip-indexed-matches))
+ :style toggle :selected reftex-index-phrases-skip-indexed-matches])
+ "--"
+ ["Save and Return" reftex-index-phrases-save-and-return t]))
+
+ map)
"Keymap used for *toc* buffer.")
+(define-obsolete-variable-alias
+ 'reftex-index-phrases-map 'reftex-index-phrases-mode-map "24.1")
(defun reftex-index-phrase-selection-or-word (arg)
@@ -1287,7 +1349,7 @@ If the buffer is non-empty, delete the old header first."
(defvar reftex-index-phrases-marker)
(defvar reftex-index-phrases-restrict-file nil)
;;;###autoload
-(defun reftex-index-phrases-mode ()
+(define-derived-mode reftex-index-phrases-mode fundamental-mode "Phrases"
"Major mode for managing the Index phrases of a LaTeX document.
This buffer was created with RefTeX.
@@ -1310,18 +1372,12 @@ For more information see the RefTeX User Manual.
Here are all local bindings.
-\\{reftex-index-phrases-map}"
- (interactive)
- (kill-all-local-variables)
- (setq major-mode 'reftex-index-phrases-mode
- mode-name "Phrases")
- (use-local-map reftex-index-phrases-map)
+\\{reftex-index-phrases-mode-map}"
(set (make-local-variable 'font-lock-defaults)
reftex-index-phrases-font-lock-defaults)
- (easy-menu-add reftex-index-phrases-menu reftex-index-phrases-map)
- (set (make-local-variable 'reftex-index-phrases-marker) (make-marker))
- (run-hooks 'reftex-index-phrases-mode-hook))
-(add-hook 'reftex-index-phrases-mode-hook 'turn-on-font-lock)
+ (easy-menu-add reftex-index-phrases-menu reftex-index-phrases-mode-map)
+ (set (make-local-variable 'reftex-index-phrases-marker) (make-marker)))
+;; (add-hook 'reftex-index-phrases-mode-hook 'turn-on-font-lock)
;; Font Locking stuff
(let ((ss (if (featurep 'xemacs) 'secondary-selection ''secondary-selection)))
@@ -1698,7 +1754,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))
@@ -2039,69 +2095,5 @@ Does not do a save-excursion."
reftex-index-phrases-macro-data "\n"))))
(reftex-select-with-char prompt help delay)))
-;; Keybindings and Menu for phrases buffer
-
-(loop for x in
- '(("\C-c\C-c" . reftex-index-phrases-save-and-return)
- ("\C-c\C-x" . reftex-index-this-phrase)
- ("\C-c\C-f" . reftex-index-next-phrase)
- ("\C-c\C-r" . reftex-index-region-phrases)
- ("\C-c\C-a" . reftex-index-all-phrases)
- ("\C-c\C-d" . reftex-index-remaining-phrases)
- ("\C-c\C-s" . reftex-index-sort-phrases)
- ("\C-c\C-n" . reftex-index-new-phrase)
- ("\C-c\C-m" . reftex-index-phrases-set-macro-key)
- ("\C-c\C-i" . reftex-index-phrases-info)
- ("\C-c\C-t" . reftex-index-find-next-conflict-phrase)
- ("\C-i" . self-insert-command))
- do (define-key reftex-index-phrases-map (car x) (cdr x)))
-
-(easy-menu-define
- reftex-index-phrases-menu reftex-index-phrases-map
- "Menu for Phrases buffer"
- '("Phrases"
- ["New Phrase" reftex-index-new-phrase t]
- ["Set Phrase Macro" reftex-index-phrases-set-macro-key t]
- ["Recreate File Header" reftex-index-initialize-phrases-buffer t]
- "--"
- ("Sort Phrases"
- ["Sort" reftex-index-sort-phrases t]
- "--"
- "Sort Options"
- ["by Search Phrase" (setq reftex-index-phrases-sort-prefers-entry nil)
- :style radio :selected (not reftex-index-phrases-sort-prefers-entry)]
- ["by Index Entry" (setq reftex-index-phrases-sort-prefers-entry t)
- :style radio :selected reftex-index-phrases-sort-prefers-entry]
- ["in Blocks" (setq reftex-index-phrases-sort-in-blocks
- (not reftex-index-phrases-sort-in-blocks))
- :style toggle :selected reftex-index-phrases-sort-in-blocks])
- ["Describe Phrase" reftex-index-phrases-info t]
- ["Next Phrase Conflict" reftex-index-find-next-conflict-phrase t]
- "--"
- ("Find and Index in Document"
- ["Current Phrase" reftex-index-this-phrase t]
- ["Next Phrase" reftex-index-next-phrase t]
- ["Current and Following" reftex-index-remaining-phrases t]
- ["Region Phrases" reftex-index-region-phrases t]
- ["All Phrases" reftex-index-all-phrases t]
- "--"
- "Options"
- ["Match Whole Words" (setq reftex-index-phrases-search-whole-words
- (not reftex-index-phrases-search-whole-words))
- :style toggle :selected reftex-index-phrases-search-whole-words]
- ["Case Sensitive Search" (setq reftex-index-phrases-case-fold-search
- (not reftex-index-phrases-case-fold-search))
- :style toggle :selected (not
- reftex-index-phrases-case-fold-search)]
- ["Wrap Long Lines" (setq reftex-index-phrases-wrap-long-lines
- (not reftex-index-phrases-wrap-long-lines))
- :style toggle :selected reftex-index-phrases-wrap-long-lines]
- ["Skip Indexed Matches" (setq reftex-index-phrases-skip-indexed-matches
- (not reftex-index-phrases-skip-indexed-matches))
- :style toggle :selected reftex-index-phrases-skip-indexed-matches])
- "--"
- ["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 47e1d2507e7..6ffbf7a4621 100644
--- a/lisp/textmodes/reftex-parse.el
+++ b/lisp/textmodes/reftex-parse.el
@@ -1,11 +1,11 @@
;;; reftex-parse.el --- parser functions for RefTeX
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2011 Free Software Foundation, Inc.
;; 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 +384,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 +774,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 +966,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))))))
@@ -1068,5 +1069,4 @@ of master file."
nrest (- nrest i))))
string))
-;; arch-tag: 6a8168f7-abb9-4576-99dc-fcbc7ba901a3
;;; reftex-parse.el ends here
diff --git a/lisp/textmodes/reftex-ref.el b/lisp/textmodes/reftex-ref.el
index c61a733092f..b47f2f6c2e9 100644
--- a/lisp/textmodes/reftex-ref.el
+++ b/lisp/textmodes/reftex-ref.el
@@ -1,11 +1,11 @@
;;; reftex-ref.el --- code to create labels and references with RefTeX
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2011 Free Software Foundation, Inc.
;; 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 +179,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 +226,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 +236,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 +293,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 +429,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 +451,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 +465,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 +476,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 +500,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 +548,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 +563,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 +689,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 +717,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 +783,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 +829,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 +846,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 eec15d2cb64..b4e15fd2776 100644
--- a/lisp/textmodes/reftex-sel.el
+++ b/lisp/textmodes/reftex-sel.el
@@ -1,11 +1,11 @@
;;; reftex-sel.el --- the selection modes for RefTeX
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <dominik@science.uva.nl>
;; Maintainer: auctex-devel@gnu.org
;; Version: 4.31
+;; Package: reftex
;; This file is part of GNU Emacs.
@@ -31,12 +31,81 @@
(require 'reftex)
;;;
-(defvar reftex-select-label-map nil
+;; Common bindings in reftex-select-label-mode-map
+;; and reftex-select-bib-mode-map.
+(defvar reftex-select-shared-map
+ (let ((map (make-sparse-keymap)))
+ (substitute-key-definition
+ 'next-line 'reftex-select-next map global-map)
+ (substitute-key-definition
+ 'previous-line 'reftex-select-previous map global-map)
+ (substitute-key-definition
+ 'keyboard-quit 'reftex-select-keyboard-quit map global-map)
+ (substitute-key-definition
+ 'newline 'reftex-select-accept map global-map)
+
+ (loop for x in
+ '((" " . reftex-select-callback)
+ ("n" . reftex-select-next)
+ ([(down)] . reftex-select-next)
+ ("p" . reftex-select-previous)
+ ([(up)] . reftex-select-previous)
+ ("f" . reftex-select-toggle-follow)
+ ("\C-m" . reftex-select-accept)
+ ([(return)] . reftex-select-accept)
+ ("q" . reftex-select-quit)
+ ("." . reftex-select-show-insertion-point)
+ ("?" . reftex-select-help))
+ do (define-key map (car x) (cdr x)))
+
+ ;; The mouse-2 binding
+ (if (featurep 'xemacs)
+ (define-key map [(button2)] 'reftex-select-mouse-accept)
+ (define-key map [(mouse-2)] 'reftex-select-mouse-accept)
+ (define-key map [follow-link] 'mouse-face))
+
+
+ ;; Digit arguments
+ (loop for key across "0123456789" do
+ (define-key map (vector (list key)) 'digit-argument))
+ (define-key map "-" 'negative-argument)
+ map))
+
+(defvar reftex-select-label-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map reftex-select-shared-map)
+
+ (loop for key across "aAcgFlrRstx#%" do
+ (define-key map (vector (list key))
+ (list 'lambda '()
+ "Press `?' during selection to find out about this key."
+ '(interactive) (list 'throw '(quote myexit) key))))
+
+ (loop for x in
+ '(("b" . reftex-select-jump-to-previous)
+ ("z" . reftex-select-jump)
+ ("v" . reftex-select-toggle-varioref)
+ ("V" . reftex-select-toggle-fancyref)
+ ("m" . reftex-select-mark)
+ ("u" . reftex-select-unmark)
+ ("," . reftex-select-mark-comma)
+ ("-" . reftex-select-mark-to)
+ ("+" . reftex-select-mark-and)
+ ([(tab)] . reftex-select-read-label)
+ ("\C-i" . reftex-select-read-label)
+ ("\C-c\C-n" . reftex-select-next-heading)
+ ("\C-c\C-p" . reftex-select-previous-heading))
+ do
+ (define-key map (car x) (cdr x)))
+
+ map)
"Keymap used for *RefTeX Select* buffer, when selecting a label.
This keymap can be used to configure the label selection process which is
started with the command \\[reftex-reference].")
+(define-obsolete-variable-alias
+ 'reftex-select-label-map 'reftex-select-label-mode-map "24.1")
-(defun reftex-select-label-mode ()
+(define-derived-mode reftex-select-label-mode fundamental-mode "LSelect"
"Major mode for selecting a label in a LaTeX document.
This buffer was created with RefTeX.
It only has a meaningful keymap when you are in the middle of a
@@ -46,28 +115,42 @@ Press `?' for a summary of important key bindings.
During a selection process, these are the local bindings.
-\\{reftex-select-label-map}"
-
- (interactive)
- (kill-all-local-variables)
+\\{reftex-select-label-mode-map}"
(when (featurep 'xemacs)
;; XEmacs needs the call to make-local-hook
(make-local-hook 'pre-command-hook)
(make-local-hook 'post-command-hook))
- (setq major-mode 'reftex-select-label-mode
- mode-name "LSelect")
(set (make-local-variable 'reftex-select-marked) nil)
(when (syntax-table-p reftex-latex-syntax-table)
(set-syntax-table reftex-latex-syntax-table))
;; We do not set a local map - reftex-select-item does this.
- (run-hooks 'reftex-select-label-mode-hook))
-
-(defvar reftex-select-bib-map nil
+ )
+
+(defvar reftex-select-bib-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map reftex-select-shared-map)
+
+ (loop for key across "grRaAeE" do
+ (define-key map (vector (list key))
+ (list 'lambda '()
+ "Press `?' during selection to find out about this key."
+ '(interactive) (list 'throw '(quote myexit) key))))
+
+ (loop for x in
+ '(("\C-i" . reftex-select-read-cite)
+ ([(tab)] . reftex-select-read-cite)
+ ("m" . reftex-select-mark)
+ ("u" . reftex-select-unmark))
+ do (define-key map (car x) (cdr x)))
+
+ map)
"Keymap used for *RefTeX Select* buffer, when selecting a BibTeX entry.
This keymap can be used to configure the BibTeX selection process which is
started with the command \\[reftex-citation].")
+(define-obsolete-variable-alias
+ 'reftex-select-bib-map 'reftex-select-bib-mode-map "24.1")
-(defun reftex-select-bib-mode ()
+(define-derived-mode reftex-select-bib-mode fundamental-mode "BSelect"
"Major mode for selecting a citation key in a LaTeX document.
This buffer was created with RefTeX.
It only has a meaningful keymap when you are in the middle of a
@@ -77,18 +160,14 @@ Press `?' for a summary of important key bindings.
During a selection process, these are the local bindings.
-\\{reftex-select-label-map}"
- (interactive)
- (kill-all-local-variables)
+\\{reftex-select-label-mode-map}"
(when (featurep 'xemacs)
;; XEmacs needs the call to make-local-hook
(make-local-hook 'pre-command-hook)
(make-local-hook 'post-command-hook))
- (setq major-mode 'reftex-select-bib-mode
- mode-name "BSelect")
(set (make-local-variable 'reftex-select-marked) nil)
;; We do not set a local map - reftex-select-item does this.
- (run-hooks 'reftex-select-bib-mode-hook))
+ )
;; (defun reftex-get-offset (buf here-am-I &optional typekey toc index file)
;; ;; Find the correct offset data, like insert-docstruct would, but faster.
@@ -368,22 +447,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 +481,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 +503,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 +524,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 +546,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 +607,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 +639,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 +648,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 +667,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)))))
@@ -655,85 +735,4 @@ Useful for large TOC's."
(princ help-string))
(reftex-enlarge-to-fit "*RefTeX Help*" t))
-;; Common bindings in reftex-select-label-map and reftex-select-bib-map
-(let ((map (make-sparse-keymap)))
- (substitute-key-definition
- 'next-line 'reftex-select-next map global-map)
- (substitute-key-definition
- 'previous-line 'reftex-select-previous map global-map)
- (substitute-key-definition
- 'keyboard-quit 'reftex-select-keyboard-quit map global-map)
- (substitute-key-definition
- 'newline 'reftex-select-accept map global-map)
-
- (loop for x in
- '((" " . reftex-select-callback)
- ("n" . reftex-select-next)
- ([(down)] . reftex-select-next)
- ("p" . reftex-select-previous)
- ([(up)] . reftex-select-previous)
- ("f" . reftex-select-toggle-follow)
- ("\C-m" . reftex-select-accept)
- ([(return)] . reftex-select-accept)
- ("q" . reftex-select-quit)
- ("." . reftex-select-show-insertion-point)
- ("?" . reftex-select-help))
- do (define-key map (car x) (cdr x)))
-
- ;; The mouse-2 binding
- (if (featurep 'xemacs)
- (define-key map [(button2)] 'reftex-select-mouse-accept)
- (define-key map [(mouse-2)] 'reftex-select-mouse-accept)
- (define-key map [follow-link] 'mouse-face))
-
-
- ;; Digit arguments
- (loop for key across "0123456789" do
- (define-key map (vector (list key)) 'digit-argument))
- (define-key map "-" 'negative-argument)
-
- ;; Make two maps
- (setq reftex-select-label-map map)
- (setq reftex-select-bib-map (copy-keymap map)))
-
-;; Specific bindings in reftex-select-label-map
-(loop for key across "aAcgFlrRstx#%" do
- (define-key reftex-select-label-map (vector (list key))
- (list 'lambda '()
- "Press `?' during selection to find out about this key."
- '(interactive) (list 'throw '(quote myexit) key))))
-
-(loop for x in
- '(("b" . reftex-select-jump-to-previous)
- ("z" . reftex-select-jump)
- ("v" . reftex-select-toggle-varioref)
- ("V" . reftex-select-toggle-fancyref)
- ("m" . reftex-select-mark)
- ("u" . reftex-select-unmark)
- ("," . reftex-select-mark-comma)
- ("-" . reftex-select-mark-to)
- ("+" . reftex-select-mark-and)
- ([(tab)] . reftex-select-read-label)
- ("\C-i" . reftex-select-read-label)
- ("\C-c\C-n" . reftex-select-next-heading)
- ("\C-c\C-p" . reftex-select-previous-heading))
- do
- (define-key reftex-select-label-map (car x) (cdr x)))
-
-;; Specific bindings in reftex-select-bib-map
-(loop for key across "grRaAeE" do
- (define-key reftex-select-bib-map (vector (list key))
- (list 'lambda '()
- "Press `?' during selection to find out about this key."
- '(interactive) (list 'throw '(quote myexit) key))))
-
-(loop for x in
- '(("\C-i" . reftex-select-read-cite)
- ([(tab)] . reftex-select-read-cite)
- ("m" . reftex-select-mark)
- ("u" . reftex-select-unmark))
- 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 1b72f6ca78d..5d691f456f7 100644
--- a/lisp/textmodes/reftex-toc.el
+++ b/lisp/textmodes/reftex-toc.el
@@ -1,11 +1,11 @@
;;; reftex-toc.el --- RefTeX's table of contents mode
-;; Copyright (C) 1997, 1998, 1999, 2000, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2000, 2003-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <dominik@science.uva.nl>
;; Maintainer: auctex-devel@gnu.org
;; Version: 4.31
+;; Package: reftex
;; This file is part of GNU Emacs.
@@ -31,8 +31,98 @@
(require 'reftex)
;;;
-(defvar reftex-toc-map (make-sparse-keymap)
+(defvar reftex-toc-mode-map
+ (let ((map (make-sparse-keymap)))
+
+ (define-key map (if (featurep 'xemacs) [(button2)] [(mouse-2)])
+ 'reftex-toc-mouse-goto-line-and-hide)
+ (define-key map [follow-link] 'mouse-face)
+
+ (substitute-key-definition
+ 'next-line 'reftex-toc-next map global-map)
+ (substitute-key-definition
+ 'previous-line 'reftex-toc-previous map global-map)
+
+ (loop for x in
+ '(("n" . reftex-toc-next)
+ ("p" . reftex-toc-previous)
+ ("?" . reftex-toc-show-help)
+ (" " . reftex-toc-view-line)
+ ("\C-m" . reftex-toc-goto-line-and-hide)
+ ("\C-i" . reftex-toc-goto-line)
+ ("\C-c>" . reftex-toc-display-index)
+ ("r" . reftex-toc-rescan)
+ ("R" . reftex-toc-Rescan)
+ ("g" . revert-buffer)
+ ("q" . reftex-toc-quit) ;
+ ("k" . reftex-toc-quit-and-kill)
+ ("f" . reftex-toc-toggle-follow) ;
+ ("a" . reftex-toggle-auto-toc-recenter)
+ ("d" . reftex-toc-toggle-dedicated-frame)
+ ("F" . reftex-toc-toggle-file-boundary)
+ ("i" . reftex-toc-toggle-index)
+ ("l" . reftex-toc-toggle-labels)
+ ("t" . reftex-toc-max-level)
+ ("c" . reftex-toc-toggle-context)
+ ;; ("%" . reftex-toc-toggle-commented)
+ ("\M-%" . reftex-toc-rename-label)
+ ("x" . reftex-toc-external)
+ ("z" . reftex-toc-jump)
+ ("." . reftex-toc-show-calling-point)
+ ("\C-c\C-n" . reftex-toc-next-heading)
+ ("\C-c\C-p" . reftex-toc-previous-heading)
+ (">" . reftex-toc-demote)
+ ("<" . reftex-toc-promote))
+ do (define-key map (car x) (cdr x)))
+
+ (loop for key across "0123456789" do
+ (define-key map (vector (list key)) 'digit-argument))
+ (define-key map "-" 'negative-argument)
+
+ (easy-menu-define
+ reftex-toc-menu map
+ "Menu for Table of Contents buffer"
+ '("TOC"
+ ["Show Location" reftex-toc-view-line t]
+ ["Go To Location" reftex-toc-goto-line t]
+ ["Exit & Go To Location" reftex-toc-goto-line-and-hide t]
+ ["Show Calling Point" reftex-toc-show-calling-point t]
+ ["Quit" reftex-toc-quit t]
+ "--"
+ ("Edit"
+ ["Promote" reftex-toc-promote t]
+ ["Demote" reftex-toc-demote t]
+ ["Rename Label" reftex-toc-rename-label t])
+ "--"
+ ["Index" reftex-toc-display-index t]
+ ["External Document TOC " reftex-toc-external t]
+ "--"
+ ("Update"
+ ["Rebuilt *toc* Buffer" revert-buffer t]
+ ["Rescan One File" reftex-toc-rescan reftex-enable-partial-scans]
+ ["Rescan Entire Document" reftex-toc-Rescan t])
+ ("Options"
+ "TOC Items"
+ ["File Boundaries" reftex-toc-toggle-file-boundary :style toggle
+ :selected reftex-toc-include-file-boundaries]
+ ["Labels" reftex-toc-toggle-labels :style toggle
+ :selected reftex-toc-include-labels]
+ ["Index Entries" reftex-toc-toggle-index :style toggle
+ :selected reftex-toc-include-index-entries]
+ ["Context" reftex-toc-toggle-context :style toggle
+ :selected reftex-toc-include-context]
+ "--"
+ ["Follow Mode" reftex-toc-toggle-follow :style toggle
+ :selected reftex-toc-follow-mode]
+ ["Auto Recenter" reftex-toggle-auto-toc-recenter :style toggle
+ :selected reftex-toc-auto-recenter-timer]
+ ["Dedicated Frame" reftex-toc-toggle-dedicated-frame t])
+ "--"
+ ["Help" reftex-toc-show-help t]))
+
+ map)
"Keymap used for *toc* buffer.")
+(define-obsolete-variable-alias 'reftex-toc-map 'reftex-toc-mode-map "24.1")
(defvar reftex-toc-menu)
(defvar reftex-last-window-height nil)
@@ -41,19 +131,14 @@
(defvar reftex-toc-include-index-indicator nil)
(defvar reftex-toc-max-level-indicator nil)
-(defun reftex-toc-mode ()
+(define-derived-mode reftex-toc-mode fundamental-mode "TOC"
"Major mode for managing Table of Contents for LaTeX files.
This buffer was created with RefTeX.
Press `?' for a summary of important key bindings.
Here are all local bindings.
-\\{reftex-toc-map}"
- (interactive)
- (kill-all-local-variables)
- (setq major-mode 'reftex-toc-mode
- mode-name "TOC")
- (use-local-map reftex-toc-map)
+\\{reftex-toc-mode-map}"
(set (make-local-variable 'transient-mark-mode) t)
(when (featurep 'xemacs)
(set (make-local-variable 'zmacs-regions) t))
@@ -78,8 +163,7 @@ Here are all local bindings.
(make-local-variable 'reftex-last-follow-point)
(add-hook 'post-command-hook 'reftex-toc-post-command-hook nil t)
(add-hook 'pre-command-hook 'reftex-toc-pre-command-hook nil t)
- (easy-menu-add reftex-toc-menu reftex-toc-map)
- (run-hooks 'reftex-toc-mode-hook))
+ (easy-menu-add reftex-toc-menu reftex-toc-mode-map))
(defvar reftex-last-toc-file nil
"Stores the file name from which `reftex-toc' was called. For redo command.")
@@ -544,8 +628,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 +656,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 +683,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 +712,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 +756,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 +767,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 +780,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))
@@ -1011,93 +1089,4 @@ always show the current section in connection with the option
(progn
(reftex-toggle-auto-toc-recenter))))
-;; Table of Contents map
-(define-key reftex-toc-map (if (featurep 'xemacs) [(button2)] [(mouse-2)])
- 'reftex-toc-mouse-goto-line-and-hide)
-(define-key reftex-toc-map [follow-link] 'mouse-face)
-
-(substitute-key-definition
- 'next-line 'reftex-toc-next reftex-toc-map global-map)
-(substitute-key-definition
- 'previous-line 'reftex-toc-previous reftex-toc-map global-map)
-
-(loop for x in
- '(("n" . reftex-toc-next)
- ("p" . reftex-toc-previous)
- ("?" . reftex-toc-show-help)
- (" " . reftex-toc-view-line)
- ("\C-m" . reftex-toc-goto-line-and-hide)
- ("\C-i" . reftex-toc-goto-line)
- ("\C-c>" . reftex-toc-display-index)
- ("r" . reftex-toc-rescan)
- ("R" . reftex-toc-Rescan)
- ("g" . revert-buffer)
- ("q" . reftex-toc-quit);
- ("k" . reftex-toc-quit-and-kill)
- ("f" . reftex-toc-toggle-follow);
- ("a" . reftex-toggle-auto-toc-recenter)
- ("d" . reftex-toc-toggle-dedicated-frame)
- ("F" . reftex-toc-toggle-file-boundary)
- ("i" . reftex-toc-toggle-index)
- ("l" . reftex-toc-toggle-labels)
- ("t" . reftex-toc-max-level)
- ("c" . reftex-toc-toggle-context)
-; ("%" . reftex-toc-toggle-commented)
- ("\M-%" . reftex-toc-rename-label)
- ("x" . reftex-toc-external)
- ("z" . reftex-toc-jump)
- ("." . reftex-toc-show-calling-point)
- ("\C-c\C-n" . reftex-toc-next-heading)
- ("\C-c\C-p" . reftex-toc-previous-heading)
- (">" . reftex-toc-demote)
- ("<" . reftex-toc-promote))
- do (define-key reftex-toc-map (car x) (cdr x)))
-
-(loop for key across "0123456789" do
- (define-key reftex-toc-map (vector (list key)) 'digit-argument))
-(define-key reftex-toc-map "-" 'negative-argument)
-
-(easy-menu-define
- reftex-toc-menu reftex-toc-map
- "Menu for Table of Contents buffer"
- '("TOC"
- ["Show Location" reftex-toc-view-line t]
- ["Go To Location" reftex-toc-goto-line t]
- ["Exit & Go To Location" reftex-toc-goto-line-and-hide t]
- ["Show Calling Point" reftex-toc-show-calling-point t]
- ["Quit" reftex-toc-quit t]
- "--"
- ("Edit"
- ["Promote" reftex-toc-promote t]
- ["Demote" reftex-toc-demote t]
- ["Rename Label" reftex-toc-rename-label t])
- "--"
- ["Index" reftex-toc-display-index t]
- ["External Document TOC " reftex-toc-external t]
- "--"
- ("Update"
- ["Rebuilt *toc* Buffer" revert-buffer t]
- ["Rescan One File" reftex-toc-rescan reftex-enable-partial-scans]
- ["Rescan Entire Document" reftex-toc-Rescan t])
- ("Options"
- "TOC Items"
- ["File Boundaries" reftex-toc-toggle-file-boundary :style toggle
- :selected reftex-toc-include-file-boundaries]
- ["Labels" reftex-toc-toggle-labels :style toggle
- :selected reftex-toc-include-labels]
- ["Index Entries" reftex-toc-toggle-index :style toggle
- :selected reftex-toc-include-index-entries]
- ["Context" reftex-toc-toggle-context :style toggle
- :selected reftex-toc-include-context]
- "--"
- ["Follow Mode" reftex-toc-toggle-follow :style toggle
- :selected reftex-toc-follow-mode]
- ["Auto Recenter" reftex-toggle-auto-toc-recenter :style toggle
- :selected reftex-toc-auto-recenter-timer]
- ["Dedicated Frame" reftex-toc-toggle-dedicated-frame t])
- "--"
- ["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 6e8e4d0b804..1b503c78afd 100644
--- a/lisp/textmodes/reftex-vars.el
+++ b/lisp/textmodes/reftex-vars.el
@@ -1,11 +1,11 @@
;;; reftex-vars.el --- configuration variables for RefTeX
-;; Copyright (C) 1997, 1998, 1999, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-1999, 2001-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <dominik@science.uva.nl>
;; Maintainer: auctex-devel@gnu.org
;; Version: 4.31
+;; Package: reftex
;; This file is part of GNU Emacs.
@@ -1916,5 +1916,4 @@ construct: \\bbb [xxx] {aaa}."
(provide 'reftex-vars)
-;; arch-tag: 9591ea34-ef39-4431-90b7-c115eaf5e16f
;;; reftex-vars.el ends here
diff --git a/lisp/textmodes/reftex.el b/lisp/textmodes/reftex.el
index 330c0834c76..7e150bff997 100644
--- a/lisp/textmodes/reftex.el
+++ b/lisp/textmodes/reftex.el
@@ -1,6 +1,5 @@
;;; reftex.el --- minor mode for doing \label, \ref, \cite, \index in LaTeX
-;; Copyright (C) 1997, 1998, 1999, 2000, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2000, 2003-2011 Free Software Foundation, Inc.
;; Author: Carsten Dominik <dominik@science.uva.nl>
;; Maintainer: auctex-devel@gnu.org
@@ -305,10 +304,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 +499,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 +532,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,30 +558,16 @@ 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."
;; Save the parsing information if it was modified.
;; This function should be installed in `kill-buffer-hook'.
- ;; We are careful to make sure nothing goes wring in this function.
+ ;; We are careful to make sure nothing goes wrong in this function.
(when (and (boundp 'reftex-mode) reftex-mode
(boundp 'reftex-save-parse-info) reftex-save-parse-info
(boundp 'reftex-docstruct-symbol) reftex-docstruct-symbol
@@ -619,17 +598,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.
@@ -2419,7 +2397,7 @@ IGNORE-WORDS List of words which should be removed from the string."
(define-key reftex-mode-map
reftex-extra-bindings-prefix
reftex-extra-bindings-map))
-
+
;;; =========================================================================
;;;
@@ -2590,7 +2568,8 @@ With optional NODE, go directly to that node."
;;; Install the kill-buffer and kill-emacs hooks ------------------------------
(add-hook 'kill-buffer-hook 'reftex-kill-buffer-hook)
-(add-hook 'kill-emacs-hook 'reftex-kill-emacs-hook)
+(unless noninteractive
+ (add-hook 'kill-emacs-hook 'reftex-kill-emacs-hook))
;;; Run Hook ------------------------------------------------------------------
@@ -2603,5 +2582,4 @@ With optional NODE, go directly to that node."
;;;============================================================================
-;; arch-tag: 49e0da4e-bd5e-4cfc-a717-fb444fccb9e6
;;; reftex.el ends here
diff --git a/lisp/textmodes/remember.el b/lisp/textmodes/remember.el
index 24e3764803f..1923ab692d8 100644
--- a/lisp/textmodes/remember.el
+++ b/lisp/textmodes/remember.el
@@ -1,7 +1,6 @@
;;; remember --- a mode for quickly jotting down things to remember
-;; Copyright (C) 1999, 2000, 2001, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2001, 2003-2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
;; Created: 29 Mar 1999
@@ -315,12 +314,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 +348,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 +527,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 4fc5d7185b3..b55146c2ff9 100644
--- a/lisp/textmodes/rst.el
+++ b/lisp/textmodes/rst.el
@@ -1,7 +1,6 @@
;;; rst.el --- Mode for viewing and editing reStructuredText-documents.
-;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2003-2011 Free Software Foundation, Inc.
;; Authors: Martin Blais <blais@furius.ca>,
;; Stefan Merten <smerten@oekonux.de>,
@@ -698,11 +697,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 +786,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 +867,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 +876,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 +907,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 +1034,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 +1388,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 +1452,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 +1499,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 +1623,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 +1774,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 +2044,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 +2293,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 +2373,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 +2408,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 +2446,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 +2523,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 +2568,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 +2842,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 +2868,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 +2946,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 +2966,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 +2974,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 +2987,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 +3001,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)))
)))
@@ -3201,16 +3233,37 @@ document with \\[rst-compile]."
:group 'rst
:version "21.1")
-(defvar rst-compile-toolsets
- '((html . ("rst2html.py" ".html" nil))
- (latex . ("rst2latex.py" ".tex" nil))
- (newlatex . ("rst2newlatex.py" ".tex" nil))
- (pseudoxml . ("rst2pseudoxml.py" ".xml" nil))
- (xml . ("rst2xml.py" ".xml" nil)))
+(defcustom rst-compile-toolsets
+ `((html ,(if (executable-find "rst2html.py") "rst2html.py" "rst2html")
+ ".html" nil)
+ (latex ,(if (executable-find "rst2latex.py") "rst2latex.py" "rst2latex")
+ ".tex" nil)
+ (newlatex ,(if (executable-find "rst2newlatex.py") "rst2newlatex.py"
+ "rst2newlatex")
+ ".tex" nil)
+ (pseudoxml ,(if (executable-find "rst2pseudoxml.py") "rst2pseudoxml.py"
+ "rst2pseudoxml")
+ ".xml" nil)
+ (xml ,(if (executable-find "rst2xml.py") "rst2xml.py" "rst2xml")
+ ".xml" nil)
+ (pdf ,(if (executable-find "rst2pdf.py") "rst2pdf.py" "rst2pdf")
+ ".pdf" nil)
+ (s5 ,(if (executable-find "rst2s5.py") "rst2s5.py" "rst2s5")
+ ".html" nil))
"Table describing the command to use for each toolset.
An association list of the toolset to a list of the (command to use,
extension of produced filename, options to the tool (nil or a
-string)) to be used for converting the document.")
+string)) to be used for converting the document."
+ :type '(alist :options (html latex newlatex pseudoxml xml pdf s5)
+ :key-type symbol
+ :value-type (list :tag "Specification"
+ (file :tag "Command")
+ (string :tag "File extension")
+ (choice :tag "Command options"
+ (const :tag "No options" nil)
+ (string :tag "Options"))))
+ :group 'rst
+ :version "24.1")
;; Note for Python programmers not familiar with association lists: you can set
;; values in an alists like this, e.g. :
@@ -3298,7 +3351,7 @@ or of the entire buffer, if the region is not selected."
(shell-command-on-region
(if mark-active (region-beginning) (point-min))
(if mark-active (region-end) (point-max))
- "rst2pseudoxml.py"
+ (cadr (assq 'pseudoxml rst-compile-toolsets))
standard-output)))
(defvar rst-pdf-program "xpdf"
@@ -3308,7 +3361,8 @@ or of the entire buffer, if the region is not selected."
"Convert the document to a PDF file and launch a preview program."
(interactive)
(let* ((tmp-filename (make-temp-file "rst-out" nil ".pdf"))
- (command (format "rst2pdf.py %s %s && %s %s"
+ (command (format "%s %s %s && %s %s"
+ (cadr (assq 'pdf rst-compile-toolsets))
buffer-file-name tmp-filename
rst-pdf-program tmp-filename)))
(start-process-shell-command "rst-pdf-preview" nil command)
@@ -3323,7 +3377,8 @@ or of the entire buffer, if the region is not selected."
"Convert the document to an S5 slide presentation and launch a preview program."
(interactive)
(let* ((tmp-filename (make-temp-file "rst-slides" nil ".html"))
- (command (format "rst2s5.py %s %s && %s %s"
+ (command (format "%s %s %s && %s %s"
+ (cadr (assq 's5 rst-compile-toolsets))
buffer-file-name tmp-filename
rst-slides-program tmp-filename)))
(start-process-shell-command "rst-slides-preview" nil command)
@@ -3421,11 +3476,10 @@ column is used (fill-column vs. end of previous/next line)."
"A portable function that returns non-nil if the mark is active."
(cond
((fboundp 'region-active-p) (region-active-p))
- ((boundp 'transient-mark-mode) transient-mark-mode mark-active)))
-
+ ((boundp 'transient-mark-mode) (and transient-mark-mode mark-active))
+ (t mark-active)))
(provide 'rst)
-;; arch-tag: 255ac0a3-a689-44cb-8643-04ca55ae490d
;;; rst.el ends here
diff --git a/lisp/textmodes/sgml-mode.el b/lisp/textmodes/sgml-mode.el
index 2338c47d454..314fbf9671b 100644
--- a/lisp/textmodes/sgml-mode.el
+++ b/lisp/textmodes/sgml-mode.el
@@ -1,7 +1,7 @@
;;; sgml-mode.el --- SGML- and HTML-editing modes -*- coding: utf-8 -*-
-;; Copyright (C) 1992, 1995, 1996, 1998, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 1995-1996, 1998, 2001-2011
+;; Free Software Foundation, Inc.
;; Author: James Clark <jjc@jclark.com>
;; Maintainer: FSF
@@ -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
@@ -377,6 +384,9 @@ a DOCTYPE or an XML declaration."
(save-excursion
(goto-char (point-min))
(or (string= "xml" (file-name-extension (or buffer-file-name "")))
+ ;; Maybe the buffer-size check isn't needed, I don't know.
+ (and (zerop (buffer-size))
+ (string= "xhtml" (file-name-extension (or buffer-file-name ""))))
(looking-at "\\s-*<\\?xml")
(when (re-search-forward
(eval-when-compile
@@ -417,7 +427,12 @@ a DOCTYPE or an XML declaration."
(format-mode-line mode-name))))))
(defun sgml-fill-nobreak ()
- ;; Don't break between a tag name and its first argument.
+ "Don't break between a tag name and its first argument.
+This function is designed for use in `fill-nobreak-predicate'.
+
+ <a href=\"some://where\" type=\"text/plain\">
+ ^ ^
+ | no break here | but still allowed here"
(save-excursion
(skip-chars-backward " \t")
(and (not (zerop (skip-syntax-backward "w_")))
@@ -472,9 +487,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 +536,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 +593,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 +611,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 +717,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 +1127,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)))
@@ -2146,5 +2161,4 @@ Can be used as a value for `html-mode-hook'."
(provide 'sgml-mode)
-;; arch-tag: 9675da94-b7f9-4bda-ad19-73ed7b4fb401
;;; sgml-mode.el ends here
diff --git a/lisp/textmodes/table.el b/lisp/textmodes/table.el
index 9d3c5001d0b..2dc4e4a88b1 100644
--- a/lisp/textmodes/table.el
+++ b/lisp/textmodes/table.el
@@ -1,12 +1,10 @@
;;; table.el --- create and edit WYSIWYG text based embedded tables
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Keywords: wp, convenience
;; Author: Takaaki Ota <Takaaki.Ota@am.sony.com>
;; Created: Sat Jul 08 2000 13:28:45 (PST)
-;; Revised: Fri Aug 21 2009 00:16:58 (PDT)
;; This file is part of GNU Emacs.
@@ -640,14 +638,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 +649,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 +663,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 +672,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 +683,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 +725,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 +740,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 +750,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 +789,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 +820,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 +858,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 +917,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 +946,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 +5056,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 +5094,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 +5588,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 b33928bff42..428fc1db3a9 100644
--- a/lisp/textmodes/tex-mode.el
+++ b/lisp/textmodes/tex-mode.el
@@ -1,7 +1,6 @@
;;; tex-mode.el --- TeX, LaTeX, and SliTeX mode commands -*- coding: utf-8 -*-
-;; Copyright (C) 1985, 1986, 1989, 1992, 1994, 1995, 1996, 1997, 1998
-;; 1999, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+;; Copyright (C) 1985-1986, 1989, 1992, 1994-1999, 2001-2011
;; Free Software Foundation, Inc.
;; Maintainer: FSF
@@ -58,14 +57,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 +83,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 +92,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 +106,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 +114,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 +122,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 +132,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 +156,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 +171,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 +179,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 +202,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 +213,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 +229,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 +326,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 +487,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 +637,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 +787,35 @@ 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))
- ;; Do nothing if the \verb construct is itself inside a comment or
- ;; verbatim env.
- (save-excursion
- ;; 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' ?
+(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.
+ (unless (nth 8 (save-excursion (syntax-ppss start)))
+ ;; Let's find the end and mark it.
+ (let ((afterdelim (point)))
+ (skip-chars-forward (string ?^ delim) (line-end-position))
+ (if (eolp)
+ ;; "LaTeX Error: \verb ended by end of line."
+ ;; Remove the syntax-table property we've just put on the
+ ;; start-delimiter, so it doesn't spill over subsequent lines.
+ (put-text-property (1- afterdelim) afterdelim
+ 'syntax-table nil)
(when (eq (char-syntax (preceding-char)) ?/)
- (put-text-property (1- (point)) (point) 'syntax-table '(1)))
- (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))
- )))
- "\""))
+ (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 +863,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 +1219,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.
@@ -1752,11 +1812,70 @@ Mark is left at original location."
;; Why use a shell instead of running TeX directly? Because if TeX
;; gets stuck, the user can switch to the shell window and type at it.
+(defvar tex-error-parse-syntax-table
+ (let ((st (make-syntax-table)))
+ (modify-syntax-entry ?\( "()" st)
+ (modify-syntax-entry ?\) ")(" st)
+ (modify-syntax-entry ?\\ "\\" st)
+ (modify-syntax-entry ?\{ "_" st)
+ (modify-syntax-entry ?\} "_" st)
+ (modify-syntax-entry ?\[ "_" st)
+ (modify-syntax-entry ?\] "_" st)
+ ;; Single quotations may appear in errors
+ (modify-syntax-entry ?\" "_" st)
+ st)
+ "Syntax-table used while parsing TeX error messages.")
+
+(defun tex-old-error-file-name ()
+ ;; This is unreliable, partly because we don't try very hard, and
+ ;; partly because TeX's output format is eminently ambiguous and unfriendly
+ ;; to automation.
+ (save-excursion
+ (save-match-data
+ (with-syntax-table tex-error-parse-syntax-table
+ (beginning-of-line)
+ (backward-up-list 1)
+ (skip-syntax-forward "(_")
+ (while (not (let ((try-filename (thing-at-point 'filename)))
+ (and try-filename
+ (not (string= "" try-filename))
+ (file-readable-p try-filename))))
+ (skip-syntax-backward "(_")
+ (backward-up-list 1)
+ (skip-syntax-forward "(_"))
+ (thing-at-point 'filename)))))
+
+(defconst tex-error-regexp-alist
+ ;; First alternative handles the newer --file-line-error style:
+ ;; ./test2.tex:14: Too many }'s.
+ '(gnu
+ ;; Second handles the old-style, which spans two lines but doesn't include
+ ;; any file info:
+ ;; ! Too many }'s.
+ ;; l.396 toto}
+ ("^l\\.\\([1-9][0-9]*\\) \\(?:\\.\\.\\.\\)?\\(.*\\)$"
+ tex-old-error-file-name 1 nil nil nil
+ ;; Since there's no filename to highlight, let's highlight the message.
+ (2 compilation-error-face))
+ ;; A few common warning messages.
+ ("^\\(?:Und\\|Ov\\)erfull \\\\[hv]box .* at lines? \\(\\([1-9][0-9]*\\)\\(?:--\\([1-9][0-9]*\\)\\)?\\)$"
+ tex-old-error-file-name (2 . 3) nil 1 nil
+ (1 compilation-warning-face))
+ ("^(Font) *\\([^ \n].* on input line \\([1-9][0-9]*\\)\\)\\.$"
+ tex-old-error-file-name 2 nil 1 1
+ (2 compilation-warning-face))
+ ;; Included files get output as (<file> ...).
+ ;; FIXME: there tend to be a crapload of them at the beginning of the
+ ;; output which aren't that interesting. Maybe we should filter out
+ ;; all the file name that start with /usr/share?
+ ;; ("(\\.?/\\([^() \n]+\\)" 1 nil nil 0)
+ ))
+
;; The utility functions:
(define-derived-mode tex-shell shell-mode "TeX-Shell"
- (set (make-local-variable 'compilation-parse-errors-function)
- 'tex-compilation-parse-errors)
+ (set (make-local-variable 'compilation-error-regexp-alist)
+ tex-error-regexp-alist)
(compilation-shell-minor-mode t))
;;;###autoload
@@ -2254,113 +2373,6 @@ Only applies the FSPEC to the args part of FORMAT."
(tex-display-shell)
(setq tex-last-buffer-texed (current-buffer)))
-(defvar tex-error-parse-syntax-table
- (let ((st (make-syntax-table)))
- (modify-syntax-entry ?\( "()" st)
- (modify-syntax-entry ?\) ")(" st)
- (modify-syntax-entry ?\\ "\\" st)
- (modify-syntax-entry ?\{ "_" st)
- (modify-syntax-entry ?\} "_" st)
- (modify-syntax-entry ?\[ "_" st)
- (modify-syntax-entry ?\] "_" st)
- ;; Single quotations may appear in errors
- (modify-syntax-entry ?\" "_" st)
- st)
- "Syntax-table used while parsing TeX error messages.")
-
-(defun tex-compilation-parse-errors (limit-search find-at-least)
- "Parse the current buffer as TeX error messages.
-See the variable `compilation-parse-errors-function' for the interface it uses.
-
-This function parses only the last TeX compilation.
-It works on TeX compilations only. It is necessary for that purpose,
-since TeX does not put file names and line numbers on the same line as
-for the error messages."
- (require 'thingatpt)
- (setq compilation-error-list nil)
- (let ((default-directory ; Perhaps dir has changed meanwhile.
- (file-name-directory (buffer-file-name tex-last-buffer-texed)))
- found-desired (num-errors-found 0)
- last-filename last-linenum last-position
- begin-of-error end-of-error errfilename)
- ;; Don't reparse messages already seen at last parse.
- (goto-char compilation-parsing-end)
- ;; Parse messages.
- (while (and (not (or found-desired (eobp)))
- ;; First alternative handles the newer --file-line-error style:
- ;; ./test2.tex:14: Too many }'s.
- ;; Second handles the old-style:
- ;; ! Too many }'s.
- (prog1 (re-search-forward
- "^\\(?:\\([^:\n]+\\):[[:digit:]]+:\\|!\\) " nil 'move)
- (setq begin-of-error (match-beginning 0)
- end-of-error (match-end 0)
- errfilename (match-string 1)))
- (re-search-forward
- "^l\\.\\([0-9]+\\) \\(\\.\\.\\.\\)?\\(.*\\)$" nil 'move))
- (let* ((this-error (copy-marker begin-of-error))
- (linenum (string-to-number (match-string 1)))
- (error-text (regexp-quote (match-string 3)))
- try-filename
- (filename
- ;; Prefer --file-liner-error filename if we have it.
- (or errfilename
- (save-excursion
- (with-syntax-table tex-error-parse-syntax-table
- (backward-up-list 1)
- (skip-syntax-forward "(_")
- (while (not
- (and (setq try-filename (thing-at-point
- 'filename))
- (not (string= "" try-filename))
- (file-readable-p try-filename)))
- (skip-syntax-backward "(_")
- (backward-up-list 1)
- (skip-syntax-forward "(_"))
- (thing-at-point 'filename)))))
- (new-file
- (or (null last-filename)
- (not (string-equal last-filename filename))))
- (error-location
- (with-current-buffer
- (if (equal filename (concat tex-zap-file ".tex"))
- tex-last-buffer-texed
- (find-file-noselect filename))
- (save-excursion
- (if new-file
- (progn
- (goto-char (point-min))
- (forward-line (1- linenum))
- (setq last-position nil))
- (goto-char last-position)
- (forward-line (- linenum last-linenum)))
- ;; first try a forward search for the error text,
- ;; then a backward search limited by the last error.
- (let ((starting-point (point)))
- (or (re-search-forward error-text nil t)
- (re-search-backward error-text last-position t)
- (goto-char starting-point)))
- (point-marker)))))
- (goto-char this-error)
- (if (and compilation-error-list
- (or (and find-at-least
- (>= num-errors-found
- find-at-least))
- (and limit-search
- (>= end-of-error limit-search)))
- new-file)
- (setq found-desired t)
- (setq num-errors-found (1+ num-errors-found)
- last-filename filename
- last-linenum linenum
- last-position error-location
- compilation-error-list ; Add the new error
- (cons (cons this-error error-location)
- compilation-error-list))
- (goto-char end-of-error)))))
- (set-marker compilation-parsing-end (point))
- (setq compilation-error-list (nreverse compilation-error-list)))
-
;;; The commands:
(defun tex-region (beg end)
@@ -2807,15 +2819,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 +2839,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,16 +2858,15 @@ 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)
(provide 'tex-mode)
-;; arch-tag: c0a680b1-63aa-4547-84b9-4193c29c0080
;;; tex-mode.el ends here
diff --git a/lisp/textmodes/texinfmt.el b/lisp/textmodes/texinfmt.el
index 3dea075a8c1..d33cbb97dd8 100644
--- a/lisp/textmodes/texinfmt.el
+++ b/lisp/textmodes/texinfmt.el
@@ -1,8 +1,7 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1986, 1988, 1990-1998, 2000-2011
+;; Free Software Foundation, Inc.
;; Maintainer: Robert J. Chassell <bug-texinfo@gnu.org>
;; Keywords: maint, tex, docs
@@ -224,7 +223,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 +284,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 +322,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 +662,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 +771,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 +944,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 +1504,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 +1689,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 +2129,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 +2406,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 +2450,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 +2502,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 +2835,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 +4297,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 b3d252abe24..7e9ce9aff6d 100644
--- a/lisp/textmodes/texinfo.el
+++ b/lisp/textmodes/texinfo.el
@@ -1,7 +1,6 @@
;;; texinfo.el --- major mode for editing Texinfo files -*- coding: utf-8 -*-
-;; Copyright (C) 1985, 1988, 1989, 1990, 1991, 1992, 1993, 1996, 1997,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+;; Copyright (C) 1985, 1988-1993, 1996-1997, 2000-2011
;; Free Software Foundation, Inc.
;; Author: Robert J. Chassell
@@ -310,19 +309,21 @@ 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
'("cartouche" "copying" "defcv" "deffn" "defivar" "defmac"
- "defmethod" "defop" "defopt" "defspec" "deftp" "deftypefn"
- "deftypefun" "deftypevar" "deftypevr" "defun" "defvar"
+ "defmethod" "defop" "defopt" "defspec" "deftp" "deftypecv"
+ "deftypefn" "deftypefun" "deftypeivar" "deftypemethod"
+ "deftypeop" "deftypevar" "deftypevr" "defun" "defvar"
"defvr" "description" "detailmenu" "direntry" "display"
"documentdescription" "enumerate" "example" "flushleft"
- "flushright" "format" "ftable" "group" "ifclear" "ifset"
+ "flushright" "format" "ftable" "group" "html" "ifclear" "ifset"
"ifhtml" "ifinfo" "ifnothtml" "ifnotinfo" "ifnotplaintext"
"ifnottex" "ifplaintext" "iftex" "ignore" "itemize" "lisp"
"macro" "menu" "multitable" "quotation" "smalldisplay"
@@ -442,7 +443,9 @@ Subexpression 1 is what goes into the corresponding `@end' statement.")
(define-key map "\C-c\C-s" 'texinfo-show-structure)
(define-key map "\C-c}" 'up-list)
+ ;; FIXME: This is often used for "close block" aka texinfo-insert-@end.
(define-key map "\C-c]" 'up-list)
+ (define-key map "\C-c/" 'texinfo-insert-@end)
(define-key map "\C-c{" 'texinfo-insert-braces)
;; bindings for inserting strings
@@ -582,11 +585,8 @@ value of `texinfo-mode-hook'."
(concat "\b\\|@[a-zA-Z]*[ \n]\\|" paragraph-separate))
(make-local-variable 'paragraph-start)
(setq paragraph-start (concat "\b\\|@[a-zA-Z]*[ \n]\\|" paragraph-start))
- (make-local-variable 'sentence-end-base)
- (setq sentence-end-base
+ (set (make-local-variable 'sentence-end-base)
"\\(@\\(end\\)?dots{}\\|[.?!]\\)[]\"'”)}]*")
- (make-local-variable 'adaptive-fill-mode)
- (setq adaptive-fill-mode nil)
(make-local-variable 'fill-column)
(setq fill-column 70)
(make-local-variable 'comment-start)
@@ -600,9 +600,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.
@@ -645,7 +645,13 @@ Puts point on a blank line between them."
(completing-read (format "Block name [%s]: " texinfo-block-default)
texinfo-environments
nil nil nil nil texinfo-block-default))
- \n "@" str \n _ \n "@end " str \n)
+ \n "@" str
+ ;; Blocks that take parameters: all the def* blocks take parameters,
+ ;; plus a few others.
+ (if (or (string-match "\\`def" str)
+ (member str '("table" "ftable" "vtable")))
+ '(nil " " -))
+ \n _ \n "@end " str \n)
(defun texinfo-inside-macro-p (macro &optional bound)
"Non-nil if inside a macro matching the regexp MACRO."
@@ -716,163 +722,131 @@ With prefix argument or inside @code or @example, inserts a plain \"."
(not (looking-at "@end"))))
(texinfo-next-unmatched-end)))
-(defun texinfo-insert-@end ()
+(define-skeleton texinfo-insert-@end
"Insert the matching `@end' for the last Texinfo command that needs one."
- (interactive)
- (let ((string
(ignore-errors
(save-excursion
+ (backward-word 1)
(texinfo-last-unended-begin)
- (match-string 1)))))
- (insert "@end ")
- (if string (insert string "\n"))))
-
-;; The following insert commands accept a prefix arg N, which is the
-;; number of words (actually s-exprs) that should be surrounded by
-;; braces. Thus you can first paste a variable name into a .texinfo
-;; buffer, then say C-u 1 C-c C-c v at the beginning of the just
-;; pasted variable name to put @var{...} *around* the variable name.
-;; Operate on previous word or words with negative arg.
-
-;; These commands use texinfo-insert-@-with-arg
-(defun texinfo-insert-@-with-arg (string &optional arg)
- (if arg
- (progn
- (setq arg (prefix-numeric-value arg))
- (if (< arg 0)
- (progn
- (skip-chars-backward " \t\n\r\f")
- (save-excursion
- (forward-sexp arg)
- (insert "@" string "{"))
- (insert "}"))
- (skip-chars-forward " \t\n\r\f")
- (insert "@" string "{")
- (forward-sexp arg)
- (insert "}")))
- (insert "@" string "{}")
- (backward-char)))
-
-(defun texinfo-insert-braces ()
+ (or (match-string 1) '-)))
+ \n "@end " str \n)
+
+(define-skeleton texinfo-insert-braces
"Make a pair of braces and be poised to type inside of them.
Use \\[up-list] to move forward out of the braces."
- (interactive)
- (insert "{}")
- (backward-char))
+ nil
+ "{" _ "}")
-(defun texinfo-insert-@code (&optional arg)
+(define-skeleton texinfo-insert-@code
"Insert a `@code{...}' command in a Texinfo buffer.
A numeric argument says how many words the braces should surround.
The default is not to surround any existing words with the braces."
- (interactive "P")
- (texinfo-insert-@-with-arg "code" arg))
+ nil
+ "@code{" _ "}")
-(defun texinfo-insert-@dfn (&optional arg)
+(define-skeleton texinfo-insert-@dfn
"Insert a `@dfn{...}' command in a Texinfo buffer.
A numeric argument says how many words the braces should surround.
The default is not to surround any existing words with the braces."
- (interactive "P")
- (texinfo-insert-@-with-arg "dfn" arg))
+ nil
+ "@dfn{" _ "}")
-(defun texinfo-insert-@email (&optional arg)
+(define-skeleton texinfo-insert-@email
"Insert a `@email{...}' command in a Texinfo buffer.
A numeric argument says how many words the braces should surround.
The default is not to surround any existing words with the braces."
- (interactive "P")
- (texinfo-insert-@-with-arg "email" arg))
+ nil
+ "@email{" _ "}")
-(defun texinfo-insert-@emph (&optional arg)
+(define-skeleton texinfo-insert-@emph
"Insert a `@emph{...}' command in a Texinfo buffer.
A numeric argument says how many words the braces should surround.
The default is not to surround any existing words with the braces."
- (interactive "P")
- (texinfo-insert-@-with-arg "emph" arg))
+ nil
+ "@emph{" _ "}")
-(defun texinfo-insert-@example ()
+(define-skeleton texinfo-insert-@example
"Insert the string `@example' in a Texinfo buffer."
- (interactive)
- (insert "@example\n"))
+ nil
+ \n "@example" \n)
-(defun texinfo-insert-@file (&optional arg)
+(define-skeleton texinfo-insert-@file
"Insert a `@file{...}' command in a Texinfo buffer.
A numeric argument says how many words the braces should surround.
The default is not to surround any existing words with the braces."
- (interactive "P")
- (texinfo-insert-@-with-arg "file" arg))
+ nil
+ "@file{" _ "}")
-(defun texinfo-insert-@item ()
+(define-skeleton texinfo-insert-@item
"Insert the string `@item' in a Texinfo buffer.
If in a table defined by @table, follow said string with a space.
Otherwise, follow with a newline."
- (interactive)
- (insert "@item"
+ nil
+ \n "@item"
(if (equal (ignore-errors
(save-excursion
(texinfo-last-unended-begin)
(match-string 1)))
"table")
- ?\s
- ?\n)))
+ " " '\n)
+ _ \n)
-(defun texinfo-insert-@kbd (&optional arg)
+(define-skeleton texinfo-insert-@kbd
"Insert a `@kbd{...}' command in a Texinfo buffer.
A numeric argument says how many words the braces should surround.
The default is not to surround any existing words with the braces."
- (interactive "P")
- (texinfo-insert-@-with-arg "kbd" arg))
+ nil
+ "@kbd{" _ "}")
-(defun texinfo-insert-@node ()
+(define-skeleton texinfo-insert-@node
"Insert the string `@node' in a Texinfo buffer.
Insert a comment on the following line indicating the order of
arguments to @node. Insert a carriage return after the comment line.
Leave point after `@node'."
- (interactive)
- (insert "@node \n@comment node-name, next, previous, up\n")
- (forward-line -2)
- (forward-char 6))
+ nil
+ \n "@node " _ \n)
-(defun texinfo-insert-@noindent ()
+(define-skeleton texinfo-insert-@noindent
"Insert the string `@noindent' in a Texinfo buffer."
- (interactive)
- (insert "@noindent\n"))
+ nil
+ \n "@noindent" \n)
-(defun texinfo-insert-@quotation ()
+(define-skeleton texinfo-insert-@quotation
"Insert the string `@quotation' in a Texinfo buffer."
- (interactive)
- (insert "@quotation\n"))
+ \n "@quotation" \n)
-(defun texinfo-insert-@samp (&optional arg)
+(define-skeleton texinfo-insert-@samp
"Insert a `@samp{...}' command in a Texinfo buffer.
A numeric argument says how many words the braces should surround.
The default is not to surround any existing words with the braces."
- (interactive "P")
- (texinfo-insert-@-with-arg "samp" arg))
+ nil
+ "@samp{" _ "}")
-(defun texinfo-insert-@strong (&optional arg)
+(define-skeleton texinfo-insert-@strong
"Insert a `@strong{...}' command in a Texinfo buffer.
A numeric argument says how many words the braces should surround.
The default is not to surround any existing words with the braces."
- (interactive "P")
- (texinfo-insert-@-with-arg "strong" arg))
+ nil
+ "@strong{" _ "}")
-(defun texinfo-insert-@table ()
+(define-skeleton texinfo-insert-@table
"Insert the string `@table' in a Texinfo buffer."
- (interactive)
- (insert "@table "))
+ nil
+ \n "@table " _ \n)
-(defun texinfo-insert-@var (&optional arg)
+(define-skeleton texinfo-insert-@var
"Insert a `@var{}' command in a Texinfo buffer.
A numeric argument says how many words the braces should surround.
The default is not to surround any existing words with the braces."
- (interactive "P")
- (texinfo-insert-@-with-arg "var" arg))
+ nil
+ "@var{" _ "}")
-(defun texinfo-insert-@uref (&optional arg)
+(define-skeleton texinfo-insert-@uref
"Insert a `@uref{}' command in a Texinfo buffer.
A numeric argument says how many words the braces should surround.
The default is not to surround any existing words with the braces."
- (interactive "P")
- (texinfo-insert-@-with-arg "uref" arg))
+ nil
+ "@uref{" _ "}")
(defalias 'texinfo-insert-@url 'texinfo-insert-@uref)
;;; Texinfo file structure
@@ -1050,5 +1024,4 @@ You are prompted for the job number (use a number shown by a previous
(provide 'texinfo)
-;; arch-tag: 005d7c38-43b9-4b7d-aa1d-aea69bae73e1
;;; texinfo.el ends here
diff --git a/lisp/textmodes/texnfo-upd.el b/lisp/textmodes/texnfo-upd.el
index 7e1ce4ce170..12a3e2a620b 100644
--- a/lisp/textmodes/texnfo-upd.el
+++ b/lisp/textmodes/texnfo-upd.el
@@ -1,7 +1,6 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1989-1992, 2001-2011 Free Software Foundation, Inc.
;; Author: Robert J. Chassell
;; Maintainer: bug-texinfo@gnu.org
@@ -349,9 +348,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 +624,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 +714,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 +897,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 +932,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 +1143,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 +1194,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 +1317,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 +1423,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 +1438,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 +1468,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 +1632,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 +1661,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 +1979,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 +2005,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 +2039,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 bcde482cdd4..3f6ad1faf87 100644
--- a/lisp/textmodes/text-mode.el
+++ b/lisp/textmodes/text-mode.el
@@ -1,10 +1,10 @@
;;; text-mode.el --- text mode, and its idiosyncratic commands
-;; Copyright (C) 1985, 1992, 1994, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1992, 1994, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: wp
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -32,7 +32,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.
@@ -181,5 +181,4 @@ The argument NLINES says how many lines to center."
(setq nlines (1+ nlines))
(forward-line -1)))))
-;; arch-tag: a07ccaad-da13-4d7b-9c61-cd04f5926aab
;;; text-mode.el ends here
diff --git a/lisp/textmodes/tildify.el b/lisp/textmodes/tildify.el
index 0f5c0a43a5c..b5af00cc450 100644
--- a/lisp/textmodes/tildify.el
+++ b/lisp/textmodes/tildify.el
@@ -1,7 +1,6 @@
;;; tildify.el --- adding hard spaces into texts
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2011 Free Software Foundation, Inc.
;; Author: Milan Zamazal <pdm@zamazal.org>
;; Version: 4.5
@@ -353,5 +352,4 @@ further questions)."
;; coding: iso-latin-2
;; End:
-;; arch-tag: fc9b05a6-7355-4639-8170-dcf57853ba22
;;; tildify.el ends here
diff --git a/lisp/textmodes/two-column.el b/lisp/textmodes/two-column.el
index c80bd8c1b7a..68b858162df 100644
--- a/lisp/textmodes/two-column.el
+++ b/lisp/textmodes/two-column.el
@@ -1,7 +1,6 @@
;;; two-column.el --- minor mode for editing of two-column text
-;; Copyright (C) 1992, 1993, 1994, 1995, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992-1995, 2001-2011 Free Software Foundation, Inc.
;; Author: Daniel Pfeiffer <occitan@esperanto.org>
;; Adapted-By: ESR, Daniel Pfeiffer
@@ -209,19 +208,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 +229,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 +239,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
@@ -632,5 +631,4 @@ on, this also realigns the two buffers."
(provide 'two-column)
-;; arch-tag: 2021b5ab-d3a4-4a8c-a21c-1936b0f9e6b1
;;; two-column.el ends here
diff --git a/lisp/textmodes/underline.el b/lisp/textmodes/underline.el
index f7507f6d6a5..2adac5a106a 100644
--- a/lisp/textmodes/underline.el
+++ b/lisp/textmodes/underline.el
@@ -1,7 +1,6 @@
;;; underline.el --- insert/remove underlining (done by overstriking) in Emacs
-;; Copyright (C) 1985, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: wp
@@ -61,5 +60,4 @@ which specify the range to operate on."
(provide 'underline)
-;; arch-tag: e7b48582-c3ea-4386-987a-87415f3c372a
;;; underline.el ends here
diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el
index 4389d54e706..a56c3e4d501 100644
--- a/lisp/thingatpt.el
+++ b/lisp/thingatpt.el
@@ -1,8 +1,6 @@
;;; thingatpt.el --- get the `thing' at point
-;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 2000,
-;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1991-1998, 2000-2011 Free Software Foundation, Inc.
;; Author: Mike Williams <mikew@gopher.dosli.govt.nz>
;; Maintainer: FSF
@@ -209,6 +207,12 @@ a symbol as a valid THING."
(cons opoint end))))
(error nil)))))
+;; Defuns
+
+(put 'defun 'beginning-op 'beginning-of-defun)
+(put 'defun 'end-op 'end-of-defun)
+(put 'defun 'forward-op 'end-of-defun)
+
;; Filenames and URLs www.com/foo%32bar
(defvar thing-at-point-file-name-chars "-~/[:alnum:]_.${}#%,:"
@@ -472,5 +476,4 @@ Signal an error if the entire string was not used."
"Return the Lisp list at point, or nil if none is found."
(form-at-point 'list 'listp))
-;; arch-tag: bb65a163-dae2-4055-aedc-fe11f497f698
;;; thingatpt.el ends here
diff --git a/lisp/thumbs.el b/lisp/thumbs.el
index b312c881219..b251ca60246 100644
--- a/lisp/thumbs.el
+++ b/lisp/thumbs.el
@@ -1,6 +1,6 @@
;;; thumbs.el --- Thumbnails previewer for images files
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: Jean-Philippe Theberge <jphiltheberge@videotron.ca>
;; Maintainer: FSF
@@ -816,5 +816,4 @@ ACTION and ARG should be a valid convert command."
(provide 'thumbs)
-;; arch-tag: f9ac1ef8-83fc-42c0-8069-1fae43fd2e5c
;;; thumbs.el ends here
diff --git a/lisp/time-stamp.el b/lisp/time-stamp.el
index fb5d4303d77..59340583997 100644
--- a/lisp/time-stamp.el
+++ b/lisp/time-stamp.el
@@ -1,7 +1,7 @@
;;; time-stamp.el --- Maintain last change time stamps in files edited by Emacs
-;; Copyright (C) 1989, 1993, 1994, 1995, 1997, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1989, 1993-1995, 1997, 2000-2011
+;; Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
@@ -470,7 +470,7 @@ and all `time-stamp-format' compatibility."
(result "")
field-width
field-result
- alt-form change-case require-padding
+ alt-form change-case
(paren-level 0))
(while (< ind fmt-len)
(setq cur-char (aref format ind))
@@ -480,7 +480,7 @@ and all `time-stamp-format' compatibility."
(cond
((eq cur-char ?%)
;; eat any additional args to allow for future expansion
- (setq alt-form nil change-case nil require-padding nil field-width "")
+ (setq alt-form nil change-case nil field-width "")
(while (progn
(setq ind (1+ ind))
(setq cur-char (if (< ind fmt-len)
@@ -706,5 +706,4 @@ around literals."
(provide 'time-stamp)
-;; arch-tag: 8a12c5c3-25d6-4a71-adc5-24b0e025a1e7
;;; time-stamp.el ends here
diff --git a/lisp/time.el b/lisp/time.el
index 45d135beb21..7d752c85d4d 100644
--- a/lisp/time.el
+++ b/lisp/time.el
@@ -1,7 +1,7 @@
;;; time.el --- display time, load and mail indicator in mode line of Emacs -*-coding: utf-8 -*-
-;; Copyright (C) 1985, 1986, 1987, 1993, 1994, 1996, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1987, 1993-1994, 1996, 2000-2011
+;; Free Software Foundation, Inc.
;; Maintainer: FSF
@@ -157,7 +157,7 @@ LABEL is a string to display as the label of that TIMEZONE's time."
;; Determine if zoneinfo style timezones are supported by testing that
;; America/New York and Europe/London return different timezones.
(let (gmt nyt)
- (set-time-zone-rule "America/New York")
+ (set-time-zone-rule "America/New_York")
(setq nyt (format-time-string "%z"))
(set-time-zone-rule "Europe/London")
(setq gmt (format-time-string "%z"))
@@ -365,6 +365,25 @@ would give mode line times like `94/12/30 21:07:48 (UTC)'."
size
nil)))
+(with-no-warnings
+ ;; Warnings are suppresed to avoid "global/dynamic var `X' lacks a prefix".
+ (defvar now)
+ (defvar time)
+ (defvar load)
+ (defvar mail)
+ (defvar 24-hours)
+ (defvar hour)
+ (defvar 12-hours)
+ (defvar am-pm)
+ (defvar minutes)
+ (defvar seconds)
+ (defvar time-zone)
+ (defvar day)
+ (defvar year)
+ (defvar monthname)
+ (defvar month)
+ (defvar dayname))
+
(defun display-time-update ()
"Update the display-time info for the mode line.
However, don't redisplay right now.
@@ -454,8 +473,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
@@ -492,15 +512,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."
@@ -508,25 +523,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 ()
@@ -582,5 +595,4 @@ For example, the Unix uptime command format is \"%D, %z%2h:%.2m\"."
(provide 'time)
-;; arch-tag: b9c1623f-b5cb-48e4-b650-482a4d23c5a6
;;; time.el ends here
diff --git a/lisp/timezone.el b/lisp/timezone.el
index 397027d577f..092d491a495 100644
--- a/lisp/timezone.el
+++ b/lisp/timezone.el
@@ -1,7 +1,7 @@
;;; timezone.el --- time zone package for GNU Emacs
-;; Copyright (C) 1990, 1991, 1992, 1993, 1996, 1999, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 1996, 1999, 2001-2011
+;; Free Software Foundation, Inc.
;; Author: Masanobu Umeda
;; Maintainer: umerin@mse.kyutech.ac.jp
@@ -403,5 +403,4 @@ The Gregorian date Sunday, December 31, 1 BC is imaginary."
(provide 'timezone)
-;; arch-tag: e23d5bc6-f32d-48ba-8996-323e9d654b3f
;;; timezone.el ends here
diff --git a/lisp/tmm.el b/lisp/tmm.el
index 0341b5384f0..52704e70a55 100644
--- a/lisp/tmm.el
+++ b/lisp/tmm.el
@@ -1,7 +1,6 @@
;;; tmm.el --- text mode access to menu-bar
-;; Copyright (C) 1994, 1995, 1996, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1996, 2000-2011 Free Software Foundation, Inc.
;; Author: Ilya Zakharevich <ilya@math.mps.ohio-state.edu>
;; Maintainer: FSF
@@ -566,5 +565,4 @@ of `menu-bar-final-items'."
(provide 'tmm)
-;; arch-tag: e7ddbdb6-4b95-4da3-afbe-ad6063d112f4
;;; tmm.el ends here
diff --git a/lisp/tool-bar.el b/lisp/tool-bar.el
index ddaf16043a3..8fdce17df86 100644
--- a/lisp/tool-bar.el
+++ b/lisp/tool-bar.el
@@ -1,10 +1,10 @@
;;; tool-bar.el --- setting up the tool bar
-;;
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
-;;
+
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
+
;; Author: Dave Love <fx@gnu.org>
;; Keywords: mouse frames
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -48,21 +48,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 +76,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.")
@@ -97,7 +88,7 @@ Define this locally to override the global tool bar.")
(defconst tool-bar-keymap-cache (make-hash-table :weakness t :test 'equal))
-(defun tool-bar-make-keymap (&optional ignore)
+(defun tool-bar-make-keymap (&optional _ignore)
"Generate an actual keymap from `tool-bar-map'.
Its main job is to figure out which images to use based on the display's
color capability and based on the available image libraries."
@@ -147,6 +138,26 @@ Use this function only to make bindings in the global value of `tool-bar-map'.
To define items in any other map, use `tool-bar-local-item'."
(apply 'tool-bar-local-item icon def key tool-bar-map props))
+(defun tool-bar--image-expression (icon)
+ "Return an expression that evaluates to an image spec for ICON."
+ (let* ((fg (face-attribute 'tool-bar :foreground))
+ (bg (face-attribute 'tool-bar :background))
+ (colors (nconc (if (eq fg 'unspecified) nil (list :foreground fg))
+ (if (eq bg 'unspecified) nil (list :background bg))))
+ (xpm-spec (list :type 'xpm :file (concat icon ".xpm")))
+ (xpm-lo-spec (list :type 'xpm :file
+ (concat "low-color/" icon ".xpm")))
+ (pbm-spec (append (list :type 'pbm :file
+ (concat icon ".pbm")) colors))
+ (xbm-spec (append (list :type 'xbm :file
+ (concat icon ".xbm")) colors)))
+ `(find-image (cond ((not (display-color-p))
+ ',(list pbm-spec xbm-spec xpm-lo-spec xpm-spec))
+ ((< (display-color-cells) 256)
+ ',(list xpm-lo-spec xpm-spec pbm-spec xbm-spec))
+ (t
+ ',(list xpm-spec pbm-spec xbm-spec))))))
+
;;;###autoload
(defun tool-bar-local-item (icon def key map &rest props)
"Add an item to the tool bar in map MAP.
@@ -159,24 +170,7 @@ ICON is the base name of a file containing the image to use. The
function will first try to use low-color/ICON.xpm if `display-color-cells'
is less or equal to 256, then ICON.xpm, then ICON.pbm, and finally
ICON.xbm, using `find-image'."
- (let* ((fg (face-attribute 'tool-bar :foreground))
- (bg (face-attribute 'tool-bar :background))
- (colors (nconc (if (eq fg 'unspecified) nil (list :foreground fg))
- (if (eq bg 'unspecified) nil (list :background bg))))
- (xpm-spec (list :type 'xpm :file (concat icon ".xpm")))
- (xpm-lo-spec (list :type 'xpm :file
- (concat "low-color/" icon ".xpm")))
- (pbm-spec (append (list :type 'pbm :file
- (concat icon ".pbm")) colors))
- (xbm-spec (append (list :type 'xbm :file
- (concat icon ".xbm")) colors))
- (image-exp `(find-image
- (cond ((not (display-color-p))
- ',(list pbm-spec xbm-spec xpm-lo-spec xpm-spec))
- ((< (display-color-cells) 256)
- ',(list xpm-lo-spec xpm-spec pbm-spec xbm-spec))
- (t
- ',(list xpm-spec pbm-spec xbm-spec))))))
+ (let* ((image-exp (tool-bar--image-expression icon)))
(define-key-after map (vector key)
`(menu-item ,(symbol-name key) ,def :image ,image-exp ,@props))))
@@ -211,27 +205,11 @@ holds a keymap."
(setq from-map global-map))
(let* ((menu-bar-map (lookup-key from-map [menu-bar]))
(keys (where-is-internal command menu-bar-map))
- (fg (face-attribute 'tool-bar :foreground))
- (bg (face-attribute 'tool-bar :background))
- (colors (nconc (if (eq fg 'unspecified) nil (list :foreground fg))
- (if (eq bg 'unspecified) nil (list :background bg))))
- (xpm-spec (list :type 'xpm :file (concat icon ".xpm")))
- (xpm-lo-spec (list :type 'xpm :file
- (concat "low-color/" icon ".xpm")))
- (pbm-spec (append (list :type 'pbm :file
- (concat icon ".pbm")) colors))
- (xbm-spec (append (list :type 'xbm :file
- (concat icon ".xbm")) colors))
- (image-exp `(find-image
- (cond ((not (display-color-p))
- ',(list pbm-spec xbm-spec xpm-lo-spec xpm-spec))
- ((< (display-color-cells) 256)
- ',(list xpm-lo-spec xpm-spec pbm-spec xbm-spec))
- (t
- ',(list xpm-spec pbm-spec xbm-spec)))))
+ (image-exp (tool-bar--image-expression icon))
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
@@ -264,60 +242,61 @@ holds a keymap."
;;; Set up some global items. Additions/deletions up for grabs.
(defun tool-bar-setup ()
- ;; 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")
+ (setq tool-bar-separator-image-expression
+ (tool-bar--image-expression "separator"))
+ (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
+ :label "Open" :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
- :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
- :visible '(not (eq 'special (get major-mode
- 'mode-class))))
+ :label "Save")
+ (define-key-after (default-value 'tool-bar-map) [separator-1] menu-bar-separator)
+ (tool-bar-add-item-from-menu 'undo "undo" nil)
+ (define-key-after (default-value 'tool-bar-map) [separator-2] menu-bar-separator)
(tool-bar-add-item-from-menu (lookup-key menu-bar-edit-menu [cut])
- "cut" nil
- :visible '(not (eq 'special (get major-mode
- 'mode-class))))
+ "cut" nil :vert-only t)
(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
- :visible '(not (eq 'special (get major-mode
- 'mode-class))))
- (tool-bar-add-item-from-menu 'nonincremental-search-forward "search")
+ "paste" nil :vert-only t)
+ (define-key-after (default-value 'tool-bar-map) [separator-3] menu-bar-separator)
+ (tool-bar-add-item-from-menu 'isearch-forward "search"
+ nil :label "Search" :vert-only t)
;;(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")))
+ ;; Help button on a tool bar is rather non-standard...
+ ;; (let ((tool-bar-map (default-value 'tool-bar-map)))
+ ;; (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 c95aee17661..bfe53dc71b7 100644
--- a/lisp/tooltip.el
+++ b/lisp/tooltip.el
@@ -1,10 +1,10 @@
;;; tooltip.el --- show tooltip windows
-;; Copyright (C) 1997, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 1999-2011 Free Software Foundation, Inc.
;; Author: Gerd Moellmann <gerd@acm.org>
;; Keywords: help c mouse tools
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -198,7 +198,7 @@ This might return nil if the event did not occur over a buffer."
(setq tooltip-timeout-id
(add-timeout (tooltip-delay) 'tooltip-timeout nil)))
-(defun tooltip-timeout (object)
+(defun tooltip-timeout (_object)
"Function called when timer with id `tooltip-timeout-id' fires."
(run-hook-with-args-until-success 'tooltip-functions
tooltip-last-mouse-motion-event))
@@ -256,7 +256,7 @@ in echo area."
(declare-function x-hide-tip "xfns.c" ())
-(defun tooltip-hide (&optional ignored-arg)
+(defun tooltip-hide (&optional _ignored-arg)
"Hide a tooltip, if one is displayed.
Value is non-nil if tooltip was open."
(tooltip-cancel-delayed-tip)
@@ -373,7 +373,7 @@ MSG is either a help string to display, or nil to cancel the display."
;; On text-only displays, try `tooltip-show-help-non-mode'.
(tooltip-show-help-non-mode msg)))
-(defun tooltip-help-tips (event)
+(defun tooltip-help-tips (_event)
"Hook function to display a help tooltip.
This is installed on the hook `tooltip-functions', which
is run when the timer with id `tooltip-timeout-id' fires.
@@ -384,5 +384,4 @@ Value is non-nil if this function handled the tip."
(provide 'tooltip)
-;; arch-tag: 3d61135e-4618-4a78-af28-183f6df5636f
;;; tooltip.el ends here
diff --git a/lisp/tree-widget.el b/lisp/tree-widget.el
index 83b1e60a389..c5aa1f330af 100644
--- a/lisp/tree-widget.el
+++ b/lisp/tree-widget.el
@@ -1,6 +1,6 @@
;;; tree-widget.el --- Tree widget
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: David Ponce <david@dponce.com>
;; Maintainer: David Ponce <david@dponce.com>
@@ -657,6 +657,8 @@ This hook should be local in the buffer setup to display widgets.")
(widget-get tree :dynargs)))
tree))
+(defvar widget-glyph-enable) ; XEmacs
+
(defun tree-widget-value-create (tree)
"Create the TREE tree-widget."
(let* ((node (tree-widget-node tree))
@@ -792,7 +794,7 @@ Each function is passed a tree-widget. If the value of the :open
property is non-nil the tree has been expanded, else collapsed.
This hook should be local in the buffer setup to display widgets.")
-(defun tree-widget-action (tree &optional event)
+(defun tree-widget-action (tree &optional _event)
"Handle the :action of the TREE tree-widget.
That is, toggle expansion of the TREE tree-widget.
Ignore the EVENT argument."
@@ -818,5 +820,4 @@ That is, if TREE :args is nil."
(provide 'tree-widget)
-;; arch-tag: c3a1ada2-1663-41dc-9d16-2479ed8320e8
;;; tree-widget.el ends here
diff --git a/lisp/tutorial.el b/lisp/tutorial.el
index 7c9d1a46282..77ef50843d3 100644
--- a/lisp/tutorial.el
+++ b/lisp/tutorial.el
@@ -1,9 +1,10 @@
;;; tutorial.el --- tutorial for Emacs
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
;; 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)))
@@ -958,5 +963,4 @@ Currently this feature is only used in `help-with-tutorial'."
(provide 'tutorial)
-;; arch-tag: c8e80aef-c3bb-4ffb-8af6-22171bf0c100
;;; tutorial.el ends here
diff --git a/lisp/type-break.el b/lisp/type-break.el
index ba08eb9f6b6..62a44724d40 100644
--- a/lisp/type-break.el
+++ b/lisp/type-break.el
@@ -1,7 +1,6 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1995, 1997, 2000-2011 Free Software Foundation, Inc.
;; Author: Noah Friedman
;; Maintainer: Noah Friedman <friedman@splode.com>
@@ -77,7 +76,7 @@
See the docstring for the `type-break-mode' command for more information.
Setting this variable directly does not take effect;
use either \\[customize] or the function `type-break-mode'."
- :set (lambda (symbol value)
+ :set (lambda (_symbol value)
(type-break-mode (if value 1 -1)))
:initialize 'custom-initialize-default
:type 'boolean
@@ -152,13 +151,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 +237,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 +431,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 +446,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 +460,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 +494,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
))))))
@@ -861,7 +831,7 @@ keystroke threshold has been exceeded."
(quit
(type-break-schedule type-break-query-interval))))))
-(defun type-break-noninteractive-query (&optional ignored-args)
+(defun type-break-noninteractive-query (&optional _ignored-args)
"Null query function which doesn't interrupt user and assumes `no'.
It prints a reminder in the echo area to take a break, but doesn't enforce
this or ask the user to start one right now."
@@ -1272,5 +1242,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 361a359a3d9..3153e143ba3 100644
--- a/lisp/uniquify.el
+++ b/lisp/uniquify.el
@@ -1,12 +1,12 @@
-;;; uniquify.el --- unique buffer names dependent on file name
+;;; uniquify.el --- unique buffer names dependent on file name -*- lexical-binding: t -*-
-;; Copyright (C) 1989, 1995, 1996, 1997, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1989, 1995-1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Dick King <king@reasoning.com>
;; Maintainer: FSF
;; Keywords: files
;; Created: 15 May 86
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -89,7 +89,7 @@
(defgroup uniquify nil
"Unique buffer names dependent on file name."
- :group 'applications)
+ :group 'files)
(defcustom uniquify-buffer-name-style nil
@@ -507,5 +507,4 @@ For use on `kill-buffer-hook'."
(provide 'uniquify)
-;; arch-tag: e763faa3-56c9-4903-8eb8-26e1c45a0065
;;; uniquify.el ends here
diff --git a/lisp/url/ChangeLog b/lisp/url/ChangeLog
index dc98640960b..1049d09d6db 100644
--- a/lisp/url/ChangeLog
+++ b/lisp/url/ChangeLog
@@ -1,36 +1,193 @@
+2011-05-02 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * url-queue.el: New file.
+ (url-queue-run-queue): Pick the first waiting job, and not the
+ last.
+ (url-queue-parallel-processes): Lower the concurrency level, since
+ Emacs doesn't seem to like too many async processes.
+ (url-queue-prune-old-entries): Fix up the pruning code.
+
+2011-04-16 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * url-http.el (url-http-wait-for-headers-change-function): Protect
+ against malformed headerless responses from servers.
+
+2011-04-02 Chong Yidong <cyd@stupidchicken.com>
+
+ * url-gw.el (url-open-stream): Use new open-network-stream
+ functionality to perform encryption.
+
+2011-04-01 Juanma Barranquero <lekktu@gmail.com>
+
+ * url-cookie.el (url-cookie-handle-set-cookie):
+ Use `dolist' rather than `mapcar'.
+
2011-03-07 Chong Yidong <cyd@stupidchicken.com>
* Version 23.3 released.
-2010-12-04 Chong Yidong <cyd@stupidchicken.com>
+2011-02-12 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * url-parse.el (url-bit-for-url, url-user-for-url)
+ (url-password-for-url): Use `auto-source-search' instead of
+ `auto-source-user-or-password'.
+
+ * url-auth.el: Autoload `auto-source-search' instead of
+ `auto-source-user-or-password'.
+ (url-basic-auth, url-digest-auth, url-do-auth-source-search): Use it.
+
+2011-02-03 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * url-http.el (url-http-wait-for-headers-change-function): Don't
+ move point if the callback function has moved changed/killed the
+ process buffer.
+
+2010-12-16 Miles Bader <miles@gnu.org>
+
+ * url-cookie.el: Require 'cl when compiling -- it's necessary for
+ defstruct.
+
+2010-12-14 Glenn Morris <rgm@gnu.org>
+
+ * url-cookie.el: Don't require cl when compiling.
+ (url-cookie-clean-up, url-cookie-generate-header-lines): Use dolist.
+ (url-cookie-parse-file, url-cookie-store, url-cookie-retrieve)
+ (url-cookie-handle-set-cookie): Simplify.
+
+2010-12-13 Chong Yidong <cyd@stupidchicken.com>
* url-cookie.el (url-cookie-retrieve): Handle null LOCALPART.
Suggested by Lennart Borgman (Bug#7543).
-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): Change 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-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 (url-http-parse-headers): Disable file name handlers at
+ * 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 (url-http-parse-headers): Disable Tramp. (Bug#6717)
+ * 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-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)
@@ -44,6 +201,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).
@@ -81,8 +265,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>
@@ -215,7 +399,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>
@@ -479,8 +663,8 @@
* url-http.el (url-http-proxy): New variable.
(url-http-create-request): Use it. Don't use `url-proxy-object'.
(url-http): Treat `url' argument as resource to download, and
- dynamic variable `url-using-proxy' as proxy to use. Set
- `url-current-object' to actual URL, and `url-http-proxy' to proxy
+ dynamic variable `url-using-proxy' as proxy to use.
+ Set `url-current-object' to actual URL, and `url-http-proxy' to proxy
used.
(url-http-handle-cookies): Assume that `url-current-object' does
not point to the proxy used.
@@ -496,24 +680,24 @@
(url-proxy): Bind it instead of `proxy-object'.
* url-http.el (url-http-create-request): Remove url argument, use
- the buffer-local variable `url-http-target-url' instead. Both
- callers updated. Simplify proxy handling.
+ the buffer-local variable `url-http-target-url' instead.
+ Both callers updated. Simplify proxy handling.
(url-http): Don't make proxy-object buffer local.
* url.el (url-retrieve-internal): Bind url-proxy-object to nil.
2006-11-26 Magnus Henoch <mange@freemail.hu>
- * url-http.el (url-http-wait-for-headers-change-function): Use
- `when' instead of `if' when possible.
+ * url-http.el (url-http-wait-for-headers-change-function):
+ Use `when' instead of `if' when possible.
(url-http): Define url-http-response-version.
(url-http-parse-response): Set it.
(url-http-parse-headers): Use it to determine keep-alive behavior.
2006-11-23 Diane Murray <disumu@x3y2z1.net> (tiny change)
- * url-http.el (url-http-content-length-after-change-function): Use
- `url-lazy-message'.
+ * url-http.el (url-http-content-length-after-change-function):
+ Use `url-lazy-message'.
* url-util.el (url-display-percentage): Only show a message if
`url-show-status' is non-nil.
@@ -895,8 +1079,8 @@
(url-cookie-generate-header-lines): Likewise.
(url-cookie-handle-set-cookie): Likewise.
(url-cookie-create): Expect :localpart instead of :path.
- (url-cookie-localpart): Renamed from url-cookie-path.
- (url-cookie-set-localpart): Renamed from url-cookie-set-path.
+ (url-cookie-localpart): Rename from url-cookie-path.
+ (url-cookie-set-localpart): Rename from url-cookie-set-path.
(url-cookie-file): Doc fix.
(url-cookie-p): Add doc string.
@@ -2113,7 +2297,7 @@
message when we have to contact a host so the user always gets
at least some feedback.
- * lisp/url-expand.el (url-expander-remove-relative-links): Moved and
+ * lisp/url-expand.el (url-expander-remove-relative-links): Move and
renamed function.
(url-default-expander): Use it.
@@ -2235,11 +2419,9 @@
;; Local variables:
;; coding: utf-8
-;; add-log-time-zone-rule: t
;; End:
- Copyright (C) 1999, 2001, 2002, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 1999, 2001-2002, 2004-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -2256,4 +2438,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: ac117078-3091-4533-be93-098162ac2926
diff --git a/lisp/url/url-about.el b/lisp/url/url-about.el
index 7f78de18fe1..b6f54db038e 100644
--- a/lisp/url/url-about.el
+++ b/lisp/url/url-about.el
@@ -1,7 +1,6 @@
;;; url-about.el --- Show internal URLs
-;; Copyright (C) 2001, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2004-2011 Free Software Foundation, Inc.
;; Keywords: comm, data, processes, hypermedia
@@ -99,5 +98,4 @@
(provide 'url-about)
-;; arch-tag: 65dd7fca-db3f-4cb1-8026-7dd37d4a460e
;;; url-about.el ends here
diff --git a/lisp/url/url-auth.el b/lisp/url/url-auth.el
index b3f058748fd..5261302a15c 100644
--- a/lisp/url/url-auth.el
+++ b/lisp/url/url-auth.el
@@ -1,7 +1,6 @@
;;; url-auth.el --- Uniform Resource Locator authorization modules
-;; Copyright (C) 1996, 1997, 1998, 1999, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1999, 2004-2011 Free Software Foundation, Inc.
;; Keywords: comm, data, processes, hypermedia
@@ -25,7 +24,7 @@
(require 'url-vars)
(require 'url-parse)
(autoload 'url-warn "url")
-(autoload 'auth-source-user-or-password "auth-source")
+(autoload 'auth-source-search "auth-source")
(defsubst url-auth-user-prompt (url realm)
"String to usefully prompt for a username."
@@ -82,11 +81,11 @@ instead of the filename inheritance method."
(cond
((and prompt (not byserv))
(setq user (or
- (auth-source-user-or-password "login" server type)
+ (url-do-auth-source-search server type :user)
(read-string (url-auth-user-prompt url realm)
(or user (user-real-login-name))))
pass (or
- (auth-source-user-or-password "password" server type)
+ (url-do-auth-source-search server type :secret)
(read-passwd "Password: " nil (or pass ""))))
(set url-basic-auth-storage
(cons (list server
@@ -111,11 +110,11 @@ instead of the filename inheritance method."
(if (or (and (not retval) prompt) overwrite)
(progn
(setq user (or
- (auth-source-user-or-password "login" server type)
+ (url-do-auth-source-search server type :user)
(read-string (url-auth-user-prompt url realm)
(user-real-login-name)))
pass (or
- (auth-source-user-or-password "password" server type)
+ (url-do-auth-source-search server type :secret)
(read-passwd "Password: "))
retval (base64-encode-string (format "%s:%s" user pass))
byserv (assoc server (symbol-value url-basic-auth-storage)))
@@ -174,11 +173,11 @@ instead of hostname:portnum."
(cond
((and prompt (not byserv))
(setq user (or
- (auth-source-user-or-password "login" server type)
+ (url-do-auth-source-search server type :user)
(read-string (url-auth-user-prompt url realm)
(user-real-login-name)))
pass (or
- (auth-source-user-or-password "password" server type)
+ (url-do-auth-source-search server type :secret)
(read-passwd "Password: "))
url-digest-auth-storage
(cons (list server
@@ -205,11 +204,11 @@ instead of hostname:portnum."
(if overwrite
(if (and (not retval) prompt)
(setq user (or
- (auth-source-user-or-password "login" server type)
+ (url-do-auth-source-search server type :user)
(read-string (url-auth-user-prompt url realm)
(user-real-login-name)))
pass (or
- (auth-source-user-or-password "password" server type)
+ (url-do-auth-source-search server type :secret)
(read-passwd "Password: "))
retval (setq retval
(cons user
@@ -245,6 +244,13 @@ instead of hostname:portnum."
"A list of the registered authorization schemes and various and sundry
information associated with them.")
+(defun url-do-auth-source-search (server type parameter)
+ (let* ((auth-info (auth-source-search :max 1 :host server :port type))
+ (auth-info (nth 0 auth-info))
+ (token (plist-get auth-info parameter))
+ (token (if (functionp token) (funcall token) token)))
+ token))
+
;;;###autoload
(defun url-get-authentication (url realm type prompt &optional args)
"Return an authorization string suitable for use in the WWW-Authenticate
@@ -345,5 +351,4 @@ RATING a rating between 1 and 10 of the strength of the authentication.
(provide 'url-auth)
-;; arch-tag: 04058625-616d-44e4-9dbf-4b46b00b2a91
;;; url-auth.el ends here
diff --git a/lisp/url/url-cache.el b/lisp/url/url-cache.el
index 4e6a64fb99d..1615920e64c 100644
--- a/lisp/url/url-cache.el
+++ b/lisp/url/url-cache.el
@@ -1,7 +1,6 @@
;;; url-cache.el --- Uniform Resource Locator retrieval tool
-;; Copyright (C) 1996, 1997, 1998, 1999, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1999, 2004-2011 Free Software Foundation, Inc.
;; Keywords: comm, data, processes, hypermedia
@@ -28,10 +27,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 +74,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 +94,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 +102,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 +151,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 +162,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 +171,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 +180,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,24 +194,20 @@ 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)
-;; arch-tag: 95b050a6-8e81-4f23-8e63-191b9d1d657c
;;; url-cache.el ends here
diff --git a/lisp/url/url-cid.el b/lisp/url/url-cid.el
index 3d34404763f..a5371a423e0 100644
--- a/lisp/url/url-cid.el
+++ b/lisp/url/url-cid.el
@@ -1,7 +1,6 @@
;;; url-cid.el --- Content-ID URL loader
-;; Copyright (C) 1998, 1999, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1998-1999, 2004-2011 Free Software Foundation, Inc.
;; Keywords: comm, data, processes
@@ -59,5 +58,4 @@
(t
(message "Unable to handle CID URL: %s" url))))
-;; arch-tag: 23d9ab74-fad4-4dba-b1e7-292871e8bda5
;;; url-cid.el ends here
diff --git a/lisp/url/url-cookie.el b/lisp/url/url-cookie.el
index 607f4da3d09..7fdd8b174c1 100644
--- a/lisp/url/url-cookie.el
+++ b/lisp/url/url-cookie.el
@@ -1,7 +1,6 @@
-;;; url-cookie.el --- Netscape Cookie support
+;;; url-cookie.el --- URL cookie support
-;; Copyright (C) 1996, 1997, 1998, 1999, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1999, 2004-2011 Free Software Foundation, Inc.
;; Keywords: comm, data, processes, hypermedia
@@ -26,10 +25,8 @@
(require 'url-util)
(require 'url-parse)
-(eval-when-compile (require 'cl))
-;; See http://home.netscape.com/newsref/std/cookie_spec.html for the
-;; 'open standard' defining this crap.
+(eval-when-compile (require 'cl)) ; defstruct
(defgroup url-cookie nil
"URL cookies."
@@ -76,41 +73,23 @@ telling Microsoft that."
"Whether the cookies list has changed since the last save operation.")
(defun url-cookie-parse-file (&optional fname)
- (setq fname (or fname url-cookie-file))
- (condition-case ()
- (load fname nil t)
- (error
- ;; It's completely normal for the cookies file not to exist yet.
- ;; (message "Could not load cookie file %s" fname)
- )))
+ "Load FNAME, default `url-cookie-file'."
+ ;; It's completely normal for the cookies file not to exist yet.
+ (load (or fname url-cookie-file) t t))
(declare-function url-cookie-p "url-cookie" t t) ; defstruct
(defun url-cookie-clean-up (&optional secure)
- (let* (
- (var (if secure 'url-cookie-secure-storage 'url-cookie-storage))
- (val (symbol-value var))
- (cur nil)
- (new nil)
- (cookies nil)
- (cur-cookie nil)
- (new-cookies nil)
- )
- (while val
- (setq cur (car val)
- val (cdr val)
- new-cookies nil
- cookies (cdr cur))
- (while cookies
- (setq cur-cookie (car cookies)
- cookies (cdr cookies))
- (if (or (not (url-cookie-p cur-cookie))
- (url-cookie-expired-p cur-cookie)
- (null (url-cookie-expires cur-cookie)))
- nil
- (setq new-cookies (cons cur-cookie new-cookies))))
- (if (not new-cookies)
- nil
+ (let ((var (if secure 'url-cookie-secure-storage 'url-cookie-storage))
+ new new-cookies)
+ (dolist (cur (symbol-value var))
+ (setq new-cookies nil)
+ (dolist (cur-cookie (cdr cur))
+ (or (not (url-cookie-p cur-cookie))
+ (url-cookie-expired-p cur-cookie)
+ (null (url-cookie-expires cur-cookie))
+ (setq new-cookies (cons cur-cookie new-cookies))))
+ (when new-cookies
(setcdr cur new-cookies)
(setq new (cons cur new))))
(set var new)))
@@ -143,54 +122,42 @@ telling Microsoft that."
(setq url-cookies-changed-since-last-save nil))))
(defun url-cookie-store (name value &optional expires domain localpart secure)
- "Store a netscape-style cookie."
- (let* ((storage (if secure url-cookie-secure-storage url-cookie-storage))
- (tmp storage)
- (cur nil)
- (found-domain nil))
-
- ;; First, look for a matching domain
- (setq found-domain (assoc domain storage))
-
- (if found-domain
+ "Store a cookie."
+ (let ((storage (if secure url-cookie-secure-storage url-cookie-storage))
+ tmp found-domain)
+ ;; First, look for a matching domain.
+ (if (setq found-domain (assoc domain storage))
;; Need to either stick the new cookie in existing domain storage
;; or possibly replace an existing cookie if the names match.
- (progn
- (setq storage (cdr found-domain)
- tmp nil)
- (while storage
- (setq cur (car storage)
- storage (cdr storage))
- (if (and (equal localpart (url-cookie-localpart cur))
- (equal name (url-cookie-name cur)))
- (progn
- (setf (url-cookie-expires cur) expires)
- (setf (url-cookie-value cur) value)
- (setq tmp t))))
- (if (not tmp)
- ;; New cookie
- (setcdr found-domain (cons
- (url-cookie-create :name name
- :value value
- :expires expires
- :domain domain
- :localpart localpart
- :secure secure)
- (cdr found-domain)))))
- ;; Need to add a new top-level domain
+ (unless (dolist (cur (setq storage (cdr found-domain)) tmp)
+ (and (equal localpart (url-cookie-localpart cur))
+ (equal name (url-cookie-name cur))
+ (progn
+ (setf (url-cookie-expires cur) expires)
+ (setf (url-cookie-value cur) value)
+ (setq tmp t))))
+ ;; New cookie.
+ (setcdr found-domain (cons
+ (url-cookie-create :name name
+ :value value
+ :expires expires
+ :domain domain
+ :localpart localpart
+ :secure secure)
+ (cdr found-domain))))
+ ;; Need to add a new top-level domain.
(setq tmp (url-cookie-create :name name
:value value
:expires expires
:domain domain
:localpart localpart
:secure secure))
- (cond
- (storage
- (setcdr storage (cons (list domain tmp) (cdr storage))))
- (secure
- (setq url-cookie-secure-storage (list (list domain tmp))))
- (t
- (setq url-cookie-storage (list (list domain tmp))))))))
+ (cond (storage
+ (setcdr storage (cons (list domain tmp) (cdr storage))))
+ (secure
+ (setq url-cookie-secure-storage (list (list domain tmp))))
+ (t
+ (setq url-cookie-storage (list (list domain tmp))))))))
(defun url-cookie-expired-p (cookie)
"Return non-nil if COOKIE is expired."
@@ -203,14 +170,9 @@ telling Microsoft that."
(append url-cookie-secure-storage url-cookie-storage)
url-cookie-storage))
(case-fold-search t)
- (cookies nil)
- (cur nil)
- (retval nil)
- (localpart-match nil))
- (while storage
- (setq cur (car storage)
- storage (cdr storage)
- cookies (cdr cur))
+ cookies retval localpart-match)
+ (dolist (cur storage)
+ (setq cookies (cdr cur))
(if (and (car cur)
(string-match
(concat "^.*"
@@ -222,36 +184,28 @@ telling Microsoft that."
(car cur)))
"$") host))
;; The domains match - a possible hit!
- (while cookies
- (setq cur (car cookies)
- cookies (cdr cookies)
- localpart-match (url-cookie-localpart cur))
- (if (and (if (and (stringp localpart-match)
- (stringp localpart))
- (string-match (concat "^" (regexp-quote
- localpart-match))
- localpart)
- (equal localpart localpart-match))
- (not (url-cookie-expired-p cur)))
- (setq retval (cons cur retval))))))
+ (dolist (cur cookies)
+ (and (if (and (stringp
+ (setq localpart-match (url-cookie-localpart cur)))
+ (stringp localpart))
+ (string-match (concat "^" (regexp-quote localpart-match))
+ localpart)
+ (equal localpart localpart-match))
+ (not (url-cookie-expired-p cur))
+ (setq retval (cons cur retval))))))
retval))
(defun url-cookie-generate-header-lines (host localpart secure)
- (let* ((cookies (url-cookie-retrieve host localpart secure))
- (retval nil)
- (cur nil)
- (chunk nil))
- ;; Have to sort this for sending most specific cookies first
+ (let ((cookies (url-cookie-retrieve host localpart secure))
+ retval chunk)
+ ;; Have to sort this for sending most specific cookies first.
(setq cookies (and cookies
(sort cookies
- (function
- (lambda (x y)
- (> (length (url-cookie-localpart x))
- (length (url-cookie-localpart y))))))))
- (while cookies
- (setq cur (car cookies)
- cookies (cdr cookies)
- chunk (format "%s=%s" (url-cookie-name cur) (url-cookie-value cur))
+ (lambda (x y)
+ (> (length (url-cookie-localpart x))
+ (length (url-cookie-localpart y)))))))
+ (dolist (cur cookies)
+ (setq chunk (format "%s=%s" (url-cookie-name cur) (url-cookie-value cur))
retval (if (and url-cookie-multiple-line
(< 80 (+ (length retval) (length chunk) 4)))
(concat retval "\r\nCookie: " chunk)
@@ -321,40 +275,38 @@ telling Microsoft that."
(file-name-directory
(url-filename url-current-object))))
(rest nil))
- (while args
- (if (not (member (downcase (car (car args)))
- '("secure" "domain" "expires" "path")))
- (setq rest (cons (car args) rest)))
- (setq args (cdr args)))
+ (dolist (this args)
+ (or (member (downcase (car this)) '("secure" "domain" "expires" "path"))
+ (setq rest (cons this rest))))
;; Sometimes we get dates that the timezone package cannot handle very
;; gracefully - take care of this here, instead of in url-cookie-expired-p
;; to speed things up.
- (if (and expires
- (string-match
- (concat "^[^,]+, +\\(..\\)-\\(...\\)-\\(..\\) +"
- "\\(..:..:..\\) +\\[*\\([^\]]+\\)\\]*$")
- expires))
- (setq expires (concat (match-string 1 expires) " "
- (match-string 2 expires) " "
- (match-string 3 expires) " "
- (match-string 4 expires) " ["
- (match-string 5 expires) "]")))
+ (and expires
+ (string-match
+ (concat "^[^,]+, +\\(..\\)-\\(...\\)-\\(..\\) +"
+ "\\(..:..:..\\) +\\[*\\([^\]]+\\)\\]*$")
+ expires)
+ (setq expires (concat (match-string 1 expires) " "
+ (match-string 2 expires) " "
+ (match-string 3 expires) " "
+ (match-string 4 expires) " ["
+ (match-string 5 expires) "]")))
;; This one is for older Emacs/XEmacs variants that don't
;; understand this format without tenths of a second in it.
;; Wednesday, 30-Dec-2037 16:00:00 GMT
;; - vs -
;; Wednesday, 30-Dec-2037 16:00:00.00 GMT
- (if (and expires
- (string-match
- "\\([0-9]+\\)-\\([A-Za-z]+\\)-\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9]+:[0-9]+\\)\\(\\.[0-9]+\\)*[ \t]+\\([-+a-zA-Z0-9]+\\)"
- expires))
- (setq expires (concat (match-string 1 expires) "-" ; day
- (match-string 2 expires) "-" ; month
- (match-string 3 expires) " " ; year
- (match-string 4 expires) ".00 " ; hour:minutes:seconds
- (match-string 6 expires)))) ":" ; timezone
+ (and expires
+ (string-match
+ "\\([0-9]+\\)-\\([A-Za-z]+\\)-\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9]+:[0-9]+\\)\\(\\.[0-9]+\\)*[ \t]+\\([-+a-zA-Z0-9]+\\)"
+ expires)
+ (setq expires (concat (match-string 1 expires) "-" ; day
+ (match-string 2 expires) "-" ; month
+ (match-string 3 expires) " " ; year
+ (match-string 4 expires) ".00 " ; hour:minutes:seconds
+ (match-string 6 expires)))) ":" ; timezone
(while (consp trusted)
(if (string-match (car trusted) current-url)
@@ -364,45 +316,38 @@ telling Microsoft that."
(if (string-match (car untrusted) current-url)
(setq untrusted (- (match-end 0) (match-beginning 0)))
(pop untrusted)))
- (if (and trusted untrusted)
- ;; Choose the more specific match
- (if (> trusted untrusted)
- (setq untrusted nil)
- (setq trusted nil)))
+ (and trusted untrusted
+ ;; Choose the more specific match.
+ (set (if (> trusted untrusted) 'untrusted 'trusted) nil))
(cond
(untrusted
- ;; The site was explicity marked as untrusted by the user
+ ;; The site was explicity marked as untrusted by the user.
nil)
((or (eq url-privacy-level 'paranoid)
(and (listp url-privacy-level) (memq 'cookies url-privacy-level)))
- ;; user never wants cookies
+ ;; User never wants cookies.
nil)
((and url-cookie-confirmation
(not trusted)
(save-window-excursion
(with-output-to-temp-buffer "*Cookie Warning*"
- (mapcar
- (function
- (lambda (x)
- (princ (format "%s - %s" (car x) (cdr x))))) rest))
+ (dolist (x rest)
+ (princ (format "%s - %s" (car x) (cdr x)))))
(prog1
(not (funcall url-confirmation-func
(format "Allow %s to set these cookies? "
(url-host url-current-object))))
(if (get-buffer "*Cookie Warning*")
(kill-buffer "*Cookie Warning*")))))
- ;; user wants to be asked, and declined.
+ ;; User wants to be asked, and declined.
nil)
((url-cookie-host-can-set-p (url-host url-current-object) domain)
- ;; Cookie is accepted by the user, and passes our security checks
- (let ((cur nil))
- (while rest
- (setq cur (pop rest))
- (url-cookie-store (car cur) (cdr cur)
- expires domain localpart secure))))
+ ;; Cookie is accepted by the user, and passes our security checks.
+ (dolist (cur rest)
+ (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)
@@ -430,5 +375,4 @@ to run the `url-cookie-setup-save-timer' function manually."
(provide 'url-cookie)
-;; arch-tag: 2568751b-6452-4398-aa2d-303edadb54d7
;;; url-cookie.el ends here
diff --git a/lisp/url/url-dav.el b/lisp/url/url-dav.el
index bd6907df642..3d1f6afcb0e 100644
--- a/lisp/url/url-dav.el
+++ b/lisp/url/url-dav.el
@@ -1,7 +1,6 @@
;;; url-dav.el --- WebDAV support
-;; Copyright (C) 2001, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2004-2011 Free Software Foundation, Inc.
;; Author: Bill Perry <wmperry@gnu.org>
;; Maintainer: Bill Perry <wmperry@gnu.org>
@@ -963,5 +962,4 @@ Returns nil if URL contains no name starting with FILE."
(provide 'url-dav)
-;; arch-tag: 2b14b7b3-888a-49b8-a490-17276a40e78e
;;; url-dav.el ends here
diff --git a/lisp/url/url-dired.el b/lisp/url/url-dired.el
index 73c8a3b265f..bb29fecb655 100644
--- a/lisp/url/url-dired.el
+++ b/lisp/url/url-dired.el
@@ -1,7 +1,6 @@
;;; url-dired.el --- URL Dired minor mode
-;; Copyright (C) 1996, 1997, 1998, 1999, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1999, 2004-2011 Free Software Foundation, Inc.
;; Keywords: comm, files
@@ -31,11 +30,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 +42,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."
@@ -90,5 +54,4 @@ Example: (add-minor-mode 'view-minor-mode \" View\" view-mode-map)"
(provide 'url-dired)
-;; arch-tag: 2694f21a-43e1-4391-b3cb-cf6e5349f15f
;;; url-dired.el ends here
diff --git a/lisp/url/url-expand.el b/lisp/url/url-expand.el
index c420ea930ba..1781c362959 100644
--- a/lisp/url/url-expand.el
+++ b/lisp/url/url-expand.el
@@ -1,7 +1,6 @@
;;; url-expand.el --- expand-file-name for URLs
-;; Copyright (C) 1999, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2004-2011 Free Software Foundation, Inc.
;; Keywords: comm, data, processes
@@ -144,5 +143,4 @@ path components followed by `..' are removed, along with the `..' itself."
(provide 'url-expand)
-;; arch-tag: 7b5f744b-b721-49da-be47-484631680a5a
;;; url-expand.el ends here
diff --git a/lisp/url/url-file.el b/lisp/url/url-file.el
index 319f62f3a1a..28fb59cd112 100644
--- a/lisp/url/url-file.el
+++ b/lisp/url/url-file.el
@@ -1,7 +1,6 @@
;;; url-file.el --- File retrieval code
-;; Copyright (C) 1996, 1997, 1998, 1999, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1999, 2004-2011 Free Software Foundation, Inc.
;; Keywords: comm, data, processes
@@ -103,12 +102,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
@@ -234,5 +240,4 @@ to them."
(provide 'url-file)
-;; arch-tag: 010e914a-7313-494b-8a8c-6495a862157d
;;; url-file.el ends here
diff --git a/lisp/url/url-ftp.el b/lisp/url/url-ftp.el
index fdfaecbf8f8..670094d80ca 100644
--- a/lisp/url/url-ftp.el
+++ b/lisp/url/url-ftp.el
@@ -1,7 +1,6 @@
;;; url-ftp.el --- FTP wrapper
-;; Copyright (C) 1996, 1997, 1998, 1999, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1999, 2004-2011 Free Software Foundation, Inc.
;; Keywords: comm, data, processes
@@ -41,5 +40,4 @@
(provide 'url-ftp)
-;; arch-tag: 9c3e70c4-350f-4d4a-bb51-a1e9b459e7dc
;;; url-ftp.el ends here
diff --git a/lisp/url/url-gw.el b/lisp/url/url-gw.el
index 8448647879d..7d80f2f6725 100644
--- a/lisp/url/url-gw.el
+++ b/lisp/url/url-gw.el
@@ -1,7 +1,6 @@
;;; url-gw.el --- Gateway munging for URL loading
-;; Copyright (C) 1997, 1998, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1997-1998, 2004-2011 Free Software Foundation, Inc.
;; Author: Bill Perry <wmperry@gnu.org>
;; Keywords: comm, data, processes
@@ -29,58 +28,56 @@
;; Fixme: support SSH explicitly or via a url-gateway-rlogin-program?
(autoload 'socks-open-network-stream "socks")
-(autoload 'open-ssl-stream "ssl")
-(autoload 'open-tls-stream "tls")
(defgroup url-gateway nil
"URL gateway variables."
: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 +92,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 +100,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)
@@ -220,13 +217,6 @@ Might do a non-blocking connection; use `process-status' to check."
host))
'native
url-gateway-method))
-;;; ;; This hack is for OS/2 Emacs so that it will not do bogus CRLF
-;;; ;; conversions while trying to be 'helpful'
-;;; (tcp-binary-process-output-services (if (stringp service)
-;;; (list service)
-;;; (list service
-;;; (int-to-string service))))
-
;; An attempt to deal with denied connections, and attempt
;; to reconnect
(cur-retries 0)
@@ -244,16 +234,15 @@ Might do a non-blocking connection; use `process-status' to check."
(let ((coding-system-for-read 'binary)
(coding-system-for-write 'binary))
(setq conn (case gw-method
- (tls
- (open-tls-stream name buffer host service))
- (ssl
- (open-ssl-stream name buffer host service))
- ((native)
- ;; Use non-blocking socket if we can.
- (make-network-process :name name :buffer buffer
- :host host :service service
- :nowait
- (featurep 'make-network-process '(:nowait t))))
+ ((tls ssl native)
+ (if (eq gw-method 'native)
+ (setq gw-method 'plain))
+ (open-network-stream
+ name buffer host service
+ :type gw-method
+ ;; Use non-blocking socket if we can.
+ :nowait (featurep 'make-network-process
+ '(:nowait t))))
(socks
(socks-open-network-stream name buffer host service))
(telnet
@@ -262,16 +251,9 @@ Might do a non-blocking connection; use `process-status' to check."
(url-open-rlogin name buffer host service))
(otherwise
(error "Bad setting of url-gateway-method: %s"
- url-gateway-method)))))
- ;; Ignoring errors here seems wrong. E.g. it'll throw away the
- ;; error signaled two lines above. It was also found inconvenient
- ;; during debugging.
- ;; (error
- ;; (setq conn nil))
- )
+ url-gateway-method))))))
conn)))
(provide 'url-gw)
-;; arch-tag: 1c4c0317-6d03-45b8-b3f3-838bd8f9d838
;;; url-gw.el ends here
diff --git a/lisp/url/url-handlers.el b/lisp/url/url-handlers.el
index 9b77c3c5cda..fef0ef15e95 100644
--- a/lisp/url/url-handlers.el
+++ b/lisp/url/url-handlers.el
@@ -1,7 +1,6 @@
;;; url-handlers.el --- file-name-handler stuff for URL loading
-;; Copyright (C) 1996, 1997, 1998, 1999, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1999, 2004-2011 Free Software Foundation, Inc.
;; Keywords: comm, data, processes, hypermedia
@@ -325,5 +324,4 @@ They count bytes from the beginning of the body."
(provide 'url-handlers)
-;; arch-tag: 7300b99c-cc83-42ff-9147-79b2723c62ac
;;; url-handlers.el ends here
diff --git a/lisp/url/url-history.el b/lisp/url/url-history.el
index 8a5b97b43a8..3827f9a5d41 100644
--- a/lisp/url/url-history.el
+++ b/lisp/url/url-history.el
@@ -1,7 +1,6 @@
;;; url-history.el --- Global history tracking for URL package
-;; Copyright (C) 1996, 1997, 1998, 1999, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1999, 2004-2011 Free Software Foundation, Inc.
;; Keywords: comm, data, processes, hypermedia
@@ -35,7 +34,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 +48,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."
@@ -184,5 +183,4 @@ user for what type to save as."
(provide 'url-history)
-;; arch-tag: fbbbaf63-db36-4e88-bc9f-2939aa93afb2
;;; url-history.el ends here
diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el
index a6652987966..28071e7165a 100644
--- a/lisp/url/url-http.el
+++ b/lisp/url/url-http.el
@@ -1,7 +1,6 @@
;;; url-http.el --- HTTP retrieval routines
-;; Copyright (C) 1999, 2001, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2001, 2004-2011 Free Software Foundation, Inc.
;; Author: Bill Perry <wmperry@gnu.org>
;; Keywords: comm, data, processes
@@ -64,6 +63,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 +338,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 +484,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 +517,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 +539,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 +557,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 +573,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 +642,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 +675,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 +728,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 +742,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 +791,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 +809,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 +873,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
@@ -982,10 +1034,11 @@ the end of the document."
url-http-response-status))
(url-http-debug "url-http-wait-for-headers-change-function (%s)"
(buffer-name))
- (when (not (bobp))
- (let ((end-of-headers nil)
- (old-http nil)
- (content-length nil))
+ (let ((end-of-headers nil)
+ (old-http nil)
+ (process-buffer (current-buffer))
+ (content-length nil))
+ (when (not (bobp))
(goto-char (point-min))
(if (and (looking-at ".*\n") ; have one line at least
(not (looking-at "^HTTP/[1-9]\\.[0-9]")))
@@ -1024,6 +1077,10 @@ the end of the document."
(downcase url-http-transfer-encoding)))
(cond
+ ((null url-http-response-status)
+ ;; We got back a headerless malformed response from the
+ ;; server.
+ (url-http-activate-callback))
((or (= url-http-response-status 204)
(= url-http-response-status 205))
(url-http-debug "%d response must have headers only (%s)."
@@ -1099,8 +1156,9 @@ the end of the document."
'url-http-simple-after-change-function)))))
;; We are still at the beginning of the buffer... must just be
;; waiting for a response.
- (url-http-debug "Spinning waiting for headers..."))
- (goto-char (point-max)))
+ (url-http-debug "Spinning waiting for headers...")
+ (when (eq process-buffer (current-buffer))
+ (goto-char (point-max)))))
;;;###autoload
(defun url-http (url callback cbargs)
@@ -1193,20 +1251,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 +1273,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
@@ -1398,5 +1458,4 @@ p3p
(provide 'url-http)
-;; arch-tag: ba7c59ae-c0f4-4a31-9617-d85f221732ee
;;; url-http.el ends here
diff --git a/lisp/url/url-imap.el b/lisp/url/url-imap.el
index d901bb00c21..3f7d1ec9238 100644
--- a/lisp/url/url-imap.el
+++ b/lisp/url/url-imap.el
@@ -1,6 +1,6 @@
;;; url-imap.el --- IMAP retrieval routines
-;; Copyright (C) 1999, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2004-2011 Free Software Foundation, Inc.
;; Author: Simon Josefsson <jas@pdc.kth.se>
;; Keywords: comm, data, processes
@@ -76,5 +76,4 @@
)))
(current-buffer)))
-;; arch-tag: 034991ff-5425-48ea-b911-c96c90e6f47d
;;; url-imap.el ends here
diff --git a/lisp/url/url-irc.el b/lisp/url/url-irc.el
index 3c7377aedcd..d5f2a99a914 100644
--- a/lisp/url/url-irc.el
+++ b/lisp/url/url-irc.el
@@ -1,7 +1,6 @@
;;; url-irc.el --- IRC URL interface
-;; Copyright (C) 1996, 1997, 1998, 1999, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1999, 2004-2011 Free Software Foundation, Inc.
;; Keywords: comm, data, processes
@@ -22,7 +21,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 +32,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
@@ -90,5 +90,4 @@ PASSWORD - What password to use"
(provide 'url-irc)
-;; arch-tag: 2e5eecf8-9eb3-436b-9fbd-c26f2fb2bf3e
;;; url-irc.el ends here
diff --git a/lisp/url/url-ldap.el b/lisp/url/url-ldap.el
index 0a99f7344dd..bb937a44423 100644
--- a/lisp/url/url-ldap.el
+++ b/lisp/url/url-ldap.el
@@ -1,6 +1,6 @@
;;; url-ldap.el --- LDAP Uniform Resource Locator retrieval code
-;; Copyright (C) 1998, 1999, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-1999, 2004-2011 Free Software Foundation, Inc.
;; Keywords: comm, data, processes
@@ -237,5 +237,4 @@ URL can be a URL string, or a URL vector of the type returned by
(provide 'url-ldap)
-;; arch-tag: 6230e21c-41ae-4174-bd83-82c835676fc8
;;; url-ldap.el ends here
diff --git a/lisp/url/url-mailto.el b/lisp/url/url-mailto.el
index fec991c3fff..c0472a92bb1 100644
--- a/lisp/url/url-mailto.el
+++ b/lisp/url/url-mailto.el
@@ -1,7 +1,6 @@
;;; url-mail.el --- Mail Uniform Resource Locator retrieval code
-;; Copyright (C) 1996, 1997, 1998, 1999, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1999, 2004-2011 Free Software Foundation, Inc.
;; Keywords: comm, data, processes
@@ -142,5 +141,4 @@
(provide 'url-mailto)
-;; arch-tag: 7b7ad52e-8760-497b-9444-75fae14e34c5
;;; url-mailto.el ends here
diff --git a/lisp/url/url-methods.el b/lisp/url/url-methods.el
index aeb78880a83..3b86ed45565 100644
--- a/lisp/url/url-methods.el
+++ b/lisp/url/url-methods.el
@@ -1,7 +1,6 @@
;;; url-methods.el --- Load URL schemes as needed
-;; Copyright (C) 1996, 1997, 1998, 1999, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1999, 2004-2011 Free Software Foundation, Inc.
;; Keywords: comm, data, processes, hypermedia
@@ -154,5 +153,4 @@ it has not already been loaded."
(provide 'url-methods)
-;; arch-tag: 336863f8-5a07-4906-9be5-b3c6bcebbe67
;;; url-methods.el ends here
diff --git a/lisp/url/url-misc.el b/lisp/url/url-misc.el
index bfcc9db6ba9..20e623de6cd 100644
--- a/lisp/url/url-misc.el
+++ b/lisp/url/url-misc.el
@@ -1,7 +1,6 @@
;;; url-misc.el --- Misc Uniform Resource Locator retrieval code
-;; Copyright (C) 1996, 1997, 1998, 1999, 2002, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1999, 2002, 2004-2011 Free Software Foundation, Inc.
;; Keywords: comm, data, processes
@@ -115,5 +114,4 @@
(provide 'url-misc)
-;; arch-tag: 8c544e1b-d8bc-40a6-b319-f1f37fef65a0
;;; url-misc.el ends here
diff --git a/lisp/url/url-news.el b/lisp/url/url-news.el
index 7f788119c52..6cd3721e498 100644
--- a/lisp/url/url-news.el
+++ b/lisp/url/url-news.el
@@ -1,7 +1,6 @@
;;; url-news.el --- News Uniform Resource Locator retrieval code
-;; Copyright (C) 1996, 1997, 1998, 1999, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1999, 2004-2011 Free Software Foundation, Inc.
;; Keywords: comm, data, processes
@@ -130,5 +129,4 @@
(provide 'url-news)
-;; arch-tag: 8975be13-04e8-4d38-bfff-47918e3ad311
;;; url-news.el ends here
diff --git a/lisp/url/url-nfs.el b/lisp/url/url-nfs.el
index f10b8ce3959..1cda75c59e7 100644
--- a/lisp/url/url-nfs.el
+++ b/lisp/url/url-nfs.el
@@ -1,7 +1,6 @@
;;; url-nfs.el --- NFS URL interface
-;; Copyright (C) 1996, 1997, 1998, 1999, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1999, 2004-2011 Free Software Foundation, Inc.
;; Keywords: comm, data, processes
@@ -89,5 +88,4 @@ Each can be used any number of times.")
(provide 'url-nfs)
-;; arch-tag: cdf9c9ba-b7d2-4c29-8b48-7ae9bbc0d437
;;; url-nfs.el ends here
diff --git a/lisp/url/url-ns.el b/lisp/url/url-ns.el
index b42052aa336..2eaa662be55 100644
--- a/lisp/url/url-ns.el
+++ b/lisp/url/url-ns.el
@@ -1,7 +1,6 @@
;;; url-ns.el --- Various netscape-ish functions for proxy definitions
-;; Copyright (C) 1997, 1998, 1999, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-1999, 2004-2011 Free Software Foundation, Inc.
;; Keywords: comm, data, processes, hypermedia
@@ -102,5 +101,4 @@
(provide 'url-ns)
-;; arch-tag: 69520992-cf97-40b4-9ad1-c866d3cae5bf
;;; url-ns.el ends here
diff --git a/lisp/url/url-parse.el b/lisp/url/url-parse.el
index ee1df01e14a..71c03bf1edd 100644
--- a/lisp/url/url-parse.el
+++ b/lisp/url/url-parse.el
@@ -1,7 +1,6 @@
;;; url-parse.el --- Uniform Resource Locator parser
-;; Copyright (C) 1996, 1997, 1998, 1999, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1999, 2004-2011 Free Software Foundation, Inc.
;; Keywords: comm, data, processes
@@ -25,6 +24,7 @@
;;; Code:
(require 'url-vars)
+(require 'auth-source)
(eval-when-compile (require 'cl))
(autoload 'url-scheme-get-property "url-methods")
@@ -35,7 +35,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,7 +174,30 @@ 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))
+ auth-info)
+ (while (and (not bit) (> (length methods) 0))
+ (setq auth-info (auth-source-search
+ :max 1
+ :host (funcall (pop methods) urlobj)
+ :port (url-type urlobj)))
+ (setq bit (plist-get (nth 0 auth-info) ,lookfor))
+ (when (functionp bit)
+ (setq bit (funcall bit))))
+ bit))
+
+(defun url-user-for-url (url)
+ "Attempt to use .authinfo to find a user for this URL."
+ (url-bit-for-url 'url-user :user url))
+
+(defun url-password-for-url (url)
+ "Attempt to use .authinfo to find a password for this URL."
+ (url-bit-for-url 'url-password :secret url))
+
(provide 'url-parse)
-;; arch-tag: f338325f-71ab-4bee-93cc-78fb9a03d403
;;; url-parse.el ends here
diff --git a/lisp/url/url-privacy.el b/lisp/url/url-privacy.el
index 563ef97418d..ff89b125c6d 100644
--- a/lisp/url/url-privacy.el
+++ b/lisp/url/url-privacy.el
@@ -1,7 +1,6 @@
;;; url-privacy.el --- Global history tracking for URL package
-;; Copyright (C) 1996, 1997, 1998, 1999, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1999, 2004-2011 Free Software Foundation, Inc.
;; Keywords: comm, data, processes, hypermedia
@@ -75,5 +74,4 @@
(provide 'url-privacy)
-;; arch-tag: fdaf95e4-98f0-4680-94c3-f3eadafabe1d
;;; url-privacy.el ends here
diff --git a/lisp/url/url-proxy.el b/lisp/url/url-proxy.el
index bfea09e831f..3290f7c5141 100644
--- a/lisp/url/url-proxy.el
+++ b/lisp/url/url-proxy.el
@@ -1,6 +1,6 @@
;;; url-proxy.el --- Proxy server support
-;; Copyright (C) 1999, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2004-2011 Free Software Foundation, Inc.
;; Keywords: comm, data, processes, hypermedia
@@ -76,5 +76,4 @@
(provide 'url-proxy)
-;; arch-tag: 4ff8882e-e498-42b7-abc5-acb449cdbc62
;;; url-proxy.el ends here
diff --git a/lisp/url/url-queue.el b/lisp/url/url-queue.el
new file mode 100644
index 00000000000..08496ad5afb
--- /dev/null
+++ b/lisp/url/url-queue.el
@@ -0,0 +1,112 @@
+;;; url-queue.el --- Fetching web pages in parallel
+
+;; Copyright (C) 2011 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Keywords: comm
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 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 point of this package is to allow fetching web pages in
+;; parallel -- but control the level of parallelism to avoid DoS-ing
+;; web servers and Emacs.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'browse-url)
+
+(defcustom url-queue-parallel-processes 2
+ "The number of concurrent processes."
+ :type 'integer
+ :group 'url)
+
+(defcustom url-queue-timeout 5
+ "How long to let a job live once it's started (in seconds)."
+ :type 'integer
+ :group 'url)
+
+;;; Internal variables.
+
+(defvar url-queue nil)
+
+(defstruct url-queue
+ url callback cbargs silentp
+ buffer start-time)
+
+;;;###autoload
+(defun url-queue-retrieve (url callback &optional cbargs silent)
+ "Retrieve URL asynchronously and call CALLBACK with CBARGS when finished.
+Like `url-retrieve' (which see for details of the arguments), but
+controls the level of parallelism via the
+`url-queue-parallel-processes' variable."
+ (setq url-queue
+ (append url-queue
+ (list (make-url-queue :url url
+ :callback callback
+ :cbargs cbargs
+ :silentp silent))))
+ (url-queue-run-queue))
+
+(defun url-queue-run-queue ()
+ (url-queue-prune-old-entries)
+ (let ((running 0)
+ waiting)
+ (dolist (entry url-queue)
+ (cond
+ ((url-queue-start-time entry)
+ (incf running))
+ ((not waiting)
+ (setq waiting entry))))
+ (when (and waiting
+ (< running url-queue-parallel-processes))
+ (setf (url-queue-start-time waiting) (float-time))
+ (url-queue-start-retrieve waiting))))
+
+(defun url-queue-callback-function (status job)
+ (setq url-queue (delq job url-queue))
+ (url-queue-run-queue)
+ (apply (url-queue-callback job) (cons status (url-queue-cbargs job))))
+
+(defun url-queue-start-retrieve (job)
+ (setf (url-queue-buffer job)
+ (ignore-errors
+ (url-retrieve (url-queue-url job)
+ #'url-queue-callback-function (list job)
+ (url-queue-silentp job)))))
+
+(defun url-queue-prune-old-entries ()
+ (let (dead-jobs)
+ (dolist (job url-queue)
+ ;; Kill jobs that have lasted longer than the timeout.
+ (when (and (url-queue-start-time job)
+ (> (- (float-time) (url-queue-start-time job))
+ url-queue-timeout))
+ (push job dead-jobs)))
+ (dolist (job dead-jobs)
+ (when (bufferp (url-queue-buffer job))
+ (while (get-buffer-process (url-queue-buffer job))
+ (ignore-errors
+ (delete-process (get-buffer-process (url-queue-buffer job)))))
+ (ignore-errors
+ (kill-buffer (url-queue-buffer job))))
+ (setq url-queue (delq job url-queue)))))
+
+(provide 'url-queue)
+
+;;; url-queue.el ends here
diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el
index d63fc3e2838..6bf3a5831ec 100644
--- a/lisp/url/url-util.el
+++ b/lisp/url/url-util.el
@@ -1,7 +1,6 @@
;;; url-util.el --- Miscellaneous helper routines for URL library
-;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1999, 2001, 2004-2011 Free Software Foundation, Inc.
;; Author: Bill Perry <wmperry@gnu.org>
;; Keywords: comm, data, processes
@@ -43,7 +42,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 +176,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 +223,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 +247,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 +256,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 +435,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 +454,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)
@@ -531,5 +531,4 @@ Creates FILE and its parent directories if they do not exist."
(provide 'url-util)
-;; arch-tag: 24352abc-5a5a-412e-90cd-313b26bed5c9
;;; url-util.el ends here
diff --git a/lisp/url/url-vars.el b/lisp/url/url-vars.el
index 4732a57a069..42d33553e14 100644
--- a/lisp/url/url-vars.el
+++ b/lisp/url/url-vars.el
@@ -1,7 +1,6 @@
;;; url-vars.el --- Variables for Uniform Resource Locator tool
-;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1999, 2001, 2004-2011 Free Software Foundation, Inc.
;; Keywords: comm, data, processes, hypermedia
@@ -30,7 +29,7 @@
(defgroup url nil
"Uniform Resource Locator tool."
:version "22.1"
- :group 'hypermedia)
+ :group 'comm)
(defgroup url-file nil
"URL storage."
@@ -68,7 +67,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 +78,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 +156,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 +171,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 +180,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 +192,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 +233,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 +245,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 +274,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 +298,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 +310,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 +326,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:
@@ -399,5 +389,4 @@ This should be set, e.g. by mail user agents rendering HTML to avoid
(provide 'url-vars)
-;; arch-tag: 29205e5f-c5ce-433c-8d5d-38cbaed64b49
;;; url-vars.el ends here
diff --git a/lisp/url/url.el b/lisp/url/url.el
index 52368dbbd5a..7136b6023ce 100644
--- a/lisp/url/url.el
+++ b/lisp/url/url.el
@@ -1,7 +1,6 @@
;;; url.el --- Uniform Resource Locator retrieval tool
-;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1999, 2001, 2004-2011 Free Software Foundation, Inc.
;; Author: Bill Perry <wmperry@gnu.org>
;; Keywords: comm, data, processes, hypermedia
@@ -29,11 +28,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 +120,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 +142,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 +155,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 +173,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 +183,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
@@ -319,5 +325,4 @@ no further processing). URL is either a string or a parsed URL."
(provide 'url)
-;; arch-tag: bc182f1f-d187-4f10-b961-47af2066579a
;;; url.el ends here
diff --git a/lisp/userlock.el b/lisp/userlock.el
index 84b5c47e71b..7a2f7f76b78 100644
--- a/lisp/userlock.el
+++ b/lisp/userlock.el
@@ -1,7 +1,6 @@
;;; userlock.el --- handle file access contention between multiple users
-;; Copyright (C) 1985, 1986, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1986, 2001-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
@@ -157,5 +156,4 @@ to get the latest version of the file, then make the change again.")
(with-current-buffer standard-output
(help-mode))))
-;; arch-tag: a61c5b60-e1c8-44fd-894a-c617f4dfc639
;;; userlock.el ends here
diff --git a/lisp/add-log.el b/lisp/vc/add-log.el
index ae71bcb40ce..73e83414e99 100644
--- a/lisp/add-log.el
+++ b/lisp/vc/add-log.el
@@ -1,11 +1,10 @@
;;; add-log.el --- change log maintenance commands for Emacs
-;; Copyright (C) 1985, 1986, 1988, 1993, 1994, 1997, 1998, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+;; Copyright (C) 1985-1986, 1988, 1993-1994, 1997-1998, 2000-2011
;; Free Software Foundation, Inc.
;; Maintainer: FSF
-;; Keywords: tools
+;; Keywords: vc tools
;; This file is part of GNU Emacs.
@@ -37,9 +36,6 @@
;;; Code:
-(eval-when-compile
- (require 'timezone))
-
(defgroup change-log nil
"Change log maintenance."
:group 'tools
@@ -245,7 +241,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
@@ -281,7 +277,7 @@ Note: The search is conducted only within 10%, at the beginning of the file."
;; Note that the FSF does not use "Patches by"; our convention
;; is to put the name of the author of the changes at the top
;; of the change log entry.
- ("\\(^\\( +\\|\t\\)\\| \\)\\(Patch\\(es\\)? by\\|Report\\(ed by\\| from\\)\\|Suggest\\(ed by\\|ion from\\)\\)"
+ ("\\(^\\( +\\|\t\\)\\| \\)\\(Thanks to\\|Patch\\(es\\)? by\\|Report\\(ed by\\| from\\)\\|Suggest\\(ed by\\|ion from\\)\\)"
3 'change-log-acknowledgement))
"Additional expressions to highlight in Change Log mode.")
@@ -755,7 +751,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.
@@ -880,7 +886,7 @@ non-nil, otherwise in local time."
(point))))
;; Now insert the new line for this item.
- (cond ((re-search-forward "^\\s *\\*\\s *$" bound t)
+ (cond ((re-search-forward "^\\s *\\* *$" bound t)
;; Put this file name into the existing empty item.
(if item
(insert item)))
@@ -922,7 +928,7 @@ non-nil, otherwise in local time."
;; No function name, so put in a colon unless we have just a star.
(unless (save-excursion
(beginning-of-line 1)
- (looking-at "\\s *\\(\\*\\s *\\)?$"))
+ (looking-at "\\s *\\(\\* *\\)?$"))
(insert ": ")
(if version (insert version ?\s)))
;; Make it easy to get rid of the function name.
@@ -1242,19 +1248,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 ()
@@ -1361,5 +1366,4 @@ old-style time formats for entries are supported."
(provide 'add-log)
-;; arch-tag: 81eee6fc-088f-4372-a37f-80ad9620e762
;;; add-log.el ends here
diff --git a/lisp/compare-w.el b/lisp/vc/compare-w.el
index 65f7ce93547..4c63e48a3fc 100644
--- a/lisp/compare-w.el
+++ b/lisp/vc/compare-w.el
@@ -1,10 +1,10 @@
;;; compare-w.el --- compare text between windows for Emacs
-;; Copyright (C) 1986, 1989, 1993, 1997, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1986, 1989, 1993, 1997, 2001-2011
+;; Free Software Foundation, Inc.
;; Maintainer: FSF
-;; Keywords: convenience files
+;; Keywords: convenience files vc
;; This file is part of GNU Emacs.
@@ -389,5 +389,4 @@ on third call it again advances points to the next difference and so on."
(provide 'compare-w)
-;; arch-tag: 4177aab1-48e6-4a98-b7a1-000ee285de46
;;; compare-w.el ends here
diff --git a/lisp/cvs-status.el b/lisp/vc/cvs-status.el
index ffad44ab7ff..063eb414579 100644
--- a/lisp/cvs-status.el
+++ b/lisp/vc/cvs-status.el
@@ -1,10 +1,9 @@
-;;; cvs-status.el --- major mode for browsing `cvs status' output -*- coding: utf-8 -*-
+;;; cvs-status.el --- major mode for browsing `cvs status' output -*- coding: utf-8; lexical-binding: t -*-
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 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.
@@ -88,6 +87,12 @@
'(cvs-status-font-lock-keywords t nil nil nil (font-lock-multiline . t)))
(defvar cvs-minor-wrap-function)
+(defvar cvs-force-command)
+(defvar cvs-minor-current-files)
+(defvar cvs-secondary-branch-prefix)
+(defvar cvs-branch-prefix)
+(defvar cvs-tag-print-rev)
+
(put 'cvs-status-mode 'mode-class 'special)
;;;###autoload
(define-derived-mode cvs-status-mode fundamental-mode "CVS-Status"
@@ -223,7 +228,6 @@ The tree will be printed no closer than column COLUMN."
(let* ((eol (save-excursion (end-of-line) (current-column)))
(column (max (+ eol 2) column)))
(if (null tags) column
- ;;(move-to-column-force column)
(let* ((rev (cvs-car tags))
(name (funcall printer (cvs-car rev)))
(rest (append (cvs-cdr name) (cvs-cdr tags)))
@@ -356,11 +360,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."
@@ -474,7 +478,7 @@ Optional prefix ARG chooses between two representations."
(nprev (if (and cvs-tree-nomerge next
(equal vlist (cvs-tag->vlist next)))
prev vlist)))
- (cvs-map (lambda (v p) v) nprev prev)))
+ (cvs-map (lambda (v _p) v) nprev prev)))
(after (save-excursion
(newline)
(cvs-tree-tags-insert (cdr tags) nprev)))
@@ -514,27 +518,26 @@ Optional prefix ARG chooses between two representations."
;;;; Merged trees from different files
;;;;
-(defun cvs-tree-fuzzy-merge-1 (trees tree prev)
- )
+;; (defun cvs-tree-fuzzy-merge-1 (trees tree prev)
+;; )
-(defun cvs-tree-fuzzy-merge (trees tree)
- "Do the impossible: merge TREE into TREES."
- ())
+;; (defun cvs-tree-fuzzy-merge (trees tree)
+;; "Do the impossible: merge TREE into TREES."
+;; ())
-(defun cvs-tree ()
- "Get tags from the status output and merge tham all into a big tree."
- (save-excursion
- (goto-char (point-min))
- (let ((inhibit-read-only t)
- (trees (make-vector 31 0)) tree)
- (while (listp (setq tree (cvs-tags->tree (cvs-status-get-tags))))
- (cvs-tree-fuzzy-merge trees tree))
- (erase-buffer)
- (let ((cvs-tag-print-rev nil))
- (cvs-tree-print tree 'cvs-tag->string 3)))))
+;; (defun cvs-tree ()
+;; "Get tags from the status output and merge them all into a big tree."
+;; (save-excursion
+;; (goto-char (point-min))
+;; (let ((inhibit-read-only t)
+;; (trees (make-vector 31 0)) tree)
+;; (while (listp (setq tree (cvs-tags->tree (cvs-status-get-tags))))
+;; (cvs-tree-fuzzy-merge trees tree))
+;; (erase-buffer)
+;; (let ((cvs-tag-print-rev nil))
+;; (cvs-tree-print tree 'cvs-tag->string 3)))))
(provide 'cvs-status)
-;; arch-tag: db8b5094-d02a-473e-a476-544e89ff5ad0
;;; cvs-status.el ends here
diff --git a/lisp/diff-mode.el b/lisp/vc/diff-mode.el
index b02c5d911d8..22dac00e7e4 100644
--- a/lisp/diff-mode.el
+++ b/lisp/vc/diff-mode.el
@@ -1,10 +1,9 @@
-;;; diff-mode.el --- a mode for viewing/editing context diffs
+;;; diff-mode.el --- a mode for viewing/editing context diffs -*- lexical-binding: t -*-
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 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.
@@ -123,8 +122,7 @@ when editing big diffs)."
("\C-m" . diff-goto-source)
([mouse-2] . diff-goto-source)
;; From XEmacs' diff-mode.
- ;; Standard M-w is useful, so don't change M-W.
- ;;("W" . widen)
+ ("W" . widen)
;;("." . diff-goto-source) ;display-buffer
;;("f" . diff-goto-source) ;find-file
("o" . diff-goto-source) ;other-window
@@ -136,17 +134,21 @@ when editing big diffs)."
;; Not useful if you have to metafy them.
;;(" " . scroll-up)
;;("\177" . scroll-down)
- ;; Standard M-a is useful, so don't change M-A.
- ;;("A" . diff-ediff-patch)
- ;; Standard M-r is useful, so don't change M-r or M-R.
- ;;("r" . diff-restrict-view)
- ;;("R" . diff-reverse-direction)
- ("g" . revert-buffer)
- ("q" . quit-window))
- "Basic keymap for `diff-mode', bound to various prefix keys.")
+ ("A" . diff-ediff-patch)
+ ("r" . diff-restrict-view)
+ ("R" . diff-reverse-direction))
+ "Basic keymap for `diff-mode', bound to various prefix keys."
+ :inherit special-mode-map)
(easy-mmode-defmap diff-mode-map
- `(("\e" . ,diff-mode-shared-map)
+ `(("\e" . ,(let ((map (make-sparse-keymap)))
+ ;; We want to inherit most bindings from diff-mode-shared-map,
+ ;; but not all since they may hide useful M-<foo> global
+ ;; bindings when editing.
+ (set-keymap-parent map diff-mode-shared-map)
+ (dolist (key '("A" "r" "R" "g" "q" "W"))
+ (define-key map key nil))
+ map))
;; From compilation-minor-mode.
("\C-c\C-c" . diff-goto-source)
;; By analogy with the global C-x 4 a binding.
@@ -812,7 +814,7 @@ PREFIX is only used internally: don't use it."
(defun diff-ediff-patch ()
"Call `ediff-patch-file' on the current buffer."
(interactive)
- (condition-case err
+ (condition-case nil
(ediff-patch-file nil (current-buffer))
(wrong-number-of-arguments (ediff-patch-file))))
@@ -1169,7 +1171,7 @@ else cover the whole buffer."
;; *-change-function is asking for trouble, whereas making them
;; from a post-command-hook doesn't pose much problems
(defvar diff-unhandled-changes nil)
-(defun diff-after-change-function (beg end len)
+(defun diff-after-change-function (beg end _len)
"Remember to fixup the hunk header.
See `after-change-functions' for the meaning of BEG, END and LEN."
;; Ignoring changes when inhibit-read-only is set is strictly speaking
@@ -1267,7 +1269,7 @@ a diff with \\[diff-reverse-direction].
;; Set up `whitespace-mode' so that turning it on will show trailing
;; whitespace problems on the modified lines of the diff.
- (set (make-local-variable 'whitespace-style) '(trailing))
+ (set (make-local-variable 'whitespace-style) '(face trailing))
(set (make-local-variable 'whitespace-trailing-regexp)
"^[-\+!<>].*?\\([\t ]+\\)$")
@@ -1279,7 +1281,7 @@ a diff with \\[diff-reverse-direction].
(add-hook 'after-change-functions 'diff-after-change-function nil t)
(add-hook 'post-command-hook 'diff-post-command-hook nil t))
;; Neat trick from Dave Love to add more bindings in read-only mode:
- (lexical-let ((ro-bind (cons 'buffer-read-only diff-mode-shared-map)))
+ (let ((ro-bind (cons 'buffer-read-only diff-mode-shared-map)))
(add-to-list 'minor-mode-overriding-map-alist ro-bind)
;; Turn off this little trick in case the buffer is put in view-mode.
(add-hook 'view-mode-hook
@@ -1291,7 +1293,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
@@ -1689,7 +1693,7 @@ With a prefix argument, REVERSE the hunk."
"See whether it's possible to apply the current hunk.
With a prefix argument, try to REVERSE the hunk."
(interactive "P")
- (destructuring-bind (buf line-offset pos src dst &optional switched)
+ (destructuring-bind (buf line-offset pos src _dst &optional switched)
(diff-find-source-location nil reverse)
(set-window-point (display-buffer buf) (+ (car pos) (cdr src)))
(diff-hunk-status-msg line-offset (diff-xor reverse switched) t)))
@@ -1709,7 +1713,7 @@ then `diff-jump-to-old-file' is also set, for the next invocations."
;; This is a convenient detail when using smerge-diff.
(if event (posn-set-point (event-end event)))
(let ((rev (not (save-excursion (beginning-of-line) (looking-at "[-<]")))))
- (destructuring-bind (buf line-offset pos src dst &optional switched)
+ (destructuring-bind (buf line-offset pos src _dst &optional switched)
(diff-find-source-location other-file rev)
(pop-to-buffer buf)
(goto-char (+ (car pos) (cdr src)))
@@ -1727,7 +1731,7 @@ For use in `add-log-current-defun-function'."
(when (looking-at diff-hunk-header-re)
(forward-line 1)
(re-search-forward "^[^ ]" nil t))
- (destructuring-bind (&optional buf line-offset pos src dst switched)
+ (destructuring-bind (&optional buf _line-offset pos src dst switched)
;; Use `noprompt' since this is used in which-func-mode and such.
(ignore-errors ;Signals errors in place of prompting.
(diff-find-source-location nil nil 'noprompt))
@@ -1821,10 +1825,13 @@ For use in `add-log-current-defun-function'."
(replace-match (cdr (assq (char-before) '((?+ . "-") (?> . "<"))))))
)
+(declare-function smerge-refine-subst "smerge-mode"
+ (beg1 end1 beg2 end2 props &optional preproc))
+
(defun diff-refine-hunk ()
"Highlight changes of hunk at point at a finer granularity."
(interactive)
- (eval-and-compile (require 'smerge-mode))
+ (require 'smerge-mode)
(save-excursion
(diff-beginning-of-hunk 'try-harder)
(let* ((start (point))
@@ -1875,28 +1882,27 @@ I.e. like `add-change-log-entry-other-window' but applied to all hunks."
;; good to call it for each change.
(save-excursion
(goto-char (point-min))
- (let ((orig-buffer (current-buffer)))
- (condition-case nil
- ;; Call add-change-log-entry-other-window for each hunk in
- ;; the diff buffer.
- (while (progn
- (diff-hunk-next)
- ;; Move to where the changes are,
- ;; `add-change-log-entry-other-window' works better in
- ;; that case.
- (re-search-forward
- (concat "\n[!+-<>]"
- ;; If the hunk is a context hunk with an empty first
- ;; half, recognize the "--- NNN,MMM ----" line
- "\\(-- [0-9]+\\(,[0-9]+\\)? ----\n"
- ;; and skip to the next non-context line.
- "\\( .*\n\\)*[+]\\)?")
- nil t))
- (save-excursion
- ;; FIXME: this pops up windows of all the buffers.
- (add-change-log-entry nil nil t nil t)))
- ;; When there's no more hunks, diff-hunk-next signals an error.
- (error nil)))))
+ (condition-case nil
+ ;; Call add-change-log-entry-other-window for each hunk in
+ ;; the diff buffer.
+ (while (progn
+ (diff-hunk-next)
+ ;; Move to where the changes are,
+ ;; `add-change-log-entry-other-window' works better in
+ ;; that case.
+ (re-search-forward
+ (concat "\n[!+-<>]"
+ ;; If the hunk is a context hunk with an empty first
+ ;; half, recognize the "--- NNN,MMM ----" line
+ "\\(-- [0-9]+\\(,[0-9]+\\)? ----\n"
+ ;; and skip to the next non-context line.
+ "\\( .*\n\\)*[+]\\)?")
+ nil t))
+ (save-excursion
+ ;; FIXME: this pops up windows of all the buffers.
+ (add-change-log-entry nil nil t nil t)))
+ ;; When there's no more hunks, diff-hunk-next signals an error.
+ (error nil))))
;; provide the package
(provide 'diff-mode)
@@ -1936,5 +1942,4 @@ I.e. like `add-change-log-entry-other-window' but applied to all hunks."
;; use `combine-after-change-calls' to minimize the slowdown of font-lock.
;;
-;; arch-tag: 2571d7ff-bc28-4cf9-8585-42e21890be66
;;; diff-mode.el ends here
diff --git a/lisp/diff.el b/lisp/vc/diff.el
index 7bf2724c4a5..9655ce64a99 100644
--- a/lisp/diff.el
+++ b/lisp/vc/diff.el
@@ -1,12 +1,11 @@
-;;; diff.el --- run `diff' in compilation-mode
+;;; diff.el --- run `diff'
-;; Copyright (C) 1992, 1994, 1996, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 1994, 1996, 2001-2011 Free Software Foundation, Inc.
;; 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 +30,8 @@
;;; Code:
+(eval-when-compile (require 'cl))
+
(defgroup diff nil
"Comparing files with `diff'."
:group 'tools)
@@ -47,11 +48,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 +56,14 @@
diff-switches
(mapconcat 'identity diff-switches " ")))))
-(defun diff-sentinel (code)
+(defun diff-sentinel (code &optional 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))
+were found.
+If optional args OLD-TEMP-FILE and/or NEW-TEMP-FILE are non-nil,
+delete the temporary files so named."
+ (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 +73,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 +85,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 +100,74 @@ 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-no-select (old new &optional switches no-async buf)
+ ;; Noninteractive helper for creating and reverting diff buffers
+ (unless (bufferp new) (setq new (expand-file-name new)))
+ (unless (bufferp old) (setq old (expand-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,7 +206,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.el ends here
diff --git a/lisp/ediff-diff.el b/lisp/vc/ediff-diff.el
index b2ebfadc963..078947e8501 100644
--- a/lisp/ediff-diff.el
+++ b/lisp/vc/ediff-diff.el
@@ -1,9 +1,9 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-2011 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
;; This file is part of GNU Emacs.
@@ -53,8 +53,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 +83,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 +1227,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 +1530,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 79b6b5decf6..ddd9371b060 100644
--- a/lisp/ediff-help.el
+++ b/lisp/vc/ediff-help.el
@@ -1,9 +1,9 @@
;;; ediff-help.el --- Code related to the contents of Ediff help buffers
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
;; This file is part of GNU Emacs.
@@ -317,5 +317,4 @@ the value of this variable and the variables `ediff-help-message-*' in
(provide 'ediff-help)
-;; arch-tag: 05659813-7fcf-4274-964f-d2f577431a9d
;;; ediff-help.el ends here
diff --git a/lisp/ediff-hook.el b/lisp/vc/ediff-hook.el
index 10b9ac0394f..7598cfdba51 100644
--- a/lisp/ediff-hook.el
+++ b/lisp/vc/ediff-hook.el
@@ -1,9 +1,9 @@
;;; ediff-hook.el --- setup for Ediff's menus and autoloads
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-2011 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
;; This file is part of GNU Emacs.
@@ -259,5 +259,4 @@
(provide 'ediff-hook)
-;; arch-tag: 512f8656-8a4b-4789-af5d-5c6144498df3
;;; ediff-hook.el ends here
diff --git a/lisp/ediff-init.el b/lisp/vc/ediff-init.el
index 06a29b84997..0d904ec85c4 100644
--- a/lisp/ediff-init.el
+++ b/lisp/vc/ediff-init.el
@@ -1,9 +1,9 @@
;;; ediff-init.el --- Macros, variables, and defsubsts used by Ediff
-;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-2011 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
;; This file is part of GNU Emacs.
@@ -560,7 +560,6 @@ See the documentation string of `ediff-focus-on-regexp-matches' for details.")
:group 'ediff)
-(ediff-defvar-local ediff-use-faces t "")
(defcustom ediff-use-faces t
"If t, differences are highlighted using faces, if device supports faces.
If nil, differences are highlighted using ASCII flags, ediff-before-flag
@@ -568,6 +567,7 @@ and ediff-after-flag. On a non-window system, differences are always
highlighted using ASCII flags."
:type 'boolean
:group 'ediff-highlighting)
+(ediff-defvar-local ediff-use-faces t "")
;; this indicates that diff regions are word-size, so fine diffs are
;; permanently nixed; used in ediff-windows-wordwise and ediff-regions-wordwise
@@ -604,13 +604,13 @@ meaning of this variable."
:type 'boolean
:group 'ediff)
-(ediff-defvar-local ediff-highlight-all-diffs t "")
(defcustom ediff-highlight-all-diffs t
"If nil, only the selected differences are highlighted.
Otherwise, all difference regions are highlighted, but the selected region is
shown in brighter colors."
:type 'boolean
:group 'ediff-highlighting)
+(ediff-defvar-local ediff-highlight-all-diffs t "")
;; The suffix of the control buffer name.
@@ -786,16 +786,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
@@ -1817,5 +1807,4 @@ Unless optional argument INPLACE is non-nil, return a new string."
;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
;; End:
-;; arch-tag: fa31d384-1e70-4d4b-82a7-3e96307c46f5
;;; ediff-init.el ends here
diff --git a/lisp/ediff-merg.el b/lisp/vc/ediff-merg.el
index 42cfcd521f5..a584d0791ff 100644
--- a/lisp/ediff-merg.el
+++ b/lisp/vc/ediff-merg.el
@@ -1,9 +1,9 @@
;;; ediff-merg.el --- merging utilities
-;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-2011 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
;; This file is part of GNU Emacs.
@@ -393,5 +393,4 @@ Combining is done according to the specifications in variable
;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
;; End:
-;; arch-tag: 9b798cf9-02ba-487f-a62e-b63aa823dbfb
;;; ediff-merg.el ends here
diff --git a/lisp/ediff-mult.el b/lisp/vc/ediff-mult.el
index f9ff78977cc..cadcdec29b4 100644
--- a/lisp/ediff-mult.el
+++ b/lisp/vc/ediff-mult.el
@@ -1,9 +1,9 @@
;;; ediff-mult.el --- support for multi-file/multi-buffer processing in Ediff
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-2011 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
;; This file is part of GNU Emacs.
@@ -457,6 +457,7 @@ It is entered through one of the following commands:
Commands:
\\{ediff-meta-buffer-map}"
+ ;; FIXME: Use define-derived-mode.
(kill-all-local-variables)
(setq major-mode 'ediff-meta-mode)
(setq mode-name "MetaEdiff")
@@ -2472,5 +2473,4 @@ for operation, or simply indicate which are equal files. If it is nil, then
;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
;; End:
-;; arch-tag: c8a76898-f96f-4d9c-be9d-129134017188
;;; ediff-mult.el ends here
diff --git a/lisp/ediff-ptch.el b/lisp/vc/ediff-ptch.el
index 26de8ca5828..d930a1bec69 100644
--- a/lisp/ediff-ptch.el
+++ b/lisp/vc/ediff-ptch.el
@@ -1,9 +1,9 @@
;;; ediff-ptch.el --- Ediff's patch support
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
;; This file is part of GNU Emacs.
@@ -61,7 +61,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 +840,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 6128ca46cd1..92f52157cb2 100644
--- a/lisp/ediff-util.el
+++ b/lisp/vc/ediff-util.el
@@ -1,9 +1,9 @@
;;; 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, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-2011 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
;; This file is part of GNU Emacs.
@@ -92,6 +92,7 @@ This mode is entered through one of the following commands:
Commands:
\\{ediff-mode-map}"
+ ;; FIXME: Use define-derived-mode.
(kill-all-local-variables)
(setq major-mode 'ediff-mode)
(setq mode-name "Ediff")
@@ -309,7 +310,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 +3994,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 +4288,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 576d8f687c2..804e62a2933 100644
--- a/lisp/ediff-vers.el
+++ b/lisp/vc/ediff-vers.el
@@ -1,9 +1,9 @@
;;; ediff-vers.el --- version control interface to Ediff
-;; Copyright (C) 1995, 1996, 1997, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995-1997, 2001-2011 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
;; This file is part of GNU Emacs.
@@ -235,5 +235,4 @@ comparison or merge operations are being performed."
;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
;; End:
-;; arch-tag: bbb34f0c-2a90-426a-a77a-c75f479ebbbf
;;; ediff-vers.el ends here
diff --git a/lisp/ediff-wind.el b/lisp/vc/ediff-wind.el
index db4b57cbe07..5a7fa0bf950 100644
--- a/lisp/ediff-wind.el
+++ b/lisp/vc/ediff-wind.el
@@ -1,9 +1,9 @@
;;; ediff-wind.el --- window manipulation utilities
-;; Copyright (C) 1994, 1995, 1996, 1997, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1997, 2000-2011 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
;; This file is part of GNU Emacs.
@@ -977,12 +977,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 +1308,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 bdd8b88e094..5e352493dc9 100644
--- a/lisp/ediff.el
+++ b/lisp/vc/ediff.el
@@ -1,11 +1,11 @@
;;; ediff.el --- a comprehensive visual interface to diff & patch
-;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-2011 Free Software Foundation, Inc.
;; 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
@@ -1561,5 +1561,4 @@ With optional NODE, goes to that node."
;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
;; End:
-;; arch-tag: 97c71396-db02-4f41-8b48-6a51c3348fcc
;;; ediff.el ends here
diff --git a/lisp/emerge.el b/lisp/vc/emerge.el
index ffae5529e1c..5435a840ac9 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
@@ -1283,10 +1271,10 @@ Otherwise, the A or B file present is copied to the output file."
(defun emerge-merge-directories (a-dir b-dir ancestor-dir output-dir)
(interactive
(list
- (read-file-name "A directory: " nil nil 'confirm)
- (read-file-name "B directory: " nil nil 'confirm)
- (read-file-name "Ancestor directory (null for none): " nil nil 'confirm)
- (read-file-name "Output directory (null for none): " nil nil 'confirm)))
+ (read-directory-name "A directory: " nil nil 'confirm)
+ (read-directory-name "B directory: " nil nil 'confirm)
+ (read-directory-name "Ancestor directory (null for none): " nil nil 'confirm)
+ (read-directory-name "Output directory (null for none): " nil nil 'confirm)))
;; Check that we're not on a line
(if (not (and (bolp) (eolp)))
(error "There is text on this line"))
@@ -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 \!.
@@ -3210,5 +3199,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 373cc31e0cd..b3f5cfb78f7 100644
--- a/lisp/log-edit.el
+++ b/lisp/vc/log-edit.el
@@ -1,10 +1,9 @@
-;;; log-edit.el --- Major mode for editing CVS commit messages
+;;; log-edit.el --- Major mode for editing CVS commit messages -*- lexical-binding: t -*-
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 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 +148,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
@@ -330,7 +329,7 @@ automatically."
(defconst log-edit-header-contents-regexp
"[ \t]*\\(.*\\(\n[ \t].*\\)*\\)\n?")
-(defun log-edit-match-to-eoh (limit)
+(defun log-edit-match-to-eoh (_limit)
;; FIXME: copied from message-match-to-eoh.
(let ((start (point)))
(rfc822-goto-eoh)
@@ -362,7 +361,7 @@ automatically."
nil lax)))))
;;;###autoload
-(defun log-edit (callback &optional setup params buffer mode &rest ignore)
+(defun log-edit (callback &optional setup params buffer mode &rest _ignore)
"Setup a buffer to enter a log message.
\\<log-edit-mode-map>The buffer will be put in mode MODE or `log-edit-mode'
if MODE is nil.
@@ -418,7 +417,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)))
@@ -531,13 +531,25 @@ If you want to abort the commit, simply delete the buffer."
(shrink-window-if-larger-than-buffer)
(selected-window)))))
+(defun log-edit-empty-buffer-p ()
+ "Return non-nil if the buffer is \"empty\"."
+ (or (= (point-min) (point-max))
+ (save-excursion
+ (goto-char (point-min))
+ (while (and (looking-at "^\\(Summary: \\)?$")
+ (zerop (forward-line 1))))
+ (eobp))))
+
(defun log-edit-insert-cvs-template ()
"Insert the template specified by the CVS administrator, if any.
This simply uses the local CVS/Template file."
(interactive)
(when (or (called-interactively-p 'interactive)
- (= (point-min) (point-max)))
+ (log-edit-empty-buffer-p))
+ ;; Should the template take precedence over an empty Summary:,
+ ;; ie should we first erase the buffer?
(when (file-readable-p "CVS/Template")
+ (goto-char (point-max))
(insert-file-contents "CVS/Template"))))
(defun log-edit-insert-cvs-rcstemplate ()
@@ -546,8 +558,9 @@ This contacts the repository to get the rcstemplate file and
can thus take some time."
(interactive)
(when (or (called-interactively-p 'interactive)
- (= (point-min) (point-max)))
+ (log-edit-empty-buffer-p))
(when (file-readable-p "CVS/Root")
+ (goto-char (point-max))
;; Ignore the stderr stuff, even if it's an error.
(call-process "cvs" nil '(t nil) nil
"checkout" "-p" "CVSROOT/rcstemplate"))))
@@ -878,5 +891,4 @@ anyway and put back as the first line of MSG."
(provide 'log-edit)
-;; arch-tag: 8089b39c-983b-4e83-93cd-ed0a64c7fdcc
;;; log-edit.el ends here
diff --git a/lisp/log-view.el b/lisp/vc/log-view.el
index 7f8775e94fa..9f6ad19fdb1 100644
--- a/lisp/log-view.el
+++ b/lisp/vc/log-view.el
@@ -1,10 +1,9 @@
-;;; log-view.el --- Major mode for browsing RCS/CVS/SCCS log output
+;;; log-view.el --- Major mode for browsing RCS/CVS/SCCS log output -*- lexical-binding: t -*-
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 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.
@@ -116,19 +115,21 @@
(autoload 'vc-diff-internal "vc")
(defvar cvs-minor-wrap-function)
+(defvar cvs-force-command)
(defgroup log-view nil
"Major mode for browsing log output of RCS/CVS/SCCS."
:group 'pcl-cvs
:prefix "log-view-")
-;; Needed because log-view-mode-map inherits from widget-keymap. (Bug#5311)
-(require 'wid-edit)
-
(easy-mmode-defmap log-view-mode-map
- '(("z" . kill-this-buffer)
+ '(
+ ;; FIXME: (copy-keymap special-mode-map) instead
+ ("z" . kill-this-buffer)
("q" . quit-window)
("g" . revert-buffer)
+ ("\C-m" . log-view-toggle-entry-display)
+
("m" . log-view-toggle-mark-entry)
("e" . log-view-modify-change-comment)
("d" . log-view-diff)
@@ -145,7 +146,6 @@
("\M-n" . log-view-file-next)
("\M-p" . log-view-file-prev))
"Log-View's keymap."
- :inherit widget-keymap
:group 'log-view)
(easy-menu-define log-view-mode-menu log-view-mode-map
@@ -166,6 +166,8 @@
:help "Annotate the version at point"]
["Modify Log Comment" log-view-modify-change-comment
:help "Edit the change comment displayed at point"]
+ ["Toggle Details at Point" log-view-toggle-entry-display
+ :active log-view-expanded-log-entry-function]
"-----"
["Next Log Entry" log-view-msg-next
:help "Go to the next count'th log message"]
@@ -179,6 +181,12 @@
(defvar log-view-mode-hook nil
"Hook run at the end of `log-view-mode'.")
+(defvar log-view-expanded-log-entry-function nil
+ "Function returning the detailed description of a Log View entry.
+It is called by the command `log-view-toggle-entry-display' with
+one arg, the revision tag (a string), and should return a string.
+If it is nil, `log-view-toggle-entry-display' does nothing.")
+
(defface log-view-file
'((((class color) (background light))
(:background "grey70" :weight bold))
@@ -256,7 +264,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
@@ -297,15 +306,36 @@ The match group number 1 should match the revision number itself.")
(when cvsdir (setq dir (expand-file-name cvsdir dir))))
(expand-file-name file dir))))
-(defun log-view-current-tag (&optional where)
- (save-excursion
- (when where (goto-char where))
- (forward-line 1)
- (let ((pt (point)))
- (when (re-search-backward log-view-message-re nil t)
- (let ((rev (match-string-no-properties 1)))
- (unless (re-search-forward log-view-file-re pt t)
- rev))))))
+(defun log-view-current-entry (&optional pos move)
+ "Return the position and revision tag of the Log View entry at POS.
+This is a list (BEG TAG), where BEG is a buffer position and TAG
+is a string. If POS is nil or omitted, it defaults to point.
+If there is no entry at POS, return nil.
+
+If optional arg MOVE is non-nil, move point to BEG if found.
+Otherwise, don't move point."
+ (let ((looping t)
+ result)
+ (save-excursion
+ (when pos (goto-char pos))
+ (forward-line 1)
+ (while looping
+ (setq pos (re-search-backward log-view-message-re nil 'move)
+ looping (and pos (log-view-inside-comment-p (point)))))
+ (when pos
+ (setq result
+ (list pos (match-string-no-properties 1)))))
+ (and move result (goto-char pos))
+ result))
+
+(defun log-view-inside-comment-p (pos)
+ "Return non-nil if POS lies inside an expanded log entry."
+ (eq (get-text-property pos 'log-view-comment) t))
+
+(defun log-view-current-tag (&optional pos)
+ "Return the revision tag (a string) of the Log View entry at POS.
+if POS is omitted or nil, it defaults to point."
+ (cadr (log-view-current-entry pos)))
(defun log-view-toggle-mark-entry ()
"Toggle the marked state for the log entry at point.
@@ -315,29 +345,24 @@ entries are denoted by changing their background color.
log entries."
(interactive)
(save-excursion
- (forward-line 1)
- (let ((pt (point)))
- (when (re-search-backward log-view-message-re nil t)
- (let ((beg (match-beginning 0))
- end ov ovlist found tag)
- (unless (re-search-forward log-view-file-re pt t)
- ;; Look to see if the current entry is marked.
- (setq found (get-char-property (point) 'log-view-self))
- (if found
- (delete-overlay found)
- ;; Create an overlay that covers this entry and change
- ;; its color.
- (setq tag (log-view-current-tag (point)))
- (forward-line 1)
- (setq end
- (if (re-search-forward log-view-message-re nil t)
- (match-beginning 0)
- (point-max)))
- (setq ov (make-overlay beg end))
- (overlay-put ov 'face 'log-view-file)
- ;; This is used to check if the overlay is present.
- (overlay-put ov 'log-view-self ov)
- (overlay-put ov 'log-view-marked tag))))))))
+ (let* ((entry (log-view-current-entry nil t))
+ (beg (car entry))
+ found)
+ (when entry
+ ;; Look to see if the current entry is marked.
+ (setq found (get-char-property beg 'log-view-self))
+ (if found
+ (delete-overlay found)
+ ;; Create an overlay covering this entry and change its color.
+ (let* ((end (if (get-text-property beg 'log-view-entry-expanded)
+ (next-single-property-change beg 'log-view-comment)
+ (log-view-end-of-defun)
+ (point)))
+ (ov (make-overlay beg end)))
+ (overlay-put ov 'face 'log-view-file)
+ ;; This is used to check if the overlay is present.
+ (overlay-put ov 'log-view-self ov)
+ (overlay-put ov 'log-view-marked (nth 1 entry))))))))
(defun log-view-get-marked ()
"Return the list of tags for the marked log entries."
@@ -350,50 +375,74 @@ log entries."
(setq pos (overlay-end ov))))
marked-list)))
-(defun log-view-beginning-of-defun ()
- ;; This assumes that a log entry starts with a line matching
- ;; `log-view-message-re'. Modes that derive from `log-view-mode'
- ;; for which this assumption is not valid will have to provide
- ;; another implementation of this function. `log-view-msg-prev'
- ;; does a similar job to this function, we can't use it here
- ;; directly because it prints messages that are not appropriate in
- ;; this context and it does not move to the beginning of the buffer
- ;; when the point is before the first log entry.
-
- ;; `log-view-beginning-of-defun' and `log-view-end-of-defun' have
- ;; been checked to work with logs produced by RCS, CVS, git,
- ;; mercurial and subversion.
-
- (re-search-backward log-view-message-re nil 'move))
+(defun log-view-toggle-entry-display ()
+ (interactive)
+ ;; Don't do anything unless `log-view-expanded-log-entry-function'
+ ;; is defined in this mode.
+ (when (functionp log-view-expanded-log-entry-function)
+ (let* ((opoint (point))
+ (entry (log-view-current-entry nil t))
+ (beg (car entry))
+ (buffer-read-only nil))
+ (when entry
+ (if (get-text-property beg 'log-view-entry-expanded)
+ ;; If the entry is expanded, collapse it.
+ (let ((pos (next-single-property-change beg 'log-view-comment)))
+ (unless (and pos (log-view-inside-comment-p pos))
+ (error "Broken markup in `log-view-toggle-entry-display'"))
+ (delete-region pos
+ (next-single-property-change pos 'log-view-comment))
+ (put-text-property beg (1+ beg) 'log-view-entry-expanded nil)
+ (if (< opoint pos)
+ (goto-char opoint)))
+ ;; Otherwise, expand the entry.
+ (let ((long-entry (funcall log-view-expanded-log-entry-function
+ (nth 1 entry))))
+ (when long-entry
+ (put-text-property beg (1+ beg) 'log-view-entry-expanded t)
+ (log-view-end-of-defun)
+ (setq beg (point))
+ (insert long-entry "\n")
+ (add-text-properties
+ beg (point)
+ '(font-lock-face font-lock-comment-face log-view-comment t))
+ (goto-char opoint))))))))
+
+(defun log-view-beginning-of-defun (&optional arg)
+ "Move backward to the beginning of a Log View entry.
+With ARG, do it that many times. Negative ARG means move forward
+to the beginning of the ARGth following entry.
+
+This is Log View mode's default `beginning-of-defun-function'.
+It assumes that a log entry starts with a line matching
+`log-view-message-re'."
+ (if (or (null arg) (zerop arg))
+ (setq arg 1))
+ (if (< arg 0)
+ (dotimes (n (- arg))
+ (log-view-end-of-defun))
+ (catch 'beginning-of-buffer
+ (dotimes (n arg)
+ (or (log-view-current-entry nil t)
+ (throw 'beginning-of-buffer nil)))
+ (point))))
(defun log-view-end-of-defun ()
- ;; The idea in this function is to search for the beginning of the
- ;; next log entry using `log-view-message-re' and then go back one
- ;; line when finding it. Modes that derive from `log-view-mode' for
- ;; which this assumption is not valid will have to provide another
- ;; implementation of this function.
-
- ;; Look back and if there is no entry there it means we are before
- ;; the first log entry, so go forward until finding one.
- (unless (save-excursion (re-search-backward log-view-message-re nil t))
- (re-search-forward log-view-message-re nil t))
-
- ;; In case we are at the end of log entry going forward a line will
- ;; make us find the next entry when searching. If we are inside of
- ;; an entry going forward a line will still keep the point inside
- ;; the same entry.
- (forward-line 1)
-
- ;; In case we are at the beginning of an entry, move past it.
- (when (looking-at log-view-message-re)
- (goto-char (match-end 0))
- (forward-line 1))
-
- ;; Search for the start of the next log entry. Go to the end of the
- ;; buffer if we could not find a next entry.
- (when (re-search-forward log-view-message-re nil 'move)
- (goto-char (match-beginning 0))
- (forward-line -1)))
+ "Move forward to the next Log View entry."
+ (let ((looping t))
+ (if (looking-at log-view-message-re)
+ (goto-char (match-end 0)))
+ (while looping
+ (cond
+ ((re-search-forward log-view-message-re nil 'move)
+ (unless (log-view-inside-comment-p (point))
+ (setq looping nil)
+ (goto-char (match-beginning 0))))
+ ;; Don't advance past the end buttons inserted by
+ ;; `vc-print-log-setup-buttons'.
+ ((looking-back "Show 2X entries Show unlimited entries")
+ (setq looping nil)
+ (forward-line -1))))))
(defvar cvs-minor-current-files)
(defvar cvs-branch-prefix)
@@ -541,5 +590,4 @@ the changes that affected other files than the currently considered file(s)."
(provide 'log-view)
-;; arch-tag: 0d64220b-ce7e-4f62-9c2a-6b04c2f81f4f
;;; log-view.el ends here
diff --git a/lisp/pcvs-defs.el b/lisp/vc/pcvs-defs.el
index 955e61f59c3..67f86dd364c 100644
--- a/lisp/pcvs-defs.el
+++ b/lisp/vc/pcvs-defs.el
@@ -1,11 +1,10 @@
;;; pcvs-defs.el --- variable definitions for PCL-CVS
-;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1991-2011 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: pcl-cvs
+;; Package: pcvs
;; This file is part of GNU Emacs.
@@ -524,5 +523,4 @@ message and replace it with a message telling you to change this variable.")
;;
(provide 'pcvs-defs)
-;; arch-tag: c7c701d0-d1d4-4aa9-a302-007bb03aca5e
;;; pcvs-defs.el ends here
diff --git a/lisp/pcvs-info.el b/lisp/vc/pcvs-info.el
index 5338d0a7148..3fd6cd40299 100644
--- a/lisp/pcvs-info.el
+++ b/lisp/vc/pcvs-info.el
@@ -1,11 +1,10 @@
;;; pcvs-info.el --- internal representation of a fileinfo entry
-;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1991-2011 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: pcl-cvs
+;; Package: pcvs
;; This file is part of GNU Emacs.
@@ -485,5 +484,4 @@ DIR can also be a file."
(provide 'pcvs-info)
-;; arch-tag: d85dde07-bdc2-400a-882f-92f398c7b0ba
;;; pcvs-info.el ends here
diff --git a/lisp/pcvs-parse.el b/lisp/vc/pcvs-parse.el
index b2de8621f7c..c514026b1f1 100644
--- a/lisp/pcvs-parse.el
+++ b/lisp/vc/pcvs-parse.el
@@ -1,10 +1,10 @@
;;; pcvs-parse.el --- the CVS output parser
-;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1991-2011 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: pcl-cvs
+;; Package: pcvs
;; This file is part of GNU Emacs.
@@ -534,5 +534,4 @@ The remaining KEYS are passed directly to `cvs-create-fileinfo'."
(provide 'pcvs-parse)
-;; arch-tag: 35418375-1a23-40a0-957d-96b0262f91d6
;;; pcvs-parse.el ends here
diff --git a/lisp/pcvs-util.el b/lisp/vc/pcvs-util.el
index 22d53aeb97b..752016a0392 100644
--- a/lisp/pcvs-util.el
+++ b/lisp/vc/pcvs-util.el
@@ -1,10 +1,10 @@
;;; pcvs-util.el --- utility functions for PCL-CVS -*- byte-compile-dynamic: t -*-
-;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1991-2011 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: pcl-cvs
+;; Package: pcvs
;; This file is part of GNU Emacs.
@@ -367,5 +367,4 @@ And reset it unless READ-ONLY is non-nil."
(provide 'pcvs-util)
-;; arch-tag: 3b2588bb-2ae3-4f1f-bf5b-dea91b1f8a59
;;; pcvs-util.el ends here
diff --git a/lisp/pcvs.el b/lisp/vc/pcvs.el
index bab93854a2f..5595dc0b03f 100644
--- a/lisp/pcvs.el
+++ b/lisp/vc/pcvs.el
@@ -1,7 +1,6 @@
;;; pcvs.el --- a front-end to CVS
-;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1991-2011 Free Software Foundation, Inc.
;; Author: (The PCL-CVS Trust) pcl-cvs@cyclic.com
;; (Per Cederqvist) ceder@lysator.liu.se
@@ -13,7 +12,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.
@@ -2439,5 +2438,4 @@ The exact behavior is determined also by `cvs-dired-use-hook'."
(provide 'pcvs)
-;; arch-tag: 8e3a7494-0453-4389-9ab3-a557ce9fab61
;;; pcvs.el ends here
diff --git a/lisp/smerge-mode.el b/lisp/vc/smerge-mode.el
index 635217fa3af..f26ccdbedda 100644
--- a/lisp/smerge-mode.el
+++ b/lisp/vc/smerge-mode.el
@@ -1,10 +1,9 @@
-;;; smerge-mode.el --- Minor mode to resolve diff3 conflicts
+;;; smerge-mode.el --- Minor mode to resolve diff3 conflicts -*- lexical-binding: t -*-
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2011 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.
@@ -46,7 +45,7 @@
(eval-when-compile (require 'cl))
(require 'diff-mode) ;For diff-auto-refine-mode.
-
+(require 'newcomment)
;;; The real definition comes later.
(defvar smerge-mode)
@@ -455,10 +454,41 @@ BUF contains a plain diff between match-1 and match-3."
(insert ">>>>>>> " name3 "\n")
(setq line endline))))))))
+(defconst smerge-resolve--normalize-re "[\n\t][ \t\n]*\\| [ \t\n]+")
+
+(defun smerge-resolve--extract-comment (beg end)
+ "Extract the text within the comments that span BEG..END."
+ (save-excursion
+ (let ((comments ())
+ combeg)
+ (goto-char beg)
+ (while (and (< (point) end)
+ (setq combeg (comment-search-forward end t)))
+ (let ((beg (point)))
+ (goto-char combeg)
+ (comment-forward 1)
+ (save-excursion
+ (comment-enter-backward)
+ (push " " comments)
+ (push (buffer-substring-no-properties beg (point)) comments))))
+ (push " " comments)
+ (with-temp-buffer
+ (apply #'insert (nreverse comments))
+ (goto-char (point-min))
+ (while (re-search-forward smerge-resolve--normalize-re
+ nil t)
+ (replace-match " "))
+ (buffer-string)))))
+
+(defun smerge-resolve--normalize (beg end)
+ (replace-regexp-in-string
+ smerge-resolve--normalize-re " "
+ (concat " " (buffer-substring-no-properties beg end) " ")))
+
(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))
@@ -472,7 +502,8 @@ some major modes. Uses `smerge-resolve-function' to do the actual work."
(m2e (match-end 2))
(m3e (match-end 3))
(buf (generate-new-buffer " *smerge*"))
- m b o)
+ m b o
+ choice)
(unwind-protect
(progn
(cond
@@ -557,6 +588,43 @@ some major modes. Uses `smerge-resolve-function' to do the actual work."
(narrow-to-region m0b m0e)
(smerge-remove-props m0b m0e)
(insert-file-contents m nil nil nil t)))
+ ;; If the conflict is only made of comments, and one of the two
+ ;; changes is only rearranging spaces (e.g. reflowing text) while
+ ;; the other is a real change, drop the space-rearrangement.
+ ((and m2e
+ (comment-only-p m1b m1e)
+ (comment-only-p m2b m2e)
+ (comment-only-p m3b m3e)
+ (let ((t1 (smerge-resolve--extract-comment m1b m1e))
+ (t2 (smerge-resolve--extract-comment m2b m2e))
+ (t3 (smerge-resolve--extract-comment m3b m3e)))
+ (cond
+ ((and (equal t1 t2) (not (equal t2 t3)))
+ (setq choice 3))
+ ((and (not (equal t1 t2)) (equal t2 t3))
+ (setq choice 1)))))
+ (set-match-data md)
+ (smerge-keep-n choice))
+ ;; Idem, when the conflict is contained within a single comment.
+ ((save-excursion
+ (and m2e
+ (nth 4 (syntax-ppss m0b))
+ ;; If there's a conflict earlier in the file,
+ ;; syntax-ppss is not reliable.
+ (not (re-search-backward smerge-begin-re nil t))
+ (progn (goto-char (nth 8 (syntax-ppss m0b)))
+ (forward-comment 1)
+ (> (point) m0e))
+ (let ((t1 (smerge-resolve--normalize m1b m1e))
+ (t2 (smerge-resolve--normalize m2b m2e))
+ (t3 (smerge-resolve--normalize m3b m3e)))
+ (cond
+ ((and (equal t1 t2) (not (equal t2 t3)))
+ (setq choice 3))
+ ((and (not (equal t1 t2)) (equal t2 t3))
+ (setq choice 1))))))
+ (set-match-data md)
+ (smerge-keep-n choice))
(t
(error "Don't know how to resolve"))))
(if (buffer-name buf) (kill-buffer buf))
@@ -815,12 +883,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 +987,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 +1056,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 +1077,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 +1233,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 +1256,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 "\\|"
@@ -1227,5 +1299,4 @@ If no conflict maker is found, turn off `smerge-mode'."
(provide 'smerge-mode)
-;; arch-tag: 605c8d1e-e43d-4943-a6f3-1bcc4333e690
;;; smerge-mode.el ends here
diff --git a/lisp/vc-annotate.el b/lisp/vc/vc-annotate.el
index 35c105027b3..abd3806d02f 100644
--- a/lisp/vc-annotate.el
+++ b/lisp/vc/vc-annotate.el
@@ -1,11 +1,11 @@
;;; vc-annotate.el --- VC Annotate Support
-;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-1998, 2000-2011 Free Software Foundation, Inc.
;; Author: Martin Lorentzson <emwson@emw.ericsson.se>
;; Maintainer: FSF
-;; Keywords: tools
+;; Keywords: vc tools
+;; Package: vc
;; This file is part of GNU Emacs.
@@ -128,6 +128,8 @@ List of factors, used to expand/compress the time scale. See `vc-annotate'."
(define-key m "p" 'vc-annotate-prev-revision)
(define-key m "w" 'vc-annotate-working-revision)
(define-key m "v" 'vc-annotate-toggle-annotation-visibility)
+ (define-key m "v" 'vc-annotate-toggle-annotation-visibility)
+ (define-key m "\C-m" 'vc-annotate-goto-line)
m)
"Local keymap used for VC-Annotate mode.")
@@ -162,7 +164,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."
@@ -672,7 +675,36 @@ The annotations are relative to the current time, unless overridden by OFFSET."
;; Pretend to font-lock there were no matches.
nil)
+(defun vc-annotate-goto-line ()
+ "Go to the line corresponding to the current VC Annotate line."
+ (interactive)
+ (unless (eq major-mode 'vc-annotate-mode)
+ (error "Not in a VC-Annotate buffer"))
+ (let ((line (save-restriction
+ (widen)
+ (line-number-at-pos)))
+ (rev vc-annotate-parent-rev))
+ (pop-to-buffer
+ (or (and (buffer-live-p vc-parent-buffer)
+ vc-parent-buffer)
+ (and (file-exists-p vc-annotate-parent-file)
+ (find-file-noselect vc-annotate-parent-file))
+ (error "File not found: %s" vc-annotate-parent-file)))
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (forward-line (1- line))
+ (recenter))
+ ;; Issue a warning if the lines might be incorrect.
+ (cond
+ ((buffer-modified-p)
+ (message "Buffer modified; annotated line numbers may be incorrect"))
+ ((not (eq (vc-state buffer-file-name) 'up-to-date))
+ (message "File is not up-to-date; annotated line numbers may be incorrect"))
+ ((not (equal rev (vc-working-revision buffer-file-name)))
+ (message "Annotations were for revision %s; line numbers may be incorrect"
+ rev)))))
+
(provide 'vc-annotate)
-;; arch-tag: c3454a89-80e5-4ffd-8993-671b59612898
;;; vc-annotate.el ends here
diff --git a/lisp/vc-arch.el b/lisp/vc/vc-arch.el
index 57bc487cafa..59cefe047b6 100644
--- a/lisp/vc-arch.el
+++ b/lisp/vc/vc-arch.el
@@ -1,10 +1,10 @@
;;; vc-arch.el --- VC backend for the Arch version-control system
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: FSF (see vc.el for full credits)
;; Maintainer: Stefan Monnier <monnier@gnu.org>
+;; Package: vc
;; This file is part of GNU Emacs.
@@ -637,5 +637,4 @@ CALLBACK expects (ENTRIES &optional MORE-TO-COME); see
(provide 'vc-arch)
-;; arch-tag: a35c7c1c-5237-429d-88ef-3d718fd2e704
;;; vc-arch.el ends here
diff --git a/lisp/vc-bzr.el b/lisp/vc/vc-bzr.el
index 41c9663fc77..21cb86a9840 100644
--- a/lisp/vc-bzr.el
+++ b/lisp/vc/vc-bzr.el
@@ -1,13 +1,13 @@
;;; vc-bzr.el --- VC backend for the bzr revision control system
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
;; Author: Dave Love <fx@gnu.org>
;; Riccardo Murri <riccardo.murri@gmail.com>
-;; Keywords: tools
+;; Maintainer: FSF
+;; Keywords: vc tools
;; Created: Sept 2006
-;; Version: 2008-01-04 (Bzr revno 25)
-;; URL: http://launchpad.net/vc-bzr
+;; Package: vc
;; This file is part of GNU Emacs.
@@ -26,11 +26,9 @@
;;; Commentary:
-;; See <URL:http://bazaar-vcs.org/> concerning bzr. See
-;; <URL:http://launchpad.net/vc-bzr> for alternate development
-;; branches of `vc-bzr'.
+;; See <URL:http://bazaar.canonical.com/> concerning bzr.
-;; Load this library to register bzr support in VC.
+;; This library provides bzr support in VC.
;; Known bugs
;; ==========
@@ -41,9 +39,6 @@
;; (that is, the target contents) are changed.
;; See https://bugs.launchpad.net/vc-bzr/+bug/116607
-;; For an up-to-date list of bugs, please see:
-;; https://bugs.launchpad.net/vc-bzr/+bugs
-
;;; Properties of the backend
(defun vc-bzr-revision-granularity () 'repository)
@@ -99,10 +94,26 @@ Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and
(apply 'vc-do-command (or buffer "*vc*") okstatus vc-bzr-program
file-or-list bzr-command args)))
+(defun vc-bzr-async-command (bzr-command &rest args)
+ "Wrapper round `vc-do-async-command' using `vc-bzr-program' as COMMAND.
+Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and
+`LC_MESSAGES=C' to the environment.
+Use the current Bzr root directory as the ROOT argument to
+`vc-do-async-command', and specify an output buffer named
+\"*vc-bzr : ROOT*\". Return this buffer."
+ (let* ((process-environment
+ (list* "BZR_PROGRESS_BAR=none" "LC_MESSAGES=C"
+ process-environment))
+ (root (vc-bzr-root default-directory))
+ (buffer (format "*vc-bzr : %s*" (expand-file-name root))))
+ (apply 'vc-do-async-command buffer root
+ vc-bzr-program bzr-command args)
+ buffer))
;;;###autoload
(defconst vc-bzr-admin-dirname ".bzr"
"Name of the directory containing Bzr repository status files.")
+;; Used in the autoloaded vc-bzr-registered; see below.
;;;###autoload
(defconst vc-bzr-admin-checkout-format-file
(concat vc-bzr-admin-dirname "/checkout/format"))
@@ -114,6 +125,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 +141,21 @@ 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 Bazaar branch settings for file FILE, as an alist.
+Each element of the returned alist has the form (NAME . VALUE),
+which are the name and value of a Bazaar setting, as strings.
+
+The settings are read from the file \".bzr/branch/branch.conf\"
+in the repository root directory of FILE."
+ (let (settings)
+ (with-temp-buffer
+ (insert-file-contents
+ (expand-file-name vc-bzr-admin-branchconf (vc-bzr-root file)))
+ (while (re-search-forward "^\\([^#=][^=]*?\\) *= *\\(.*\\)$" nil t)
+ (push (cons (match-string 1) (match-string 2)) settings)))
+ settings))
+
(require 'sha1) ;For sha1-program
(defun vc-bzr-sha1 (file)
@@ -144,7 +172,7 @@ Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and
(defun vc-bzr-state-heuristic (file)
"Like `vc-bzr-state' but hopefully without running Bzr."
- ;; `bzr status' was excrutiatingly slow with large histories and
+ ;; `bzr status' was excruciatingly slow with large histories and
;; pending merges, so try to avoid using it until they fix their
;; performance problems.
;; This function tries first to parse Bzr internal file
@@ -154,10 +182,19 @@ Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and
;; format 3' in the first line.
;; If the `checkout/dirstate' file cannot be parsed, fall back to
;; running `vc-bzr-state'."
+ ;;
+ ;; The format of the dirstate file is explained in bzrlib/dirstate.py
+ ;; in the bzr distribution. Basically:
+ ;; header-line giving the version of the file format in use.
+ ;; a few lines of stuff
+ ;; entries, one per line, with null-separated fields. Each line:
+ ;; entry_key = dirname (may be empty), basename, file-id
+ ;; current = common ( = kind, fingerprint, size, executable )
+ ;; + working ( = packed_stat )
+ ;; parent = common ( as above ) + history ( = rev_id )
+ ;; kinds = (r)elocated, (a)bsent, (d)irectory, (f)ile, (l)ink
(lexical-let ((root (vc-bzr-root file)))
(when root ; Short cut.
- ;; This looks at internal files. May break if they change
- ;; their format.
(lexical-let ((dirstate (expand-file-name vc-bzr-admin-dirstate root)))
(condition-case nil
(with-temp-buffer
@@ -178,13 +215,18 @@ Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and
"\\([^\0]*\\)\0" ;"a/f/d", a=removed?
"\\([^\0]*\\)\0" ;sha1 (empty if conflicted)?
"\\([^\0]*\\)\0" ;size?p
- "[^\0]*\0" ;"y/n", executable?
+ ;; y/n. Whether or not the current copy
+ ;; was executable the last time bzr checked?
+ "[^\0]*\0"
"[^\0]*\0" ;?
- "\\([^\0]*\\)\0" ;"a/f/d" a=added?
+ ;; Parent information. Absent in a new repo.
+ "\\(?:\\([^\0]*\\)\0" ;"a/f/d" a=added?
"\\([^\0]*\\)\0" ;sha1 again?
"\\([^\0]*\\)\0" ;size again?
- "[^\0]*\0" ;"y/n", executable again?
- "[^\0]*\0" ;last revid?
+ ;; y/n. Whether or not the repo thinks
+ ;; the file should be executable?
+ "\\([^\0]*\\)\0"
+ "[^\0]*\0\\)?" ;last revid?
;; There are more fields when merges are pending.
)
nil t)
@@ -194,11 +236,28 @@ Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and
;; conflict markers).
(cond
((eq (char-after (match-beginning 1)) ?a) 'removed)
- ((eq (char-after (match-beginning 4)) ?a) 'added)
+ ;; If there is no parent, this must be a new repo.
+ ;; If file is in dirstate, can only be added (b#8025).
+ ((or (not (match-beginning 4))
+ (eq (char-after (match-beginning 4)) ?a)) 'added)
((or (and (eq (string-to-number (match-string 3))
(nth 7 (file-attributes file)))
- (equal (match-string 5)
- (vc-bzr-sha1 file)))
+ (equal (match-string 5)
+ (vc-bzr-sha1 file))
+ ;; For a file, does the executable state match?
+ ;; (Bug#7544)
+ (or (not
+ (eq (char-after (match-beginning 1)) ?f))
+ (let ((exe
+ (memq
+ ?x
+ (mapcar
+ 'identity
+ (nth 8 (file-attributes file))))))
+ (if (eq (char-after (match-beginning 7))
+ ?y)
+ exe
+ (not exe)))))
(and
;; It looks like for lightweight
;; checkouts \2 is empty and we need to
@@ -227,6 +286,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 +297,90 @@ Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and
(when rootdir
(file-relative-name filename* rootdir))))
+(defvar vc-bzr-error-regex-alist
+ '(("^\\( M[* ]\\|+N \\|-D \\|\\| \\*\\|R[M ] \\) \\(.+\\)" 2 nil nil 1)
+ ("^C \\(.+\\)" 2)
+ ("^Text conflict in \\(.+\\)" 1 nil nil 2)
+ ("^Using saved parent location: \\(.+\\)" 1 nil nil 0))
+ "Value of `compilation-error-regexp-alist' in *vc-bzr* buffers.")
+
+(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 (assoc "bound" branch-conf))
+ (bound (and bound (equal "true" (downcase (cdr bound)))))
+ ;; If we need to do a "bzr pull", check for a parent. If it
+ ;; does not exist, bzr will need a pull location.
+ (has-parent (unless bound
+ (assoc "parent_location" branch-conf)))
+ (command (if bound "update" "pull"))
+ args)
+ ;; If necessary, prompt for the exact command.
+ (when (or prompt (not (or bound has-parent)))
+ (setq args (split-string
+ (read-shell-command
+ "Bzr pull command: "
+ (concat vc-bzr-program " " command)
+ 'vc-bzr-history)
+ " " t))
+ (setq vc-bzr-program (car args)
+ command (cadr args)
+ args (cddr args)))
+ (let ((buf (apply 'vc-bzr-async-command command args)))
+ (with-current-buffer buf
+ (vc-exec-after
+ `(progn
+ (let ((compilation-error-regexp-alist
+ vc-bzr-error-regex-alist))
+ (compilation-mode))
+ (set (make-local-variable 'compilation-error-regexp-alist)
+ vc-bzr-error-regex-alist))))
+ (vc-set-async-update buf))))
+
+(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. Extract the specific location and
+ ;; add it explicitly to the command line.
+ (setting nil)
+ (location
+ (cond
+ ((setq setting (assoc "submit_branch" branch-conf))
+ (cdr setting))
+ ((setq setting (assoc "parent_location" branch-conf))
+ (cdr setting))))
+ (cmd
+ (split-string
+ (read-shell-command
+ "Bzr merge command: "
+ (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)))
+ (let ((buf (apply 'vc-bzr-async-command command args)))
+ (with-current-buffer buf
+ (vc-exec-after
+ `(progn
+ (let ((compilation-error-regexp-alist
+ vc-bzr-error-regex-alist))
+ (compilation-mode))
+ (set (make-local-variable 'compilation-error-regexp-alist)
+ vc-bzr-error-regex-alist))))
+ (vc-set-async-update buf))))
+
(defun vc-bzr-status (file)
"Return FILE status according to Bzr.
Return value is a cons (STATUS . WARNING), where WARNING is a
@@ -289,8 +435,13 @@ If any error occurred in running `bzr status', then return nil."
(defun vc-bzr-state (file)
(lexical-let ((result (vc-bzr-status file)))
(when (consp result)
- (when (cdr result)
- (message "Warnings in `bzr' output: %s" (cdr result)))
+ (let ((warnings (cdr result)))
+ (when warnings
+ ;; bzr 2.3.0 returns info about shelves, which is not really a warning
+ (when (string-match "[1-9]+ shel\\(f\\|ves\\) exists?\\..*?\n" warnings)
+ (setq warnings (replace-match "" nil nil warnings)))
+ (unless (string= warnings "")
+ (message "Warnings in `bzr' output: %s" warnings))))
(cdr (assq (car result)
'((added . added)
(kindchanged . edited)
@@ -422,7 +573,7 @@ If any error occurred in running `bzr status', then return nil."
(error "Don't know how to compute the next revision of %s" rev)))
(defun vc-bzr-register (files &optional rev comment)
- "Register FILE under bzr.
+ "Register FILES under bzr.
Signal an error unless REV is nil.
COMMENT is ignored."
(if rev (error "Can't register explicit revision with bzr"))
@@ -454,7 +605,7 @@ or a superior directory.")
(declare-function log-edit-extract-headers "log-edit" (headers string))
(defun vc-bzr-checkin (files rev comment)
- "Check FILE in to bzr with log message COMMENT.
+ "Check FILES in to bzr with log message COMMENT.
REV non-nil gets an error."
(if rev (error "Can't check in a specific revision with bzr"))
(apply 'vc-bzr-command "commit" nil 0
@@ -484,6 +635,7 @@ REV non-nil gets an error."
(defvar log-view-font-lock-keywords)
(defvar log-view-current-tag-function)
(defvar log-view-per-file-logs)
+(defvar log-view-expanded-log-entry-function)
(define-derived-mode vc-bzr-log-view-mode log-view-mode "Bzr-Log-View"
(remove-hook 'log-view-mode-hook 'vc-bzr-log-view-mode) ;Deactivate the hack.
@@ -494,6 +646,11 @@ REV non-nil gets an error."
(if (eq vc-log-view-type 'short)
"^ *\\([0-9.]+\\): \\(.*?\\)[ \t]+\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}\\)\\( \\[merge\\]\\)?"
"^ *\\(?:revno: \\([0-9.]+\\)\\|merged: .+\\)"))
+ ;; Allow expanding short log entries
+ (when (eq vc-log-view-type 'short)
+ (setq truncate-lines t)
+ (set (make-local-variable 'log-view-expanded-log-entry-function)
+ 'vc-bzr-expanded-log-entry))
(set (make-local-variable 'log-view-font-lock-keywords)
;; log-view-font-lock-keywords is careful to use the buffer-local
;; value of log-view-message-re only since Emacs-23.
@@ -531,6 +688,16 @@ REV non-nil gets an error."
(list vc-bzr-log-switches)
vc-bzr-log-switches)))))
+(defun vc-bzr-expanded-log-entry (revision)
+ (with-temp-buffer
+ (apply 'vc-bzr-command "log" t nil nil
+ (list (format "-r%s" revision)))
+ (goto-char (point-min))
+ (when (looking-at "^-+\n")
+ ;; Indent the expanded log entry.
+ (indent-region (match-end 0) (point-max) 2)
+ (buffer-substring (match-end 0) (point-max)))))
+
(defun vc-bzr-log-incoming (buffer remote-location)
(apply 'vc-bzr-command "missing" buffer 'async nil
(list "--theirs-only" (unless (string= remote-location "") remote-location))))
@@ -560,18 +727,22 @@ REV non-nil gets an error."
(defun vc-bzr-diff (files &optional rev1 rev2 buffer)
"VC bzr backend for diff."
- ;; `bzr diff' exits with code 1 if diff is non-empty.
- (apply #'vc-bzr-command "diff" (or buffer "*vc-diff*")
- (if vc-disable-async-diff 1 'async) files
- "--diff-options" (mapconcat 'identity
- (vc-switches 'bzr 'diff)
- " ")
- ;; This `when' is just an optimization because bzr-1.2 is *much*
- ;; faster when the revision argument is not given.
- (when (or rev1 rev2)
- (list "-r" (format "%s..%s"
- (or rev1 "revno:-1")
- (or rev2 ""))))))
+ (let* ((switches (vc-switches 'bzr 'diff))
+ (args
+ (append
+ ;; Only add --diff-options if there are any diff switches.
+ (unless (zerop (length switches))
+ (list "--diff-options" (mapconcat 'identity switches " ")))
+ ;; This `when' is just an optimization because bzr-1.2 is *much*
+ ;; faster when the revision argument is not given.
+ (when (or rev1 rev2)
+ (list "-r" (format "%s..%s"
+ (or rev1 "revno:-1")
+ (or rev2 "")))))))
+ ;; `bzr diff' exits with code 1 if diff is non-empty.
+ (apply #'vc-bzr-command "diff" (or buffer "*vc-diff*")
+ (if vc-disable-async-diff 1 'async) files
+ args)))
;; FIXME: vc-{next,previous}-revision need fixing in vc.el to deal with
@@ -605,6 +776,10 @@ property containing author and date information."
(when (process-buffer proc)
(with-current-buffer (process-buffer proc)
(setq string (concat (process-get proc :vc-left-over) string))
+ ;; Eg: 102020 Gnus developers 20101020 | regexp."
+ ;; As of bzr 2.2.2, no email address in whoami (which can
+ ;; lead to spaces in the author field) is allowed but discouraged.
+ ;; See bug#7792.
(while (string-match "^\\( *[0-9.]+ *\\) \\(.+?\\) +\\([0-9]\\{8\\}\\)\\( |.*\n\\)" string)
(let* ((rev (match-string 1 string))
(author (match-string 2 string))
@@ -643,11 +818,11 @@ property containing author and date information."
(string-to-number (substring str 0 4))))))))
(defun vc-bzr-annotate-extract-revision-at-line ()
- "Return revision for current line of annoation buffer, or nil.
+ "Return revision for current line of annotation buffer, or nil.
Return nil if current line isn't annotated."
(save-excursion
(beginning-of-line)
- (if (looking-at "^ *\\([0-9.]+\\) +[^\n ]* +|")
+ (if (looking-at "^ *\\([0-9.]+\\) +.* +|")
(match-string-no-properties 1))))
(defun vc-bzr-command-discarding-stderr (command &rest args)
@@ -709,38 +884,40 @@ stream. Standard error output is discarded."
(result nil))
(goto-char (point-min))
(while (not (eobp))
- (setq status-str
- (buffer-substring-no-properties (point) (+ (point) 3)))
- (setq translated (cdr (assoc status-str translation)))
- (cond
- ((eq translated 'conflict)
- ;; For conflicts the file appears twice in the listing: once
- ;; with the M flag and once with the C flag, so take care
- ;; not to add it twice to `result'. Ugly.
- (let* ((file
- (buffer-substring-no-properties
- ;;For files with conflicts the format is:
- ;;C Text conflict in FILENAME
- ;; Bah.
- (+ (point) 21) (line-end-position)))
- (entry (assoc file result)))
- (when entry
- (setf (nth 1 entry) 'conflict))))
- ((eq translated 'renamed)
- (re-search-forward "R[ M] \\(.*\\) => \\(.*\\)$" (line-end-position) t)
- (let ((new-name (file-relative-name (match-string 2) relative-dir))
- (old-name (file-relative-name (match-string 1) relative-dir)))
- (push (list new-name 'edited
- (vc-bzr-create-extra-fileinfo old-name)) result)))
- ;; do nothing for non existent files
- ((eq translated 'not-found))
- (t
- (push (list (file-relative-name
- (buffer-substring-no-properties
- (+ (point) 4)
- (line-end-position)) relative-dir)
- translated) result)))
- (forward-line))
+ ;; Bzr 2.3.0 added this if there are shelves. (Bug#8170)
+ (unless (looking-at "[1-9]+ shel\\(f\\|ves\\) exists?\\.")
+ (setq status-str
+ (buffer-substring-no-properties (point) (+ (point) 3)))
+ (setq translated (cdr (assoc status-str translation)))
+ (cond
+ ((eq translated 'conflict)
+ ;; For conflicts the file appears twice in the listing: once
+ ;; with the M flag and once with the C flag, so take care
+ ;; not to add it twice to `result'. Ugly.
+ (let* ((file
+ (buffer-substring-no-properties
+ ;;For files with conflicts the format is:
+ ;;C Text conflict in FILENAME
+ ;; Bah.
+ (+ (point) 21) (line-end-position)))
+ (entry (assoc file result)))
+ (when entry
+ (setf (nth 1 entry) 'conflict))))
+ ((eq translated 'renamed)
+ (re-search-forward "R[ M] \\(.*\\) => \\(.*\\)$" (line-end-position) t)
+ (let ((new-name (file-relative-name (match-string 2) relative-dir))
+ (old-name (file-relative-name (match-string 1) relative-dir)))
+ (push (list new-name 'edited
+ (vc-bzr-create-extra-fileinfo old-name)) result)))
+ ;; do nothing for non existent files
+ ((eq translated 'not-found))
+ (t
+ (push (list (file-relative-name
+ (buffer-substring-no-properties
+ (+ (point) 4)
+ (line-end-position)) relative-dir)
+ translated) result))))
+ (forward-line))
(funcall update-function result)))
(defun vc-bzr-dir-status (dir update-function)
@@ -939,7 +1116,7 @@ stream. Standard error output is discarded."
(defun vc-bzr-shelve-delete-at-point ()
(interactive)
(let ((shelve (vc-bzr-shelve-get-at-point (point))))
- (when (y-or-n-p (format "Remove shelf %s ?" shelve))
+ (when (y-or-n-p (format "Remove shelf %s ? " shelve))
(vc-bzr-command "unshelve" nil 0 nil "--delete-only" shelve)
(vc-dir-refresh))))
@@ -1049,9 +1226,6 @@ stream. Standard error output is discarded."
vc-bzr-revision-keywords))
string pred))))))
-(eval-after-load "vc"
- '(add-to-list 'vc-directory-exclusion-list vc-bzr-admin-dirname t))
-
(provide 'vc-bzr)
-;; arch-tag: 8101bad8-4e92-4e7d-85ae-d8e08b4e7c06
+
;;; vc-bzr.el ends here
diff --git a/lisp/vc-cvs.el b/lisp/vc/vc-cvs.el
index 4c9d62a087c..6a76359b5f7 100644
--- a/lisp/vc-cvs.el
+++ b/lisp/vc/vc-cvs.el
@@ -1,10 +1,10 @@
;;; vc-cvs.el --- non-resident support for CVS version-control
-;; Copyright (C) 1995, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 1998-2011 Free Software Foundation, Inc.
;; 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 +91,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)
@@ -1209,5 +1209,4 @@ is non-nil."
(provide 'vc-cvs)
-;; arch-tag: 60e1402a-aa53-4607-927a-cf74f144b432
;;; vc-cvs.el ends here
diff --git a/lisp/vc-dav.el b/lisp/vc/vc-dav.el
index 0b4ec9fb4e8..27db4b57dc9 100644
--- a/lisp/vc-dav.el
+++ b/lisp/vc/vc-dav.el
@@ -1,10 +1,11 @@
;;; vc-dav.el --- vc.el support for WebDAV
-;; Copyright (C) 2001, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2004-2011 Free Software Foundation, Inc.
;; 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
@@ -185,5 +186,4 @@ It should return a status of either 0 (no differences found), or
(provide 'vc-dav)
-;; arch-tag: 0a0fb9fe-8190-4c0a-a179-5c291d3a467e
;;; vc-dav.el ends here
diff --git a/lisp/vc-dir.el b/lisp/vc/vc-dir.el
index 1fee373c007..01b6f2fc26e 100644
--- a/lisp/vc-dir.el
+++ b/lisp/vc/vc-dir.el
@@ -1,10 +1,10 @@
;;; vc-dir.el --- Directory status display under VC
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 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.
@@ -104,7 +104,7 @@ See `run-hooks'."
;; We pass a filename to create-file-buffer because it is what
;; the function expects, and also what uniquify needs (if active)
(with-current-buffer (create-file-buffer (expand-file-name bname dir))
- (cd dir)
+ (setq default-directory dir)
(vc-setup-buffer (current-buffer))
;; Reset the vc-parent-buffer-name so that it does not appear
;; in the mode-line.
@@ -195,7 +195,7 @@ See `run-hooks'."
'(menu-item "Show Incoming Log" vc-log-incoming
:help "Show a log of changes that will be received with a pull operation"))
(define-key map [log]
- '(menu-item "Show history" vc-print-log
+ '(menu-item "Show History" vc-print-log
:help "List the change log of the current file set in a window"))
(define-key map [rlog]
'(menu-item "Show Top of the Tree History " vc-print-root-log
@@ -265,6 +265,7 @@ See `run-hooks'."
(define-key map [C-up] 'vc-dir-previous-directory)
;; The remainder.
(define-key map "f" 'vc-dir-find-file)
+ (define-key map "e" 'vc-dir-find-file) ; dired-mode compatibility
(define-key map "\C-m" 'vc-dir-find-file)
(define-key map "o" 'vc-dir-find-file-other-window)
(define-key map "\C-c\C-c" 'vc-dir-kill-dir-status-process)
@@ -306,29 +307,36 @@ If BODY uses EVENT, it should be a variable,
(defvar vc-dir-tool-bar-map
(let ((map (make-sparse-keymap)))
- (tool-bar-local-item-from-menu 'vc-dir-find-file "open"
- 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")
- (tool-bar-local-item-from-menu 'vc-dir-previous-line "left-arrow"
- map vc-dir-mode-map
- :rtl "right-arrow")
- (tool-bar-local-item-from-menu 'vc-dir-next-line "right-arrow"
- map vc-dir-mode-map
- :rtl "left-arrow")
+ (tool-bar-local-item-from-menu 'find-file "new" map nil
+ :label "New File" :vert-only t)
+ (tool-bar-local-item-from-menu 'menu-find-file-existing "open" map nil
+ :label "Open" :vert-only t)
+ (tool-bar-local-item-from-menu 'dired "diropen" map nil
+ :vert-only t)
+ (tool-bar-local-item-from-menu 'quit-window "close" map vc-dir-mode-map
+ :vert-only t)
+ (tool-bar-local-item-from-menu 'vc-next-action "saveas" map
+ vc-dir-mode-map :label "Commit")
(tool-bar-local-item-from-menu 'vc-print-log "info"
- map vc-dir-mode-map)
- (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)
- (tool-bar-local-item-from-menu 'vc-dir-query-replace-regexp
- "search-replace" map vc-dir-mode-map)
+ map vc-dir-mode-map
+ :label "Log")
+ (define-key-after map [separator-1] menu-bar-separator)
(tool-bar-local-item-from-menu 'vc-dir-kill-dir-status-process "cancel"
- map vc-dir-mode-map)
- (tool-bar-local-item-from-menu 'quit-window "exit"
- map vc-dir-mode-map)
+ map vc-dir-mode-map
+ :label "Stop" :vert-only t)
+ (tool-bar-local-item-from-menu 'revert-buffer "refresh"
+ map vc-dir-mode-map :vert-only t)
+ (define-key-after map [separator-2] menu-bar-separator)
+ (tool-bar-local-item-from-menu (lookup-key menu-bar-edit-menu [cut])
+ "cut" map nil :vert-only t)
+ (tool-bar-local-item-from-menu (lookup-key menu-bar-edit-menu [copy])
+ "copy" map nil :vert-only t)
+ (tool-bar-local-item-from-menu (lookup-key menu-bar-edit-menu [paste])
+ "paste" map nil :vert-only t)
+ (define-key-after map [separator-3] menu-bar-separator)
+ (tool-bar-local-item-from-menu 'isearch-forward
+ "search" map nil
+ :label "Search" :vert-only t)
map))
(defun vc-dir-node-directory (node)
@@ -961,6 +969,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)
@@ -993,7 +1002,7 @@ specific headers."
(generate-new-buffer (format " *VC-%s* tmp status" backend))))
(lexical-let ((buffer (current-buffer)))
(with-current-buffer vc-dir-process-buffer
- (cd def-dir)
+ (setq default-directory def-dir)
(erase-buffer)
(vc-call-backend
backend 'dir-status-files def-dir files default-state
@@ -1053,9 +1062,12 @@ Throw an error if another update process is in progress."
(unless (vc-dir-fileinfo->directory info)
(setf (vc-dir-fileinfo->needs-update info) t) nil))
vc-ewoc)
+ ;; Bzr has serious locking problems, so setup the headers first (this is
+ ;; synchronous) rather than doing it while dir-status is running.
+ (ewoc-set-hf vc-ewoc (vc-dir-headers backend def-dir) "")
(lexical-let ((buffer (current-buffer)))
(with-current-buffer vc-dir-process-buffer
- (cd def-dir)
+ (setq default-directory def-dir)
(erase-buffer)
(vc-call-backend
backend 'dir-status def-dir
@@ -1073,8 +1085,7 @@ Throw an error if another update process is in progress."
(vc-dir-refresh-files
(mapcar 'vc-dir-fileinfo->name remaining)
'up-to-date)
- (setq mode-line-process nil)))))))))
- (ewoc-set-hf vc-ewoc (vc-dir-headers backend def-dir) ""))))
+ (setq mode-line-process nil))))))))))))
(defun vc-dir-show-fileentry (file)
"Insert an entry for a specific file into the current *VC-dir* listing.
@@ -1174,9 +1185,9 @@ These are the commands available for use in the file status buffer:
;; therefore it makes sense to always do that.
;; Otherwise if you do C-x v d -> C-x C-f -> C-c v d
;; you may get a new *vc-dir* buffer, different from the original
- (file-truename (read-file-name "VC status for directory: "
- default-directory default-directory t
- nil #'file-directory-p))
+ (file-truename (read-directory-name "VC status for directory: "
+ default-directory default-directory t
+ nil))
(if current-prefix-arg
(intern
(completing-read
@@ -1250,5 +1261,4 @@ These are the commands available for use in the file status buffer:
(provide 'vc-dir)
-;; arch-tag: 0274a2e3-e8e9-4b1a-a73c-e8b9129d5d15
;;; vc-dir.el ends here
diff --git a/lisp/vc-dispatcher.el b/lisp/vc/vc-dispatcher.el
index 1ed908753c2..388d4c94a08 100644
--- a/lisp/vc-dispatcher.el
+++ b/lisp/vc/vc-dispatcher.el
@@ -1,11 +1,11 @@
;;; vc-dispatcher.el -- generic command-dispatcher facility.
-;; Copyright (C) 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; 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 +317,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.
@@ -363,6 +356,61 @@ case, and the process object in the asynchronous case."
',command ',file-or-list ',flags))
status))))
+(defun vc-do-async-command (buffer root command &rest args)
+ "Run COMMAND asynchronously with ARGS, displaying the result.
+Send the output to BUFFER, which should be a buffer or the name
+of a buffer, which is created.
+ROOT should be the directory in which the command should be run.
+Display the buffer in some window, but don't select it."
+ (let* ((dir default-directory)
+ (inhibit-read-only t)
+ window new-window-start)
+ (setq buffer (get-buffer-create buffer))
+ (if (get-buffer-process buffer)
+ (error "Another VC action on %s is running" root))
+ (with-current-buffer buffer
+ (setq default-directory root)
+ (goto-char (point-max))
+ (unless (eq (point) (point-min))
+ (insert " \n"))
+ (setq new-window-start (point))
+ (insert "Running \"" command)
+ (dolist (arg args)
+ (insert " " arg))
+ (insert "\"...\n")
+ ;; Run in the original working directory.
+ (let ((default-directory dir))
+ (apply 'vc-do-command t 'async command nil args)))
+ (setq window (display-buffer buffer))
+ (if window
+ (set-window-start window new-window-start))
+ buffer))
+
+(defun vc-set-async-update (process-buffer)
+ "Set a `vc-exec-after' action appropriate to the current buffer.
+This action will update the current buffer after the current
+asynchronous VC command has completed. PROCESS-BUFFER is the
+buffer for the asynchronous VC process.
+
+If the current buffer is a VC Dir buffer, call `vc-dir-refresh'.
+If the current buffer is a Dired buffer, revert it."
+ (let* ((buf (current-buffer))
+ (tick (buffer-modified-tick buf)))
+ (cond
+ ((derived-mode-p 'vc-dir-mode)
+ (with-current-buffer process-buffer
+ (vc-exec-after
+ `(if (buffer-live-p ,buf)
+ (with-current-buffer ,buf
+ (vc-dir-refresh))))))
+ ((derived-mode-p 'dired-mode)
+ (with-current-buffer process-buffer
+ (vc-exec-after
+ `(and (buffer-live-p ,buf)
+ (= (buffer-modified-tick ,buf) ,tick)
+ (with-current-buffer ,buf
+ (revert-buffer)))))))))
+
;; These functions are used to ensure that the view the user sees is up to date
;; even if the dispatcher client mode has messed with file contents (as in,
;; for example, VCS keyword expansion).
@@ -698,5 +746,4 @@ the buffer contents as a comment."
(provide 'vc-dispatcher)
-;; arch-tag: 7d08b17f-5470-4799-914b-bfb9fcf6a246
;;; vc-dispatcher.el ends here
diff --git a/lisp/vc-git.el b/lisp/vc/vc-git.el
index b9b63ce5040..711a573ba99 100644
--- a/lisp/vc-git.el
+++ b/lisp/vc/vc-git.el
@@ -1,9 +1,10 @@
;;; vc-git.el --- VC backend for the git version control system
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
;; Author: Alexandre Julliard <julliard@winehq.org>
-;; Keywords: tools
+;; Keywords: vc tools
+;; Package: vc
;; This file is part of GNU Emacs.
@@ -118,9 +119,39 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches."
:version "23.1"
:group 'vc)
+(defcustom vc-git-program "git"
+ "Name of the Git executable (excluding any arguments)."
+ :version "24.1"
+ :type 'string
+ :group 'vc)
+
+(defcustom vc-git-root-log-format
+ '("%d%h..: %an %ad %s"
+ ;; The first shy group matches the characters drawn by --graph.
+ ;; We use numbered groups because `log-view-message-re' wants the
+ ;; revision number to be group 1.
+ "^\\(?:[*/\\| ]+ \\)?\\(?2: ([^)]+)\\)?\\(?1:[0-9a-z]+\\)..: \
+\\(?3:.*?\\)[ \t]+\\(?4:[0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}\\)"
+ ((1 'log-view-message-face)
+ (2 'change-log-list nil lax)
+ (3 'change-log-name)
+ (4 'change-log-date)))
+ "Git log format for `vc-print-root-log'.
+This should be a list (FORMAT REGEXP KEYWORDS), where FORMAT is a
+format string (which is passed to \"git log\" via the argument
+\"--pretty=tformat:FORMAT\"), REGEXP is a regular expression
+matching the resulting Git log output, and KEYWORDS is a list of
+`font-lock-keywords' for highlighting the Log View buffer."
+ :type '(list string string (repeat sexp))
+ :group 'vc
+ :version "24.1")
+
(defvar vc-git-commits-coding-system 'utf-8
"Default coding system for git commits.")
+;; History of Git commands.
+(defvar vc-git-history nil)
+
;;; BACKEND PROPERTIES
(defun vc-git-revision-granularity () 'repository)
@@ -525,6 +556,21 @@ or an empty string if none."
'help-echo stash-help-echo
'face 'font-lock-variable-name-face))))))
+(defun vc-git-branches ()
+ "Return the existing branches, as a list of strings.
+The car of the list is the current branch."
+ (with-temp-buffer
+ (call-process vc-git-program nil t nil "branch")
+ (goto-char (point-min))
+ (let (current-branch branches)
+ (while (not (eobp))
+ (when (looking-at "^\\([ *]\\) \\(.+\\)$")
+ (if (string-equal (match-string 1) "*")
+ (setq current-branch (match-string 2))
+ (push (match-string 2) branches)))
+ (forward-line 1))
+ (cons current-branch (nreverse branches)))))
+
;;; STATE-CHANGING FUNCTIONS
(defun vc-git-create-repo ()
@@ -586,6 +632,47 @@ or an empty string if none."
(vc-git-command nil 0 file "reset" "-q" "--")
(vc-git-command nil nil file "checkout" "-q" "--")))
+(defun vc-git-pull (prompt)
+ "Pull changes into the current Git branch.
+Normally, this runs \"git pull\". If PROMPT is non-nil, prompt
+for the Git command to run."
+ (let* ((root (vc-git-root default-directory))
+ (buffer (format "*vc-git : %s*" (expand-file-name root)))
+ (command "pull")
+ (git-program vc-git-program)
+ args)
+ ;; If necessary, prompt for the exact command.
+ (when prompt
+ (setq args (split-string
+ (read-shell-command "Git pull command: "
+ (format "%s pull" git-program)
+ 'vc-git-history)
+ " " t))
+ (setq git-program (car args)
+ command (cadr args)
+ args (cddr args)))
+ (apply 'vc-do-async-command buffer root git-program command args)
+ (vc-set-async-update buffer)))
+
+(defun vc-git-merge-branch ()
+ "Merge changes into the current Git branch.
+This prompts for a branch to merge from."
+ (let* ((root (vc-git-root default-directory))
+ (buffer (format "*vc-git : %s*" (expand-file-name root)))
+ (branches (cdr (vc-git-branches)))
+ (merge-source
+ (completing-read "Merge from branch: "
+ (if (or (member "FETCH_HEAD" branches)
+ (not (file-readable-p
+ (expand-file-name ".git/FETCH_HEAD"
+ root))))
+ branches
+ (cons "FETCH_HEAD" branches))
+ nil t)))
+ (apply 'vc-do-async-command buffer root vc-git-program "merge"
+ (list merge-source))
+ (vc-set-async-update buffer)))
+
;;; HISTORY FUNCTIONS
(defun vc-git-print-log (files buffer &optional shortlog start-revision limit)
@@ -606,8 +693,10 @@ for the --graph option."
(append
'("log" "--no-color")
(when shortlog
- '("--graph" "--decorate" "--date=short"
- "--pretty=tformat:%d%h %ad %s" "--abbrev-commit"))
+ `("--graph" "--decorate" "--date=short"
+ ,(format "--pretty=tformat:%s"
+ (car vc-git-root-log-format))
+ "--abbrev-commit"))
(when limit (list "-n" (format "%s" limit)))
(when start-revision (list start-revision))
'("--")))))))
@@ -618,7 +707,8 @@ for the --graph option."
buffer 0 nil
"log"
"--no-color" "--graph" "--decorate" "--date=short"
- "--pretty=tformat:%d%h %ad %s" "--abbrev-commit"
+ (format "--pretty=tformat:%s" (car vc-git-root-log-format))
+ "--abbrev-commit"
(concat (if (string= remote-location "")
"@{upstream}"
remote-location)
@@ -631,7 +721,8 @@ for the --graph option."
buffer 0 nil
"log"
"--no-color" "--graph" "--decorate" "--date=short"
- "--pretty=tformat:%d%h %ad %s" "--abbrev-commit"
+ (format "--pretty=tformat:%s" (car vc-git-root-log-format))
+ "--abbrev-commit"
(concat "HEAD.." (if (string= remote-location "")
"@{upstream}"
remote-location))))
@@ -640,6 +731,7 @@ for the --graph option."
(defvar log-view-file-re)
(defvar log-view-font-lock-keywords)
(defvar log-view-per-file-logs)
+(defvar log-view-expanded-log-entry-function)
(define-derived-mode vc-git-log-view-mode log-view-mode "Git-Log-View"
(require 'add-log) ;; We need the faces add-log.
@@ -648,37 +740,37 @@ for the --graph option."
(set (make-local-variable 'log-view-per-file-logs) nil)
(set (make-local-variable 'log-view-message-re)
(if (not (eq vc-log-view-type 'long))
- "^\\(?:[*/\\| ]+ \\)?\\(?: ([^)]+)\\)?\\([0-9a-z]+\\) \\([-a-z0-9]+\\) \\(.*\\)"
+ (cadr vc-git-root-log-format)
"^commit *\\([0-9a-z]+\\)"))
+ ;; Allow expanding short log entries
+ (when (eq vc-log-view-type 'short)
+ (setq truncate-lines t)
+ (set (make-local-variable 'log-view-expanded-log-entry-function)
+ 'vc-git-expanded-log-entry))
(set (make-local-variable 'log-view-font-lock-keywords)
(if (not (eq vc-log-view-type 'long))
- '(
- ;; Same as log-view-message-re, except that we don't
- ;; want the shy group for the tag name.
- ("^\\(?:[*/\\| ]+ \\)?\\( ([^)]+)\\)?\\([0-9a-z]+\\) \\([-a-z0-9]+\\) \\(.*\\)"
- (1 'highlight nil lax)
- (2 'change-log-acknowledgement)
- (3 'change-log-date)))
- (append
- `((,log-view-message-re (1 'change-log-acknowledgement)))
- ;; Handle the case:
- ;; user: foo@bar
- '(("^Author:[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
- (1 'change-log-email))
- ;; Handle the case:
- ;; user: FirstName LastName <foo@bar>
- ("^Author:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
- (1 'change-log-name)
- (2 'change-log-email))
- ("^ +\\(?:\\(?:[Aa]cked\\|[Ss]igned-[Oo]ff\\)-[Bb]y:\\)[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
- (1 'change-log-name))
- ("^ +\\(?:\\(?:[Aa]cked\\|[Ss]igned-[Oo]ff\\)-[Bb]y:\\)[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
- (1 'change-log-name)
- (2 'change-log-email))
- ("^Merge: \\([0-9a-z]+\\) \\([0-9a-z]+\\)"
- (1 'change-log-acknowledgement)
- (2 'change-log-acknowledgement))
- ("^Date: \\(.+\\)" (1 'change-log-date))
+ (list (cons (nth 1 vc-git-root-log-format)
+ (nth 2 vc-git-root-log-format)))
+ (append
+ `((,log-view-message-re (1 'change-log-acknowledgement)))
+ ;; Handle the case:
+ ;; user: foo@bar
+ '(("^Author:[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
+ (1 'change-log-email))
+ ;; Handle the case:
+ ;; user: FirstName LastName <foo@bar>
+ ("^Author:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
+ (1 'change-log-name)
+ (2 'change-log-email))
+ ("^ +\\(?:\\(?:[Aa]cked\\|[Ss]igned-[Oo]ff\\)-[Bb]y:\\)[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
+ (1 'change-log-name))
+ ("^ +\\(?:\\(?:[Aa]cked\\|[Ss]igned-[Oo]ff\\)-[Bb]y:\\)[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
+ (1 'change-log-name)
+ (2 'change-log-email))
+ ("^Merge: \\([0-9a-z]+\\) \\([0-9a-z]+\\)"
+ (1 'change-log-acknowledgement)
+ (2 'change-log-acknowledgement))
+ ("^Date: \\(.+\\)" (1 'change-log-date))
("^summary:[ \t]+\\(.+\\)" (1 'log-view-message)))))))
@@ -698,6 +790,15 @@ or BRANCH^ (where \"^\" can be repeated)."
(t nil))))
(beginning-of-line)))
+(defun vc-git-expanded-log-entry (revision)
+ (with-temp-buffer
+ (apply 'vc-git-command t nil nil (list "log" revision "-1"))
+ (goto-char (point-min))
+ (unless (eobp)
+ ;; Indent the expanded log entry.
+ (indent-region (point-min) (point-max) 2)
+ (buffer-string))))
+
(defun vc-git-diff (files &optional rev1 rev2 buffer)
"Get a difference report using Git between two revisions of FILES."
(let (process-file-side-effects)
@@ -988,8 +1089,10 @@ This command shares argument histories with \\[rgrep] and \\[grep]."
(defun vc-git-command (buffer okstatus file-or-list &rest flags)
"A wrapper around `vc-do-command' for use in vc-git.el.
-The difference to vc-do-command is that this function always invokes `git'."
- (apply 'vc-do-command (or buffer "*vc*") okstatus "git" file-or-list flags))
+The difference to vc-do-command is that this function always invokes
+`vc-git-program'."
+ (apply 'vc-do-command (or buffer "*vc*") okstatus vc-git-program
+ file-or-list flags))
(defun vc-git--empty-db-p ()
"Check if the git db is empty (no commit done yet)."
@@ -1000,7 +1103,7 @@ The difference to vc-do-command is that this function always invokes `git'."
;; We don't need to care the arguments. If there is a file name, it
;; is always a relative one. This works also for remote
;; directories.
- (apply 'process-file "git" nil buffer nil command args))
+ (apply 'process-file vc-git-program nil buffer nil command args))
(defun vc-git--out-ok (command &rest args)
(zerop (apply 'vc-git--call '(t nil) command args)))
@@ -1035,5 +1138,4 @@ Returns nil if not possible."
(provide 'vc-git)
-;; arch-tag: bd10664a-0e5b-48f5-a877-6c17b135be12
;;; vc-git.el ends here
diff --git a/lisp/vc-hg.el b/lisp/vc/vc-hg.el
index 4a38c3dfa3a..0516abbf024 100644
--- a/lisp/vc-hg.el
+++ b/lisp/vc/vc-hg.el
@@ -1,9 +1,10 @@
;;; vc-hg.el --- VC backend for the mercurial version control system
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
;; Author: Ivan Kanis
-;; Keywords: tools
+;; Keywords: vc tools
+;; Package: vc
;; This file is part of GNU Emacs.
@@ -137,9 +138,29 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches."
"Name of the Mercurial executable (excluding any arguments)."
:type 'string
:group 'vc)
+
+(defcustom vc-hg-root-log-format
+ '("{rev}:{tags}: {author|person} {date|shortdate} {desc|firstline}\\n"
+ "^\\([0-9]+\\):\\([^:]*\\): \\(.*?\\)[ \t]+\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}\\)"
+ ((1 'log-view-message-face)
+ (2 'change-log-list)
+ (3 'change-log-name)
+ (4 'change-log-date)))
+ "Mercurial log template for `vc-print-root-log'.
+This should be a list (TEMPLATE REGEXP KEYWORDS), where TEMPLATE
+is the \"--template\" argument string to pass to Mercurial,
+REGEXP is a regular expression matching the resulting Mercurial
+output, and KEYWORDS is a list of `font-lock-keywords' for
+highlighting the Log View buffer."
+ :type '(list string string (repeat sexp))
+ :group 'vc
+ :version "24.1")
+
;;; Properties of the backend
+(defvar vc-hg-history nil)
+
(defun vc-hg-revision-granularity () 'repository)
(defun vc-hg-checkout-model (files) 'implicit)
@@ -263,13 +284,14 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches."
(nconc
(when start-revision (list (format "-r%s:" start-revision)))
(when limit (list "-l" (format "%s" limit)))
- (when shortlog (list "--style" "compact"))
+ (when shortlog (list "--template" (car vc-hg-root-log-format)))
vc-hg-log-switches)))))
(defvar log-view-message-re)
(defvar log-view-file-re)
(defvar log-view-font-lock-keywords)
(defvar log-view-per-file-logs)
+(defvar log-view-expanded-log-entry-function)
(define-derived-mode vc-hg-log-view-mode log-view-mode "Hg-Log-View"
(require 'add-log) ;; we need the add-log faces
@@ -277,33 +299,34 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches."
(set (make-local-variable 'log-view-per-file-logs) nil)
(set (make-local-variable 'log-view-message-re)
(if (eq vc-log-view-type 'short)
- "^\\([0-9]+\\)\\(\\[.*\\]\\)? +\\([0-9a-z]\\{12\\}\\) +\\(\\(?:[0-9]+\\)-\\(?:[0-9]+\\)-\\(?:[0-9]+\\) \\(?:[0-9]+\\):\\(?:[0-9]+\\) \\(?:[-+0-9]+\\)\\) +\\(.*\\)$"
+ (cadr vc-hg-root-log-format)
"^changeset:[ \t]*\\([0-9]+\\):\\(.+\\)"))
+ ;; Allow expanding short log entries
+ (when (eq vc-log-view-type 'short)
+ (setq truncate-lines t)
+ (set (make-local-variable 'log-view-expanded-log-entry-function)
+ 'vc-hg-expanded-log-entry))
(set (make-local-variable 'log-view-font-lock-keywords)
(if (eq vc-log-view-type 'short)
- (append `((,log-view-message-re
- (1 'log-view-message-face)
- (2 'highlight nil lax)
- (3 'log-view-message-face)
- (4 'change-log-date)
- (5 'change-log-name))))
- (append
- log-view-font-lock-keywords
- '(
- ;; Handle the case:
- ;; user: FirstName LastName <foo@bar>
- ("^user:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
- (1 'change-log-name)
- (2 'change-log-email))
- ;; Handle the cases:
- ;; user: foo@bar
- ;; and
- ;; user: foo
- ("^user:[ \t]+\\([A-Za-z0-9_.+-]+\\(?:@[A-Za-z0-9_.-]+\\)?\\)"
- (1 'change-log-email))
- ("^date: \\(.+\\)" (1 'change-log-date))
- ("^tag: +\\([^ ]+\\)$" (1 'highlight))
- ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message)))))))
+ (list (cons (nth 1 vc-hg-root-log-format)
+ (nth 2 vc-hg-root-log-format)))
+ (append
+ log-view-font-lock-keywords
+ '(
+ ;; Handle the case:
+ ;; user: FirstName LastName <foo@bar>
+ ("^user:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
+ (1 'change-log-name)
+ (2 'change-log-email))
+ ;; Handle the cases:
+ ;; user: foo@bar
+ ;; and
+ ;; user: foo
+ ("^user:[ \t]+\\([A-Za-z0-9_.+-]+\\(?:@[A-Za-z0-9_.-]+\\)?\\)"
+ (1 'change-log-email))
+ ("^date: \\(.+\\)" (1 'change-log-date))
+ ("^tag: +\\([^ ]+\\)$" (1 'highlight))
+ ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message)))))))
(defun vc-hg-diff (files &optional oldvers newvers buffer)
"Get a difference report using hg between two revisions of FILES."
@@ -321,6 +344,16 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches."
(list "-r" oldvers "-r" newvers)
(list "-r" oldvers)))))))
+(defun vc-hg-expanded-log-entry (revision)
+ (with-temp-buffer
+ (vc-hg-command t nil nil "log" "-r" revision)
+ (goto-char (point-min))
+ (unless (eobp)
+ ;; Indent the expanded log entry.
+ (indent-region (point-min) (point-max) 2)
+ (goto-char (point-max))
+ (buffer-string))))
+
(defun vc-hg-revision-table (files)
(let ((default-directory (file-name-directory (car files))))
(with-temp-buffer
@@ -496,9 +529,9 @@ REV is the revision to check out into WORKFILE."
(insert (propertize
(format " (%s %s)"
(case (vc-hg-extra-fileinfo->rename-state extra)
- ('copied "copied from")
- ('renamed-from "renamed from")
- ('renamed-to "renamed to"))
+ (copied "copied from")
+ (renamed-from "renamed from")
+ (renamed-to "renamed to"))
(vc-hg-extra-fileinfo->extra-name extra))
'face 'font-lock-comment-face)))))
@@ -606,23 +639,62 @@ REV is the revision to check out into WORKFILE."
(mapcar (lambda (arg) (list "-r" arg)) marked-list)))
(error "No log entries selected for push"))))
-(defun vc-hg-pull ()
- (interactive)
- (let ((marked-list (log-view-get-marked)))
- (if marked-list
- (apply #'vc-hg-command
- nil 0 nil
- "pull"
- (apply 'nconc
- (mapcar (lambda (arg) (list "-r" arg)) marked-list)))
- (error "No log entries selected for pull"))))
+(defun vc-hg-pull (prompt)
+ "Issue a Mercurial pull command.
+If called interactively with a set of marked Log View buffers,
+call \"hg pull -r REVS\" to pull in the specified revisions REVS.
+
+With a prefix argument or if PROMPT is non-nil, prompt for a
+specific Mercurial pull command. The default is \"hg pull -u\",
+which fetches changesets from the default remote repository and
+then attempts to update the working directory."
+ (interactive "P")
+ (let (marked-list)
+ ;; The `vc-hg-pull' command existed before the `pull' VC action
+ ;; was implemented. Keep it for backward compatibility.
+ (if (and (called-interactively-p 'interactive)
+ (setq marked-list (log-view-get-marked)))
+ (apply #'vc-hg-command
+ nil 0 nil
+ "pull"
+ (apply 'nconc
+ (mapcar (lambda (arg) (list "-r" arg))
+ marked-list)))
+ (let* ((root (vc-hg-root default-directory))
+ (buffer (format "*vc-hg : %s*" (expand-file-name root)))
+ (command "pull")
+ (hg-program vc-hg-program)
+ ;; Fixme: before updating the working copy to the latest
+ ;; state, should check if it's visiting an old revision.
+ (args '("-u")))
+ ;; If necessary, prompt for the exact command.
+ (when prompt
+ (setq args (split-string
+ (read-shell-command "Run Hg (like this): "
+ (format "%s pull -u" hg-program)
+ 'vc-hg-history)
+ " " t))
+ (setq hg-program (car args)
+ command (cadr args)
+ args (cddr args)))
+ (apply 'vc-do-async-command buffer root hg-program
+ command args)
+ (vc-set-async-update buffer)))))
+
+(defun vc-hg-merge-branch ()
+ "Merge incoming changes into the current working directory.
+This runs the command \"hg merge\"."
+ (let* ((root (vc-hg-root default-directory))
+ (buffer (format "*vc-hg : %s*" (expand-file-name root))))
+ (apply 'vc-do-async-command buffer root vc-hg-program '("merge"))
+ (vc-set-async-update buffer)))
;;; Internal functions
(defun vc-hg-command (buffer okstatus file-or-list &rest flags)
"A wrapper around `vc-do-command' for use in vc-hg.el.
-The difference to vc-do-command is that this function always invokes `hg',
-and that it passes `vc-hg-global-switches' to it before FLAGS."
+This function differs from vc-do-command in that it invokes
+`vc-hg-program', and passes `vc-hg-global-switches' to it before FLAGS."
(apply 'vc-do-command (or buffer "*vc*") okstatus vc-hg-program file-or-list
(if (stringp vc-hg-global-switches)
(cons vc-hg-global-switches flags)
@@ -634,5 +706,4 @@ and that it passes `vc-hg-global-switches' to it before FLAGS."
(provide 'vc-hg)
-;; arch-tag: bd094dc5-715a-434f-a331-37b9fb7cd954
;;; vc-hg.el ends here
diff --git a/lisp/vc-hooks.el b/lisp/vc/vc-hooks.el
index 401b483ae8c..e7bfd273732 100644
--- a/lisp/vc-hooks.el
+++ b/lisp/vc/vc-hooks.el
@@ -1,11 +1,10 @@
;;; vc-hooks.el --- resident support for version-control
-;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1992-1996, 1998-2011 Free Software Foundation, Inc.
;; 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 +47,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 +80,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 +456,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).
@@ -1058,5 +1050,4 @@ current, and kill the buffer that visits the link."
(provide 'vc-hooks)
-;; arch-tag: 2e5a6fa7-1d30-48e2-8bd0-e3d335f04f32
;;; vc-hooks.el ends here
diff --git a/lisp/vc-mtn.el b/lisp/vc/vc-mtn.el
index 71d9ec1ed4e..0b263e9c669 100644
--- a/lisp/vc-mtn.el
+++ b/lisp/vc/vc-mtn.el
@@ -1,9 +1,10 @@
;;; vc-mtn.el --- VC backend for Monotone
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 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:
@@ -340,5 +341,4 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches."
(provide 'vc-mtn)
-;; arch-tag: 2b89ffbc-cbb8-405a-9080-2eafd4becb70
;;; vc-mtn.el ends here
diff --git a/lisp/vc-rcs.el b/lisp/vc/vc-rcs.el
index e1cb4e21c26..488efaa3522 100644
--- a/lisp/vc-rcs.el
+++ b/lisp/vc/vc-rcs.el
@@ -1,11 +1,10 @@
;;; vc-rcs.el --- support for RCS version-control
-;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
-;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1992-2011 Free Software Foundation, Inc.
;; Author: FSF (see vc.el for full credits)
;; Maintainer: Andre Spiegel <spiegel@gnu.org>
+;; Package: vc
;; This file is part of GNU Emacs.
@@ -26,14 +25,10 @@
;; See vc.el
-;; Some features will not work with old RCS versions. Where
+;; Some features will not work with ancient RCS versions. Where
;; appropriate, VC finds out which version you have, and allows or
-;; disallows those features (stealing locks, for example, works only
-;; from 5.6.2 onwards).
-;; Even initial checkins will fail if your RCS version is so old that ci
-;; doesn't understand -t-; this has been known to happen to people running
-;; NExTSTEP 3.0.
-;;
+;; disallows those features.
+
;; You can support the RCS -x option by customizing vc-rcs-master-templates.
;;; Code:
@@ -76,10 +71,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
@@ -392,7 +387,7 @@ whether to remove it."
(vc-rcs-set-default-branch file
(if (vc-rcs-trunk-p new-version) nil
(vc-branch-part new-version)))
- ;; If this is an old RCS release, we might have
+ ;; If this is an old (pre-1992!) RCS release, we might have
;; to remove a remaining lock.
(if (not (vc-rcs-release-p "5.6.2"))
;; exit status of 1 is also accepted.
@@ -1466,5 +1461,4 @@ The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension."
(provide 'vc-rcs)
-;; arch-tag: 759b4916-5b0d-431d-b647-b185b8c652cf
;;; vc-rcs.el ends here
diff --git a/lisp/vc-sccs.el b/lisp/vc/vc-sccs.el
index 4e89e726634..0ee75e1c24a 100644
--- a/lisp/vc-sccs.el
+++ b/lisp/vc/vc-sccs.el
@@ -1,11 +1,10 @@
;;; vc-sccs.el --- support for SCCS version-control
-;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
-;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1992-2011 Free Software Foundation, Inc.
;; 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 +69,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
@@ -481,5 +481,4 @@ If NAME is nil or a revision number string it's just passed through."
(provide 'vc-sccs)
-;; arch-tag: d751dee3-d7b3-47e1-95e3-7ae98c052041
;;; vc-sccs.el ends here
diff --git a/lisp/vc-svn.el b/lisp/vc/vc-svn.el
index 832127a6a16..7362258a42d 100644
--- a/lisp/vc-svn.el
+++ b/lisp/vc/vc-svn.el
@@ -1,10 +1,10 @@
;;; vc-svn.el --- non-resident support for Subversion version-control
-;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2003-2011 Free Software Foundation, Inc.
;; Author: FSF (see vc.el for full credits)
;; Maintainer: Stefan Monnier <monnier@gnu.org>
+;; Package: vc
;; This file is part of GNU Emacs.
@@ -71,9 +71,9 @@ If t, use no switches."
t ;`svn' doesn't support common args like -c or -b.
"String or list of strings specifying extra switches for svn diff under VC.
If nil, use the value of `vc-diff-switches' (or `diff-switches'),
-together with \"-x --diff-cmd=diff\" (since svn diff does not
-support the default \"-c\" value of `diff-switches'). If you
-want to force an empty list of arguments, use t."
+together with \"-x --diff-cmd=\"`diff-command' (since 'svn diff'
+does not support the default \"-c\" value of `diff-switches').
+If you want to force an empty list of arguments, use t."
:type '(choice (const :tag "Unspecified" nil)
(const :tag "None" t)
(string :tag "Argument String")
@@ -83,9 +83,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)
@@ -117,17 +117,13 @@ want to force an empty list of arguments, use t."
;;;###autoload (getenv "SVN_ASP_DOT_NET_HACK"))
;;;###autoload "_svn")
;;;###autoload (t ".svn"))))
-;;;###autoload (when (file-readable-p (expand-file-name
-;;;###autoload (concat admin-dir "/entries")
-;;;###autoload (file-name-directory f)))
+;;;###autoload (when (vc-find-root f admin-dir)
;;;###autoload (load "vc-svn")
;;;###autoload (vc-svn-registered f))))
(defun vc-svn-registered (file)
"Check if FILE is SVN registered."
- (when (file-readable-p (expand-file-name (concat vc-svn-admin-directory
- "/entries")
- (file-name-directory file)))
+ (when (vc-svn-root file)
(with-temp-buffer
(cd (file-name-directory file))
(let* (process-file-side-effects
@@ -170,15 +166,21 @@ want to force an empty list of arguments, use t."
(?? . unregistered)
;; This is what vc-svn-parse-status does.
(?~ . edited)))
- (re (if remote "^\\(.\\)......? \\([ *]\\) +\\(?:[-0-9]+\\)? \\(.*\\)$"
- ;; Subexp 2 is a dummy in this case, so the numbers match.
- "^\\(.\\)....\\(.\\) \\(.*\\)$"))
+ (re (if remote "^\\(.\\)\\(.\\).....? \\([ *]\\) +\\(?:[-0-9]+\\)? \\(.*\\)$"
+ ;; Subexp 3 is a dummy in this case, so the numbers match.
+ "^\\(.\\)\\(.\\)...\\(.\\) \\(.*\\)$"))
result)
(goto-char (point-min))
(while (re-search-forward re nil t)
(let ((state (cdr (assq (aref (match-string 1) 0) state-map)))
- (filename (match-string 3)))
- (and remote (string-equal (match-string 2) "*")
+ (propstat (cdr (assq (aref (match-string 2) 0) state-map)))
+ (filename (if (memq system-type '(windows-nt ms-dos))
+ (replace-regexp-in-string "\\\\" "/" (match-string 4))
+ (match-string 4))))
+ (and (memq propstat '(conflict edited))
+ (not (eq state 'conflict)) ; conflict always wins
+ (setq state propstat))
+ (and remote (string-equal (match-string 3) "*")
;; FIXME are there other possible combinations?
(cond ((eq state 'edited) (setq state 'needs-merge))
((not state) (setq state 'needs-update))))
@@ -271,18 +273,16 @@ Passes either `vc-svn-register-switches' or `vc-register-switches'
to the SVN command."
(apply 'vc-svn-command nil 0 files "add" (vc-switches 'SVN 'register)))
-(defun vc-svn-responsible-p (file)
- "Return non-nil if SVN thinks it is responsible for FILE."
- (file-directory-p (expand-file-name vc-svn-admin-directory
- (if (file-directory-p file)
- file
- (file-name-directory file)))))
+(defun vc-svn-root (file)
+ (vc-find-root file vc-svn-admin-directory))
+
+(defalias 'vc-svn-responsible-p 'vc-svn-root)
-(defalias 'vc-svn-could-register 'vc-svn-responsible-p
+(defalias 'vc-svn-could-register 'vc-svn-root
"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
@@ -518,7 +518,7 @@ or svn+ssh://."
(let* ((switches
(if vc-svn-diff-switches
(vc-switches 'SVN 'diff)
- (list "--diff-cmd=diff" "-x"
+ (list (concat "--diff-cmd=" diff-command) "-x"
(mapconcat 'identity (vc-switches nil 'diff) " "))))
(async (and (not vc-disable-async-diff)
(vc-stay-local-p files 'SVN)
@@ -590,20 +590,10 @@ and that it passes `vc-svn-global-switches' to it before FLAGS."
(defun vc-svn-repository-hostname (dirname)
(with-temp-buffer
- (let ((coding-system-for-read
- (or file-name-coding-system
- default-file-name-coding-system)))
- (vc-insert-file (expand-file-name (concat vc-svn-admin-directory
- "/entries")
- dirname)))
+ (let (process-file-side-effects)
+ (vc-svn-command t t dirname "info" "--xml"))
(goto-char (point-min))
- (when (re-search-forward
- ;; Old `svn' used name="svn:this_dir", newer use just name="".
- (concat "name=\"\\(?:svn:this_dir\\)?\"[\n\t ]*"
- "\\(?:[-a-z]+=\"[^\"]*\"[\n\t ]*\\)*?"
- "url=\"\\(?1:[^\"]+\\)\""
- ;; Yet newer ones don't use XML any more.
- "\\|^\ndir\n[0-9]+\n\\(?1:.*\\)") nil t)
+ (when (re-search-forward "<url>\\(.*\\)</url>" nil t)
;; This is not a hostname but a URL. This may actually be considered
;; as a feature since it allows vc-svn-stay-local to specify different
;; behavior for different modules on the same server.
@@ -642,7 +632,7 @@ and that it passes `vc-svn-global-switches' to it before FLAGS."
"Parse output of \"svn status\" command in the current buffer.
Set file properties accordingly. Unless FILENAME is non-nil, parse only
information about FILENAME and return its status."
- (let (file status)
+ (let (file status propstat)
(goto-char (point-min))
(while (re-search-forward
;; Ignore the files with status X.
@@ -652,7 +642,9 @@ information about FILENAME and return its status."
(setq file (or filename
(expand-file-name
(buffer-substring (point) (line-end-position)))))
- (setq status (char-after (line-beginning-position)))
+ (setq status (char-after (line-beginning-position))
+ ;; Status of the item's properties ([ MC]).
+ propstat (char-after (1+ (line-beginning-position))))
(if (eq status ??)
(vc-file-setprop file 'vc-state 'unregistered)
;; Use the last-modified revision, so that searching in vc-print-log
@@ -663,7 +655,7 @@ information about FILENAME and return its status."
(vc-file-setprop
file 'vc-state
(cond
- ((eq status ?\ )
+ ((and (eq status ?\ ) (eq propstat ?\ ))
(if (eq (char-after (match-beginning 1)) ?*)
'needs-update
(vc-file-setprop file 'vc-checkout-time
@@ -674,9 +666,11 @@ information about FILENAME and return its status."
(vc-file-setprop file 'vc-working-revision "0")
(vc-file-setprop file 'vc-checkout-time 0)
'added)
- ((eq status ?C)
+ ;; Conflict in contents or properties.
+ ((or (eq status ?C) (eq propstat ?C))
(vc-file-setprop file 'vc-state 'conflict))
- ((eq status '?M)
+ ;; Modified contents or properties.
+ ((or (eq status ?M) (eq propstat ?M))
(if (eq (char-after (match-beginning 1)) ?*)
'needs-merge
'edited))
@@ -743,5 +737,4 @@ information about FILENAME and return its status."
(provide 'vc-svn)
-;; arch-tag: 02f10c68-2b4d-453a-90fc-1eee6cfb268d
;;; vc-svn.el ends here
diff --git a/lisp/vc.el b/lisp/vc/vc.el
index c0aff4c8a9b..3809b5b4293 100644
--- a/lisp/vc.el
+++ b/lisp/vc/vc.el
@@ -1,12 +1,10 @@
;;; vc.el --- drive a version-control system from within Emacs
-;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 2000,
-;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1992-1998, 2000-2011 Free Software Foundation, Inc.
;; 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 +98,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 +107,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 +311,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 +346,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 +451,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 +472,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)
@@ -642,6 +653,7 @@
(require 'vc-hooks)
(require 'vc-dispatcher)
+(require 'ediff)
(eval-when-compile
(require 'cl)
@@ -920,7 +932,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 +999,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."
@@ -1103,9 +1116,12 @@ merge in the changes into your working copy."
(dolist (file files)
(unless (file-writable-p file)
;; Make the file+buffer read-write.
- (unless (y-or-n-p (format "%s is edited but read-only; make it writable and continue?" file))
+ (unless (y-or-n-p (format "%s is edited but read-only; make it writable and continue? " file))
(error "Aborted"))
- (set-file-modes file (logior (file-modes file) 128))
+ ;; Maybe we somehow lost permissions on the directory.
+ (condition-case nil
+ (set-file-modes file (logior (file-modes file) 128))
+ (error (error "Unable to make file writable")))
(let ((visited (get-file-buffer file)))
(when visited
(with-current-buffer visited
@@ -1602,45 +1618,48 @@ returns t if the buffer had changes, nil otherwise."
nil nil initial-input nil default)
(read-string prompt initial-input nil default))))
+(defun vc-diff-build-argument-list-internal ()
+ "Build argument list for calling internal diff functions."
+ (let* ((vc-fileset (vc-deduce-fileset t)) ;FIXME: why t? --Stef
+ (files (cadr vc-fileset))
+ (backend (car vc-fileset))
+ (first (car files))
+ (rev1-default nil)
+ (rev2-default nil))
+ (cond
+ ;; someday we may be able to do revision completion on non-singleton
+ ;; filesets, but not yet.
+ ((/= (length files) 1)
+ nil)
+ ;; if it's a directory, don't supply any revision default
+ ((file-directory-p first)
+ nil)
+ ;; if the file is not up-to-date, use working revision as older revision
+ ((not (vc-up-to-date-p first))
+ (setq rev1-default (vc-working-revision first)))
+ ;; if the file is not locked, use last and previous revisions as defaults
+ (t
+ (setq rev1-default (vc-call-backend backend 'previous-revision first
+ (vc-working-revision first)))
+ (when (string= rev1-default "") (setq rev1-default nil))
+ (setq rev2-default (vc-working-revision first))))
+ ;; construct argument list
+ (let* ((rev1-prompt (if rev1-default
+ (concat "Older revision (default "
+ rev1-default "): ")
+ "Older revision: "))
+ (rev2-prompt (concat "Newer revision (default "
+ (or rev2-default "current source") "): "))
+ (rev1 (vc-read-revision rev1-prompt files backend rev1-default))
+ (rev2 (vc-read-revision rev2-prompt files backend rev2-default)))
+ (when (string= rev1 "") (setq rev1 nil))
+ (when (string= rev2 "") (setq rev2 nil))
+ (list files rev1 rev2))))
+
;;;###autoload
(defun vc-version-diff (files rev1 rev2)
"Report diffs between revisions of the fileset in the repository history."
- (interactive
- (let* ((vc-fileset (vc-deduce-fileset t)) ;FIXME: why t? --Stef
- (files (cadr vc-fileset))
- (backend (car vc-fileset))
- (first (car files))
- (rev1-default nil)
- (rev2-default nil))
- (cond
- ;; someday we may be able to do revision completion on non-singleton
- ;; filesets, but not yet.
- ((/= (length files) 1)
- nil)
- ;; if it's a directory, don't supply any revision default
- ((file-directory-p first)
- nil)
- ;; if the file is not up-to-date, use working revision as older revision
- ((not (vc-up-to-date-p first))
- (setq rev1-default (vc-working-revision first)))
- ;; if the file is not locked, use last and previous revisions as defaults
- (t
- (setq rev1-default (vc-call-backend backend 'previous-revision first
- (vc-working-revision first)))
- (when (string= rev1-default "") (setq rev1-default nil))
- (setq rev2-default (vc-working-revision first))))
- ;; construct argument list
- (let* ((rev1-prompt (if rev1-default
- (concat "Older revision (default "
- rev1-default "): ")
- "Older revision: "))
- (rev2-prompt (concat "Newer revision (default "
- (or rev2-default "current source") "): "))
- (rev1 (vc-read-revision rev1-prompt files backend rev1-default))
- (rev2 (vc-read-revision rev2-prompt files backend rev2-default)))
- (when (string= rev1 "") (setq rev1 nil))
- (when (string= rev2 "") (setq rev2 nil))
- (list files rev1 rev2))))
+ (interactive (vc-diff-build-argument-list-internal))
;; All that was just so we could do argument completion!
(when (and (not rev1) rev2)
(error "Not a valid revision range"))
@@ -1665,6 +1684,48 @@ saving the buffer."
(vc-diff-internal t (vc-deduce-fileset t) nil nil
(called-interactively-p 'interactive))))
+(declare-function ediff-vc-internal (rev1 rev2 &optional startup-hooks))
+
+;;;###autoload
+(defun vc-version-ediff (files rev1 rev2)
+ "Show differences between revisions of the fileset in the
+repository history using ediff."
+ (interactive (vc-diff-build-argument-list-internal))
+ ;; All that was just so we could do argument completion!
+ (when (and (not rev1) rev2)
+ (error "Not a valid revision range"))
+
+ (message "%s" (format "Finding changes in %s..." (vc-delistify files)))
+
+ ;; Functions ediff-(vc|rcs)-internal use "" instead of nil.
+ (when (null rev1) (setq rev1 ""))
+ (when (null rev2) (setq rev2 ""))
+
+ (cond
+ ;; FIXME We only support running ediff on one file for now.
+ ;; We could spin off an ediff session per file in the file set.
+ ((= (length files) 1)
+ (ediff-load-version-control)
+ (find-file (car files)) ;FIXME: find-file from Elisp is bad.
+ (ediff-vc-internal rev1 rev2 nil))
+ (t
+ (error "More than one file is not supported"))))
+
+;;;###autoload
+(defun vc-ediff (historic &optional not-urgent)
+ "Display diffs between file revisions using ediff.
+Normally this compares the currently selected fileset with their
+working revisions. With a prefix argument HISTORIC, it reads two revision
+designators specifying which revisions to compare.
+
+The optional argument NOT-URGENT non-nil means it is ok to say no to
+saving the buffer."
+ (interactive (list current-prefix-arg t))
+ (if historic
+ (call-interactively 'vc-version-ediff)
+ (when buffer-file-name (vc-buffer-sync not-urgent))
+ (vc-version-ediff (cadr (vc-deduce-fileset t)) nil nil)))
+
;;;###autoload
(defun vc-root-diff (historic &optional not-urgent)
"Display diffs between VC-controlled whole tree revisions.
@@ -1815,53 +1876,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)))
@@ -1930,7 +2003,7 @@ checked out in that new branch."
;; For VC's that do not work at file level, it's pointless
;; to ask for a directory, branches are created at repository level.
default-directory
- (read-file-name "Directory: " default-directory default-directory t))
+ (read-directory-name "Directory: " default-directory default-directory t))
(read-string (if current-prefix-arg "New branch name: " "New tag name: "))
current-prefix-arg)))
(message "Making %s... " (if branchp "branch" "tag"))
@@ -1956,7 +2029,7 @@ allowed and simply skipped)."
;; For VC's that do not work at file level, it's pointless
;; to ask for a directory, branches are created at repository level.
default-directory
- (read-file-name "Directory: " default-directory default-directory t))
+ (read-directory-name "Directory: " default-directory default-directory t))
(read-string "Tag name to retrieve (default latest revisions): "))))
(let ((update (yes-or-no-p "Update any affected buffers? "))
(msg (if (or (not name) (string= name ""))
@@ -1990,22 +2063,20 @@ Not all VC backends support short logs!")
(goto-char (point-max))
(lexical-let ((working-revision working-revision)
(limit limit))
- (widget-create 'push-button
- :notify (lambda (&rest ignore)
- (vc-print-log-internal
- log-view-vc-backend log-view-vc-fileset
- working-revision nil (* 2 limit)))
- :help-echo "Show the log again, and double the number of log entries shown"
- "Show 2X entries")
- (widget-insert " ")
- (widget-create 'push-button
- :notify (lambda (&rest ignore)
- (vc-print-log-internal
- log-view-vc-backend log-view-vc-fileset
- working-revision nil nil))
- :help-echo "Show the log again, showing all entries"
- "Show unlimited entries"))
- (widget-setup)))
+ (insert "\n")
+ (insert-text-button "Show 2X entries"
+ 'action (lambda (&rest ignore)
+ (vc-print-log-internal
+ log-view-vc-backend log-view-vc-fileset
+ working-revision nil (* 2 limit)))
+ 'help-echo "Show the log again, and double the number of log entries shown")
+ (insert " ")
+ (insert-text-button "Show unlimited entries"
+ 'action (lambda (&rest ignore)
+ (vc-print-log-internal
+ log-view-vc-backend log-view-vc-fileset
+ working-revision nil nil))
+ 'help-echo "Show the log again, including all entries"))))
(defun vc-print-log-internal (backend files working-revision
&optional is-start-revision limit)
@@ -2273,35 +2344,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-pull (&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-update 'vc-pull)
(defun vc-version-backup-file (file &optional rev)
"Return name of backup file for revision REV of FILE.
@@ -2580,9 +2663,6 @@ log entries should be gathered."
(when index
(substring rev 0 index))))
-(define-obsolete-function-alias
- 'vc-default-previous-version 'vc-default-previous-revision "23.1")
-
(defun vc-default-responsible-p (backend file)
"Indicate whether BACKEND is reponsible for FILE.
The default is to return nil always."
@@ -2737,5 +2817,4 @@ Invoke FUNC f ARGS on each VC-managed file f underneath it."
(provide 'vc)
-;; arch-tag: ca82c1de-3091-4e26-af92-460abc6213a6
;;; vc.el ends here
diff --git a/lisp/vcursor.el b/lisp/vcursor.el
index f4d2f2a6c39..d4fc35920a9 100644
--- a/lisp/vcursor.el
+++ b/lisp/vcursor.el
@@ -1,7 +1,6 @@
;;; vcursor.el --- manipulate an alternative ("virtual") cursor
-;; Copyright (C) 1994, 1996, 1998, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 1996, 1998, 2001-2011 Free Software Foundation, Inc.
;; Author: Peter Stephenson <pws@ibmth.df.unipi.it>
;; Maintainer: FSF
@@ -325,7 +324,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))
@@ -1144,5 +1143,4 @@ line is treated like ordinary characters."
(provide 'vcursor)
-;; arch-tag: cdfe1cdc-2c46-4046-88e4-ed57d20f7aca
;;; vcursor.el ends here
diff --git a/lisp/version.el b/lisp/version.el
index 424c681c083..d28a3004585 100644
--- a/lisp/version.el
+++ b/lisp/version.el
@@ -1,11 +1,11 @@
;;; version.el --- record version number of Emacs -*- no-byte-compile: t -*-
-;; Copyright (C) 1985, 1992, 1994, 1995, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+;; Copyright (C) 1985, 1992, 1994-1995, 1999-2011
;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -29,12 +29,6 @@
;;; Code:
-(defconst emacs-copyright "Copyright (C) 2011 Free Software Foundation, Inc." "\
-Short copyright string for this version of Emacs.")
-
-(defconst emacs-version "23.3.50" "\
-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 7d5f7f81a9b..e91c4dd175c 100644
--- a/lisp/view.el
+++ b/lisp/view.el
@@ -1,7 +1,7 @@
;;; view.el --- peruse file or buffer without editing
-;; Copyright (C) 1985, 1989, 1994, 1995, 1997, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1989, 1994-1995, 1997, 2000-2011
+;; Free Software Foundation, Inc.
;; Author: K. Shane Hartman
;; Maintainer: Inge Frick <inge@nada.kth.se>
@@ -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."
@@ -823,7 +807,7 @@ Also set the mark at the position where point was."
(forward-line (1- line))
(view-recenter))
-(defun View-back-to-mark (&optional ignore)
+(defun View-back-to-mark (&optional _ignore)
"Return to last mark set in View mode, else beginning of file.
Display that line at the center of the window.
This command pops the mark ring, so that successive
@@ -1102,5 +1086,4 @@ If TIMES is negative, search backwards."
(provide 'view)
-;; arch-tag: 6d0ace36-1d12-4de3-8de3-1fa3231636d7
;;; view.el ends here
diff --git a/lisp/vt-control.el b/lisp/vt-control.el
index 81b734e0776..558978768bc 100644
--- a/lisp/vt-control.el
+++ b/lisp/vt-control.el
@@ -1,7 +1,6 @@
;;; vt-control.el --- Common VTxxx control functions
-;; Copyright (C) 1993, 1994, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1994, 2001-2011 Free Software Foundation, Inc.
;; Author: Rob Riepel <riepel@networking.stanford.edu>
;; Maintainer: Rob Riepel <riepel@networking.stanford.edu>
@@ -108,5 +107,4 @@
(provide 'vt-control)
-;; arch-tag: d4fed1bf-2524-4ba1-a4fe-86bca3d928a2
;;; vt-control.el ends here
diff --git a/lisp/vt100-led.el b/lisp/vt100-led.el
index 350a8f3ab87..8a4b4ac288c 100644
--- a/lisp/vt100-led.el
+++ b/lisp/vt100-led.el
@@ -1,7 +1,6 @@
;;; vt100-led.el --- functions for LED control on VT-100 terminals & clones
-;; Copyright (C) 1988, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1988, 2001-2011 Free Software Foundation, Inc.
;; Author: Howard Gayle
;; Maintainer: FSF
@@ -66,5 +65,4 @@ Element 0 is not used.")
(provide 'vt100-led)
-;; arch-tag: 346e6480-5e31-4234-aafe-257cea4a36d1
;;; vt100-led.el ends here
diff --git a/lisp/w32-fns.el b/lisp/w32-fns.el
index 2ece6e0c487..a002a63e3f8 100644
--- a/lisp/w32-fns.el
+++ b/lisp/w32-fns.el
@@ -1,10 +1,10 @@
-;;; w32-fns.el --- Lisp routines for Windows NT
+;;; w32-fns.el --- Lisp routines for 32-bit Windows
-;; Copyright (C) 1994, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 2001-2011 Free Software Foundation, Inc.
;; Author: Geoff Voelker <voelker@cs.washington.edu>
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -31,34 +31,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")
@@ -84,7 +56,7 @@ That includes all Windows systems except for 9X/Me."
(defun w32-shell-name ()
"Return the name of the shell being used."
- (or (bound-and-true-p explicit-shell-file-name)
+ (or (bound-and-true-p shell-file-name)
(getenv "ESHELL")
(getenv "SHELL")
(and (w32-using-nt) "cmd.exe")
@@ -253,15 +225,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)
@@ -312,7 +285,7 @@ Note that on MS-Windows, primary and secondary selections set by Emacs
are not available to other programs."
(put 'x-selections (or type 'PRIMARY) data))
-(defun x-get-selection (&optional type data-type)
+(defun x-get-selection (&optional type _data-type)
"Return the value of an X Windows selection.
The argument TYPE (default `PRIMARY') says which selection,
and the argument DATA-TYPE (default `STRING') says
@@ -423,40 +396,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 +423,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)
@@ -482,6 +431,11 @@ they were unset."
;;;; Support for build process
+
+;; From autoload.el
+(defvar autoload-make-program)
+(defvar generated-autoload-file)
+
(defun w32-batch-update-autoloads ()
"Like `batch-update-autoloads', but takes the name of the autoloads file
from the command line.
@@ -509,5 +463,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 ee8f2beec39..d1e8edc40be 100644
--- a/lisp/w32-vars.el
+++ b/lisp/w32-vars.el
@@ -1,10 +1,10 @@
;;; w32-vars.el --- MS-Windows specific user options
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
;; Author: Jason Rumney <jasonr@gnu.org>
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -147,17 +147,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/wdired.el b/lisp/wdired.el
index a9189c39203..f71979e2727 100644
--- a/lisp/wdired.el
+++ b/lisp/wdired.el
@@ -1,7 +1,6 @@
;;; wdired.el --- Rename files editing their names in dired buffers
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Filename: wdired.el
;; Author: Juan Len Lahoz Garca <juanleon1@gmail.com>
@@ -59,39 +58,13 @@
;;
;; - To mark files for deletion, by deleting their whole filename.
-;;; Installation:
-
-;; Add this file (byte-compiling it is recommended) to your load-path.
-;; Then add one of these set of lines (or similar ones) to your config:
-;;
-;; This is the easy way:
-;;
-;; (require 'wdired)
-;; (define-key dired-mode-map "r" 'wdired-change-to-wdired-mode)
-;;
-;; This is the recommended way for faster Emacs startup time and lower
-;; memory consumption:
-;;
-;; (autoload 'wdired-change-to-wdired-mode "wdired")
-;; (eval-after-load "dired"
-;; '(lambda ()
-;; (define-key dired-mode-map "r" 'wdired-change-to-wdired-mode)
-;; (define-key dired-mode-map
-;; [menu-bar immediate wdired-change-to-wdired-mode]
-;; '("Edit File Names" . wdired-change-to-wdired-mode))))
-;;
-;; Type "M-x customize-group RET wdired" if you want to make changes
-;; to the default behavior.
-
;;; Usage:
-;; Then, you can start editing the names of the files by typing "r"
-;; (or whatever key you choose, or M-x wdired-change-to-wdired-mode).
-;; Use C-c C-c when finished or C-c C-k to abort. You can use also the
-;; menu options: in dired mode, "Edit File Names" under "Immediate".
-;; While editing the names, a new submenu "WDired" is available at top
-;; level. You can customize the behavior of this package from this
-;; menu.
+;; You can edit the names of the files by typing C-x C-q or by
+;; executing M-x wdired-change-to-wdired-mode. Use C-c C-c when
+;; finished or C-c C-k to abort. While editing filenames, a new
+;; submenu "WDired" is available at top level. You can customize the
+;; behavior of this package from this menu.
;;; Change Log:
@@ -541,7 +514,7 @@ and proceed depending on the answer."
(interactive)
(customize-apropos "wdired" 'groups))
-(defun wdired-revert (&optional arg noconfirm)
+(defun wdired-revert (&optional _arg _noconfirm)
"Discard changes in the buffer and update it based on changes on disk.
Optional arguments are ignored."
(wdired-change-to-dired-mode)
@@ -649,7 +622,7 @@ If OLD, return the old target. If MOVE, move point before it."
(if (< arg 0)
(funcall command arg)
(while (> arg 0)
- (condition-case err
+ (condition-case nil
(progn
(funcall command 1)
(setq arg (1- arg)))
@@ -841,5 +814,4 @@ Like original function but it skips read-only words."
;; byte-compile-dynamic: t
;; End:
-;; arch-tag: bc00902e-526f-4305-bc7f-8862a559184f
;;; wdired.el ends here
diff --git a/lisp/whitespace.el b/lisp/whitespace.el
index 6608c0c2c50..89f078a5063 100644
--- a/lisp/whitespace.el
+++ b/lisp/whitespace.el
@@ -1,12 +1,11 @@
;;; whitespace.el --- minor mode to visualize TAB, (HARD) SPACE, NEWLINE
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: data, wp
-;; Version: 13.1
+;; Version: 13.2.1
;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
;; This file is part of GNU Emacs.
@@ -313,6 +312,9 @@
;; Acknowledgements
;; ----------------
;;
+;; Thanks to felix (EmacsWiki) for keeping highlight when switching between
+;; major modes on a file.
+;;
;; Thanks to David Reitter <david.reitter@gmail.com> for suggesting a
;; `whitespace-newline' initialization with low contrast relative to
;; the background color.
@@ -798,13 +800,12 @@ Used when `whitespace-style' includes `tabs'."
(defcustom whitespace-trailing-regexp
- "\\(\\(\t\\| \\|\xA0\\|\x8A0\\|\x920\\|\xE20\\|\xF20\\)+\\)$"
+ "\\([\t \u00A0]+\\)$"
"Specify trailing characters regexp.
If you're using `mule' package, there may be other characters besides:
- \" \" \"\\t\" \"\\xA0\" \"\\x8A0\" \"\\x920\" \"\\xE20\" \
-\"\\xF20\"
+ \" \" \"\\t\" \"\\u00A0\"
that should be considered blank.
@@ -1103,7 +1104,7 @@ See also `whitespace-newline' and `whitespace-display-mappings'."
:init-value nil
:global nil
:group 'whitespace
- (let ((whitespace-style '(newline-mark newline)))
+ (let ((whitespace-style '(face newline-mark newline)))
(whitespace-mode whitespace-newline-mode)
;; sync states (running a batch job)
(setq whitespace-newline-mode whitespace-mode)))
@@ -1131,15 +1132,17 @@ See also `whitespace-style', `whitespace-newline' and
(noninteractive ; running a batch job
(setq global-whitespace-mode nil))
(global-whitespace-mode ; global-whitespace-mode on
- (save-excursion
+ (save-current-buffer
(add-hook 'find-file-hook 'whitespace-turn-on-if-enabled)
+ (add-hook 'after-change-major-mode-hook 'whitespace-turn-on-if-enabled)
(dolist (buffer (buffer-list)) ; adjust all local mode
(set-buffer buffer)
(unless whitespace-mode
(whitespace-turn-on-if-enabled)))))
(t ; global-whitespace-mode off
- (save-excursion
+ (save-current-buffer
(remove-hook 'find-file-hook 'whitespace-turn-on-if-enabled)
+ (remove-hook 'after-change-major-mode-hook 'whitespace-turn-on-if-enabled)
(dolist (buffer (buffer-list)) ; adjust all local mode
(set-buffer buffer)
(unless whitespace-mode
@@ -1522,7 +1525,7 @@ documentation."
;; whole buffer
(t
(save-excursion
- (save-match-data
+ (save-match-data ;FIXME: Why?
;; PROBLEM 1: empty lines at bob
;; PROBLEM 2: empty lines at eob
;; ACTION: remove all empty lines at bob and/or eob
@@ -1594,7 +1597,7 @@ documentation."
overwrite-mode ; enforce no overwrite
tmp)
(save-excursion
- (save-match-data
+ (save-match-data ;FIXME: Why?
;; PROBLEM 1: 8 or more SPACEs at bol
(cond
;; ACTION: replace 8 or more SPACEs at bol by TABs, if
@@ -1653,12 +1656,12 @@ documentation."
(whitespace-replace-action
(if whitespace-indent-tabs-mode 'tabify 'untabify)
rstart rend whitespace-space-before-tab-regexp
- (if whitespace-indent-tabs-mode 1 2)))
+ (if whitespace-indent-tabs-mode 0 2)))
;; ACTION: replace SPACEs before TAB by TABs.
((memq 'space-before-tab::tab whitespace-style)
(whitespace-replace-action
'tabify rstart rend
- whitespace-space-before-tab-regexp 1))
+ whitespace-space-before-tab-regexp 0))
;; ACTION: replace TABs by SPACEs.
((memq 'space-before-tab::space whitespace-style)
(whitespace-replace-action
@@ -1866,7 +1869,7 @@ cleaning up these problems."
(interactive "r")
(setq force (or current-prefix-arg force))
(save-excursion
- (save-match-data
+ (save-match-data ;FIXME: Why?
(let* ((has-bogus nil)
(rstart (min start end))
(rend (max start end))
@@ -2047,7 +2050,7 @@ can't split window to display whitespace toggle options"))
"Scroll help window, if it exists.
If UP is non-nil, scroll up; otherwise, scroll down."
- (condition-case data-help
+ (condition-case nil
(let ((buffer (get-buffer whitespace-help-buffer-name)))
(if buffer
(with-selected-window (get-buffer-window buffer)
@@ -2408,9 +2411,8 @@ resultant list will be returned."
"Match trailing spaces which do not contain the point at end of line."
(let ((status t))
(while (if (re-search-forward whitespace-trailing-regexp limit t)
- (save-match-data
- (= whitespace-point (match-end 1))) ;; loop if point at eol
- (setq status nil))) ;; end of buffer
+ (= whitespace-point (match-end 1)) ;; Loop if point at eol.
+ (setq status nil))) ;; End of buffer.
status))
@@ -2424,9 +2426,7 @@ beginning of buffer."
((= b 1)
(setq r (and (/= whitespace-point 1)
(looking-at whitespace-empty-at-bob-regexp)))
- (if r
- (set-marker whitespace-bob-marker (match-end 1))
- (set-marker whitespace-bob-marker b)))
+ (set-marker whitespace-bob-marker (if r (match-end 1) b)))
;; inside bob empty region
((<= limit whitespace-bob-marker)
(setq r (looking-at whitespace-empty-at-bob-regexp))
@@ -2437,9 +2437,7 @@ beginning of buffer."
;; intersection with end of bob empty region
((<= b whitespace-bob-marker)
(setq r (looking-at whitespace-empty-at-bob-regexp))
- (if r
- (set-marker whitespace-bob-marker (match-end 1))
- (set-marker whitespace-bob-marker b)))
+ (set-marker whitespace-bob-marker (if r (match-end 1) b)))
;; it is not inside bob empty region
(t
(setq r nil)))
@@ -2495,7 +2493,7 @@ buffer."
r))
-(defun whitespace-buffer-changed (beg end)
+(defun whitespace-buffer-changed (_beg _end)
"Set `whitespace-buffer-changed' variable to t."
(setq whitespace-buffer-changed t))
@@ -2669,5 +2667,4 @@ It should be added buffer-locally to `write-file-functions'."
(run-hooks 'whitespace-load-hook)
-;; arch-tag: 1b1e2500-dbd4-4a26-8f7a-5a5edfd3c97e
;;; whitespace.el ends here
diff --git a/lisp/wid-browse.el b/lisp/wid-browse.el
index fbecdc9fd89..b765e46b9c6 100644
--- a/lisp/wid-browse.el
+++ b/lisp/wid-browse.el
@@ -1,10 +1,10 @@
;;; wid-browse.el --- functions for browsing widgets
;;
-;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2001-2011 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: extensions
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -189,7 +189,7 @@ The :value of the widget shuld be the widget to be browsed."
:value-create 'widget-browse-value-create
:action 'widget-browse-action)
-(defun widget-browse-action (widget &optional event)
+(defun widget-browse-action (widget &optional _event)
;; Create widget browser for WIDGET's :value.
(widget-browse (widget-get widget :value)))
@@ -205,12 +205,12 @@ The :value of the widget shuld be the widget to be browsed."
;;; Keyword Printer Functions.
-(defun widget-browse-widget (widget key value)
+(defun widget-browse-widget (_widget _key value)
"Insert description of WIDGET's KEY VALUE.
VALUE is assumed to be a widget."
(widget-create 'widget-browse value))
-(defun widget-browse-widgets (widget key value)
+(defun widget-browse-widgets (_widget _key value)
"Insert description of WIDGET's KEY VALUE.
VALUE is assumed to be a list of widgets."
(while value
@@ -220,7 +220,7 @@ VALUE is assumed to be a list of widgets."
(when value
(widget-insert " "))))
-(defun widget-browse-sexp (widget key value)
+(defun widget-browse-sexp (_widget _key value)
"Insert description of WIDGET's KEY VALUE.
Nothing is assumed about value."
(let ((pp (condition-case signal
@@ -236,7 +236,7 @@ Nothing is assumed about value."
(widget-insert pp)
(widget-create 'push-button
:tag "show"
- :action (lambda (widget &optional event)
+ :action (lambda (widget &optional _event)
(with-output-to-temp-buffer
"*Pp Eval Output*"
(princ (widget-get widget :value))))
@@ -278,5 +278,4 @@ With arg, turn widget mode on if and only if arg is positive."
(provide 'wid-browse)
-;; arch-tag: d5ffb18f-8984-4735-8502-edf70456db21
;;; wid-browse.el ends here
diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el
index e83a599c814..31cc8ad9ca9 100644
--- a/lisp/wid-edit.el
+++ b/lisp/wid-edit.el
@@ -1,11 +1,11 @@
;;; wid-edit.el --- Functions for creating and using widgets -*-byte-compile-dynamic: t;-*-
;;
-;; Copyright (C) 1996, 1997, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1997, 1999-2011 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Maintainer: FSF
;; Keywords: extensions
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -56,8 +56,6 @@
;;; Code:
-(defvar widget)
-
;;; Compatibility.
(defun widget-event-point (event)
@@ -78,8 +76,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 +251,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)
@@ -415,7 +414,7 @@ the :notify function can't know the new value.")
(overlay-put overlay 'follow-link follow-link)
(overlay-put overlay 'help-echo help-echo)))
-(defun widget-mouse-help (window overlay point)
+(defun widget-mouse-help (_window overlay _point)
"Help-echo callback for widgets whose :help-echo is a function."
(with-current-buffer (overlay-buffer overlay)
(let* ((widget (widget-at (overlay-start overlay)))
@@ -467,7 +466,7 @@ the :notify function can't know the new value.")
(overlay-put overlay 'modification-hooks '(widget-overlay-inactive))
(widget-put widget :inactive overlay))))
-(defun widget-overlay-inactive (&rest junk)
+(defun widget-overlay-inactive (&rest _junk)
"Ignoring the arguments, signal an error."
(unless inhibit-read-only
(error "The widget here is not active")))
@@ -637,9 +636,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))
+ specs)))
+ (find-image (nreverse specs))))
(t
;; Oh well.
nil)))
@@ -649,14 +648,14 @@ extension (xpm, xbm, gif, jpg, or png) located in
This exists as a variable so it can be set locally in certain
buffers.")
-(defun widget-image-insert (widget tag image &optional down inactive)
+(defun widget-image-insert (widget tag image &optional _down _inactive)
"In WIDGET, insert the text TAG or, if supported, IMAGE.
IMAGE should either be an image or an image file name sans extension
\(xpm, xbm, gif, jpg, or png) located in `widget-image-directory'.
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))
@@ -1308,7 +1307,7 @@ Unlike (get-char-property POS 'field), this works with empty fields too."
(add-hook 'before-change-functions 'widget-before-change nil t)
(add-hook 'after-change-functions 'widget-after-change nil t))
-(defun widget-after-change (from to old)
+(defun widget-after-change (from to _old)
"Adjust field size and text properties."
(let ((field (widget-field-find from))
(other (widget-field-find to)))
@@ -1336,7 +1335,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))))
@@ -1432,8 +1431,8 @@ The value of the :type attribute should be an unconverted widget type."
(define-widget 'default nil
"Basic widget other widgets are derived from."
- :value-to-internal (lambda (widget value) value)
- :value-to-external (lambda (widget value) value)
+ :value-to-internal (lambda (_widget value) value)
+ :value-to-external (lambda (_widget value) value)
:button-prefix 'widget-button-prefix
:button-suffix 'widget-button-suffix
:complete 'widget-default-complete
@@ -1460,11 +1459,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 +1482,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 +1515,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)
@@ -1541,7 +1544,7 @@ If that does not exist, call the value of `widget-complete-field'."
(widget-put widget :to to)))
(widget-clear-undo))
-(defun widget-default-format-handler (widget escape)
+(defun widget-default-format-handler (_widget escape)
(error "Unknown escape `%c'" escape))
(defun widget-default-button-face-get (widget)
@@ -1649,11 +1652,11 @@ If that does not exist, call the value of `widget-complete-field'."
(when parent
(widget-apply parent :notify widget event))))
-(defun widget-default-notify (widget child &optional event)
+(defun widget-default-notify (widget _child &optional event)
"Pass notification to parent."
(widget-default-action widget event))
-(defun widget-default-prompt-value (widget prompt value unbound)
+(defun widget-default-prompt-value (_widget prompt _value _unbound)
"Read an arbitrary value."
(eval-minibuffer prompt))
@@ -1701,14 +1704,14 @@ as the argument to `documentation-property'."
;; Match if the value is the same.
(equal (widget-get widget :value) value))
-(defun widget-item-match-inline (widget values)
+(defun widget-item-match-inline (widget vals)
;; Match if the value is the same.
(let ((value (widget-get widget :value)))
(and (listp value)
- (<= (length value) (length values))
- (let ((head (widget-sublist values 0 (length value))))
+ (<= (length value) (length vals))
+ (let ((head (widget-sublist vals 0 (length value))))
(and (equal head value)
- (cons head (widget-sublist values (length value))))))))
+ (cons head (widget-sublist vals (length value))))))))
(defun widget-sublist (list start &optional end)
"Return the sublist of LIST from START to END.
@@ -1793,7 +1796,7 @@ If END is omitted, it defaults to the length of LIST."
"A link to an info file."
:action 'widget-info-link-action)
-(defun widget-info-link-action (widget &optional event)
+(defun widget-info-link-action (widget &optional _event)
"Open the info node specified by WIDGET."
(info (widget-value widget)))
@@ -1803,7 +1806,7 @@ If END is omitted, it defaults to the length of LIST."
"A link to an www page."
:action 'widget-url-link-action)
-(defun widget-url-link-action (widget &optional event)
+(defun widget-url-link-action (widget &optional _event)
"Open the URL specified by WIDGET."
(browse-url (widget-value widget)))
@@ -1813,7 +1816,7 @@ If END is omitted, it defaults to the length of LIST."
"A link to an Emacs function."
:action 'widget-function-link-action)
-(defun widget-function-link-action (widget &optional event)
+(defun widget-function-link-action (widget &optional _event)
"Show the function specified by WIDGET."
(describe-function (widget-value widget)))
@@ -1823,7 +1826,7 @@ If END is omitted, it defaults to the length of LIST."
"A link to an Emacs variable."
:action 'widget-variable-link-action)
-(defun widget-variable-link-action (widget &optional event)
+(defun widget-variable-link-action (widget &optional _event)
"Show the variable specified by WIDGET."
(describe-variable (widget-value widget)))
@@ -1833,7 +1836,7 @@ If END is omitted, it defaults to the length of LIST."
"A link to a file."
:action 'widget-file-link-action)
-(defun widget-file-link-action (widget &optional event)
+(defun widget-file-link-action (widget &optional _event)
"Find the file specified by WIDGET."
(find-file (widget-value widget)))
@@ -1843,7 +1846,7 @@ If END is omitted, it defaults to the length of LIST."
"A link to an Emacs Lisp library file."
:action 'widget-emacs-library-link-action)
-(defun widget-emacs-library-link-action (widget &optional event)
+(defun widget-emacs-library-link-action (widget &optional _event)
"Find the Emacs library file specified by WIDGET."
(find-file (locate-library (widget-value widget))))
@@ -1853,7 +1856,7 @@ If END is omitted, it defaults to the length of LIST."
"A link to Commentary in an Emacs Lisp library file."
:action 'widget-emacs-commentary-link-action)
-(defun widget-emacs-commentary-link-action (widget &optional event)
+(defun widget-emacs-commentary-link-action (widget &optional _event)
"Find the Commentary section of the Emacs file specified by WIDGET."
(finder-commentary (widget-value widget)))
@@ -1876,6 +1879,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)
@@ -1883,7 +1887,7 @@ by some other text in the `:format' string (if specified)."
(defvar widget-field-history nil
"History of field minibuffer edits.")
-(defun widget-field-prompt-internal (widget prompt initial history)
+(defun widget-field-prompt-internal (_widget prompt initial history)
"Read string for WIDGET prompting with PROMPT.
INITIAL is the initial input and HISTORY is a symbol containing
the earlier input."
@@ -1903,7 +1907,7 @@ the earlier input."
(defvar widget-edit-functions nil)
-(defun widget-field-action (widget &optional event)
+(defun widget-field-action (widget &optional _event)
"Move to next field."
(widget-forward 1)
(run-hook-with-args 'widget-edit-functions widget))
@@ -1914,6 +1918,17 @@ 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)))
+ (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 +1966,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)
@@ -1968,7 +1982,7 @@ the earlier input."
result))
(widget-get widget :value))))
-(defun widget-field-match (widget value)
+(defun widget-field-match (_widget value)
;; Match any string.
(stringp value))
@@ -2039,7 +2053,7 @@ when he invoked the menu."
:type 'boolean
:group 'widgets)
-(defun widget-choice-mouse-down-action (widget &optional event)
+(defun widget-choice-mouse-down-action (widget &optional _event)
;; Return non-nil if we need a menu.
(let ((args (widget-get widget :args))
(old (widget-get widget :choice)))
@@ -2123,14 +2137,14 @@ when he invoked the menu."
found (widget-apply current :match value)))
found))
-(defun widget-choice-match-inline (widget values)
+(defun widget-choice-match-inline (widget vals)
;; Matches if one of the choices matches.
(let ((args (widget-get widget :args))
current found)
(while (and args (null found))
(setq current (car args)
args (cdr args)
- found (widget-match-inline current values)))
+ found (widget-match-inline current vals)))
found))
;;; The `toggle' Widget.
@@ -2140,27 +2154,19 @@ when he invoked the menu."
:format "%[%v%]\n"
:value-create 'widget-toggle-value-create
:action 'widget-toggle-action
- :match (lambda (widget value) t)
+ :match (lambda (_widget _value) t)
:on "on"
:off "off")
(defun widget-toggle-value-create (widget)
"Insert text representing the `on' and `off' states."
- (if (widget-value widget)
- (let ((image (widget-get widget :on-glyph)))
- (and (display-graphic-p)
- (listp image)
- (not (eq (car image) 'image))
- (widget-put widget :on-glyph (setq image (eval image))))
- (widget-image-insert widget
- (widget-get widget :on)
- image))
- (let ((image (widget-get widget :off-glyph)))
- (and (display-graphic-p)
- (listp image)
- (not (eq (car image) 'image))
- (widget-put widget :off-glyph (setq image (eval image))))
- (widget-image-insert widget (widget-get widget :off) image))))
+ (let* ((val (widget-value widget))
+ (text (widget-get widget (if val :on :off)))
+ (img (widget-image-find
+ (widget-get widget (if val :on-glyph :off-glyph)))))
+ (widget-image-insert widget (or text "")
+ (if img
+ (append img '(:ascent center))))))
(defun widget-toggle-action (widget &optional event)
;; Toggle value.
@@ -2179,19 +2185,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 +2219,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 +2243,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)
@@ -2275,34 +2270,35 @@ If the item is checked, CHOSEN is a cons whose cdr is the value."
(and button (widget-put widget :buttons (cons button buttons)))
(and child (widget-put widget :children (cons child children))))))
-(defun widget-checklist-match (widget values)
+(defun widget-checklist-match (widget vals)
;; All values must match a type in the checklist.
- (and (listp values)
- (null (cdr (widget-checklist-match-inline widget values)))))
+ (and (listp vals)
+ (null (cdr (widget-checklist-match-inline widget vals)))))
-(defun widget-checklist-match-inline (widget values)
+(defun widget-checklist-match-inline (widget vals)
;; Find the values which match a type in the checklist.
(let ((greedy (widget-get widget :greedy))
(args (copy-sequence (widget-get widget :args)))
found rest)
- (while values
- (let ((answer (widget-checklist-match-up args values)))
+ (while vals
+ (let ((answer (widget-checklist-match-up args vals)))
(cond (answer
- (let ((vals (widget-match-inline answer values)))
+ (let ((vals (widget-match-inline answer vals)))
(setq found (append found (car vals))
- values (cdr vals)
+ vals (cdr vals)
args (delq answer args))))
(greedy
- (setq rest (append rest (list (car values)))
- values (cdr values)))
+ (setq rest (append rest (list (car vals)))
+ vals (cdr vals)))
(t
- (setq rest (append rest values)
- values nil)))))
+ (setq rest (append rest vals)
+ vals 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)
@@ -2378,7 +2374,7 @@ Return an alist of (TYPE MATCH)."
:off "( )"
:off-glyph "radio0")
-(defun widget-radio-button-notify (widget child &optional event)
+(defun widget-radio-button-notify (widget _child &optional event)
;; Tell daddy.
(widget-apply (widget-get widget :parent) :action widget event))
@@ -2431,7 +2427,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)
@@ -2547,7 +2543,7 @@ Return an alist of (TYPE MATCH)."
:help-echo "Insert a new item into the list at this position."
:action 'widget-insert-button-action)
-(defun widget-insert-button-action (widget &optional event)
+(defun widget-insert-button-action (widget &optional _event)
;; Ask the parent to insert a new item.
(widget-apply (widget-get widget :parent)
:insert-before (widget-get widget :widget)))
@@ -2560,7 +2556,7 @@ Return an alist of (TYPE MATCH)."
:help-echo "Delete this item from the list."
:action 'widget-delete-button-action)
-(defun widget-delete-button-action (widget &optional event)
+(defun widget-delete-button-action (widget &optional _event)
;; Ask the parent to insert a new item.
(widget-apply (widget-get widget :parent)
:delete-at (widget-get widget :widget)))
@@ -2710,7 +2706,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)
@@ -2783,10 +2779,10 @@ Return an alist of (TYPE MATCH)."
;; Get the default of the components.
(mapcar 'widget-default-get (widget-get widget :args)))
-(defun widget-group-match (widget values)
+(defun widget-group-match (widget vals)
;; Match if the components match.
- (and (listp values)
- (let ((match (widget-group-match-inline widget values)))
+ (and (listp vals)
+ (let ((match (widget-group-match-inline widget vals)))
(and match (null (cdr match))))))
(defun widget-group-match-inline (widget vals)
@@ -2795,11 +2791,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,33 +2803,25 @@ 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-glyph 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-glyph 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-glyph "down"
:on "Hide"
+ :off-glyph "right"
:off "Show"
:value-create 'widget-visibility-value-create
:action 'widget-toggle-action
- :match (lambda (widget value) t))
-
-(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"))))
+ :match (lambda (_widget _value) t))
+
+(defalias 'widget-visibility-value-create 'widget-toggle-value-create)
;;; The `documentation-link' Widget.
;;
@@ -2846,7 +2833,7 @@ Return an alist of (TYPE MATCH)."
:help-echo "Describe this symbol"
:action 'widget-documentation-link-action)
-(defun widget-documentation-link-action (widget &optional event)
+(defun widget-documentation-link-action (widget &optional _event)
"Display documentation for WIDGET's value. Ignore optional argument EVENT."
(let* ((string (widget-get widget :value))
(symbol (intern string)))
@@ -2937,7 +2924,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
@@ -2955,7 +2942,7 @@ link for that string."
(widget-documentation-link-add widget start (point))))
(insert ?\n))
-(defun widget-documentation-string-action (widget &rest ignore)
+(defun widget-documentation-string-action (widget &rest _ignore)
;; Toggle documentation.
(let ((parent (widget-get widget :parent)))
(widget-put parent :documentation-shown
@@ -2993,7 +2980,7 @@ Optional ARGS specifies additional keyword arguments for the
:prompt-value 'widget-const-prompt-value
:format "%t\n%d")
-(defun widget-const-prompt-value (widget prompt value unbound)
+(defun widget-const-prompt-value (widget _prompt _value _unbound)
;; Return the value of the const.
(widget-value widget))
@@ -3031,14 +3018,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)))))
@@ -3054,7 +3040,7 @@ widget. If that isn't a list, it's evalled and expected to yield a list."
;; :value-face 'widget-single-line-field
:tag "Regexp")
-(defun widget-regexp-match (widget value)
+(defun widget-regexp-match (_widget value)
;; Match valid regexps.
(and (stringp value)
(condition-case nil
@@ -3083,9 +3069,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.
@@ -3125,16 +3112,16 @@ It reads a directory name from an editable text field."
:value nil
:tag "Symbol"
:format "%{%t%}: %v"
- :match (lambda (widget value) (symbolp value))
+ :match (lambda (_widget value) (symbolp value))
:complete-function 'lisp-complete-symbol
:prompt-internal 'widget-symbol-prompt-internal
:prompt-match 'symbolp
:prompt-history 'widget-symbol-prompt-value-history
- :value-to-internal (lambda (widget value)
+ :value-to-internal (lambda (_widget value)
(if (symbolp value)
(symbol-name value)
value))
- :value-to-external (lambda (widget value)
+ :value-to-external (lambda (_widget value)
(if (stringp value)
(intern value)
value)))
@@ -3202,7 +3189,7 @@ It reads a directory name from an editable text field."
:value 'undecided
:prompt-match 'coding-system-p)
-(defun widget-coding-system-prompt-value (widget prompt value unbound)
+(defun widget-coding-system-prompt-value (widget prompt value _unbound)
"Read coding-system from minibuffer."
(if (widget-get widget :base-only)
(intern
@@ -3292,7 +3279,7 @@ It reads a directory name from an editable text field."
(key-description value))
value))
-(defun widget-key-sequence-value-to-external (widget value)
+(defun widget-key-sequence-value-to-external (_widget value)
(if (stringp value)
(if (string-match "\\`[[:space:]]*\\'" value)
widget-key-sequence-default-value
@@ -3306,13 +3293,13 @@ It reads a directory name from an editable text field."
:format "%{%t%}: %v"
:value nil
:validate 'widget-sexp-validate
- :match (lambda (widget value) t)
+ :match (lambda (_widget _value) t)
:value-to-internal 'widget-sexp-value-to-internal
- :value-to-external (lambda (widget value) (read value))
+ :value-to-external (lambda (_widget value) (read value))
:prompt-history 'widget-sexp-prompt-value-history
:prompt-value 'widget-sexp-prompt-value)
-(defun widget-sexp-value-to-internal (widget value)
+(defun widget-sexp-value-to-internal (_widget value)
;; Use pp for printer representation.
(let ((pp (if (symbolp value)
(prin1-to-string value)
@@ -3419,15 +3406,15 @@ To use this type, you must define :match or :match-alternatives."
:format "%{%t%}: %v\n"
:valid-regexp "\\`.\\'"
:error "This field should contain a single character"
- :value-to-internal (lambda (widget value)
+ :value-to-internal (lambda (_widget value)
(if (stringp value)
value
(char-to-string value)))
- :value-to-external (lambda (widget value)
+ :value-to-external (lambda (_widget value)
(if (stringp value)
(aref value 0)
value))
- :match (lambda (widget value)
+ :match (lambda (_widget value)
(characterp value)))
(define-widget 'list 'group
@@ -3440,8 +3427,8 @@ To use this type, you must define :match or :match-alternatives."
:tag "Vector"
:format "%{%t%}:\n%v"
:match 'widget-vector-match
- :value-to-internal (lambda (widget value) (append value nil))
- :value-to-external (lambda (widget value) (apply 'vector value)))
+ :value-to-internal (lambda (_widget value) (append value nil))
+ :value-to-external (lambda (_widget value) (apply 'vector value)))
(defun widget-vector-match (widget value)
(and (vectorp value)
@@ -3453,9 +3440,9 @@ To use this type, you must define :match or :match-alternatives."
:tag "Cons-cell"
:format "%{%t%}:\n%v"
:match 'widget-cons-match
- :value-to-internal (lambda (widget value)
+ :value-to-internal (lambda (_widget value)
(list (car value) (cdr value)))
- :value-to-external (lambda (widget value)
+ :value-to-external (lambda (_widget value)
(apply 'cons value)))
(defun widget-cons-match (widget value)
@@ -3616,7 +3603,7 @@ example:
:button-suffix 'widget-push-button-suffix
:prompt-value 'widget-choice-prompt-value)
-(defun widget-choice-prompt-value (widget prompt value unbound)
+(defun widget-choice-prompt-value (widget prompt value _unbound)
"Make a choice."
(let ((args (widget-get widget :args))
(completion-ignore-case (widget-get widget :case-fold))
@@ -3684,7 +3671,7 @@ example:
:on "on (non-nil)"
:off "off (nil)")
-(defun widget-boolean-prompt-value (widget prompt value unbound)
+(defun widget-boolean-prompt-value (_widget prompt _value _unbound)
;; Toggle a boolean.
(y-or-n-p prompt))
@@ -3694,6 +3681,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 +3690,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
@@ -3722,8 +3731,6 @@ example:
"Prompt for a color."
(let* ((tag (widget-apply widget :menu-tag-get))
(prompt (concat tag ": "))
- (value (widget-value widget))
- (start (widget-field-start widget))
(answer (facemenu-read-color prompt)))
(unless (zerop (length answer))
(widget-value-set widget answer)
diff --git a/lisp/widget.el b/lisp/widget.el
index cb5f9f9d214..1bac2e44b3f 100644
--- a/lisp/widget.el
+++ b/lisp/widget.el
@@ -1,12 +1,12 @@
;;; widget.el --- a library of user interface components
;;
-;; Copyright (C) 1996, 1997, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1997, 2001-2011 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; 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.
@@ -36,7 +36,7 @@
;; Doing this is unnecessary in Emacs 20. Kept as dummy in case
;; external libraries call it. We save a kb or two of purespace by
;; dummying-out such definitions generally.
-(defmacro define-widget-keywords (&rest keys)
+(defmacro define-widget-keywords (&rest _keys)
;; ;; Don't use backquote, since that makes trouble trying to
;; ;; re-bootstrap from just the .el files.
;; (list 'eval-and-compile
@@ -95,5 +95,4 @@ The third argument DOC is a documentation string for the widget."
(provide 'widget)
-;; arch-tag: 932c71a3-9aeb-4827-a293-8b88b26d5c58
;;; widget.el ends here
diff --git a/lisp/windmove.el b/lisp/windmove.el
index 81367ac5f0c..2aef37dd4c8 100644
--- a/lisp/windmove.el
+++ b/lisp/windmove.el
@@ -1,7 +1,6 @@
;;; windmove.el --- directional window-selection routines
;;
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;;
;; Author: Hovav Shacham (hovav@cs.stanford.edu)
;; Created: 17 October 1998
@@ -374,14 +373,12 @@ Returns the constrained coordinate."
;; otherwise would be. the only complication is that we need to check
;; if the minibuffer is active, and, if not, pretend that it's not
;; even part of the frame.
-(defun windmove-wrap-loc-for-movement (coord window dir)
+(defun windmove-wrap-loc-for-movement (coord window)
"Takes the constrained COORD and wraps it around for the movement.
This makes an out-of-range x or y coordinate and wraps it around the
frame, giving a coordinate (hopefully) in the window on the other edge
of the frame. WINDOW is the window that movement is relative to (nil
-means the currently selected window); DIR is the direction of the
-movement, one of `left', `up', `right',or `down'.
-Returns the wrapped coordinate."
+means the currently selected window). Returns the wrapped coordinate."
(let* ((frame-edges (windmove-frame-edges window))
(frame-minibuffer (minibuffer-window (if window
(window-frame window)
@@ -475,8 +472,7 @@ DIR, ARG, and WINDOW are handled as by `windmove-other-window-loc'."
(other-window-loc
(if windmove-wrap-around
(windmove-wrap-loc-for-movement constrained-other-window-loc
- actual-current-window
- dir)
+ actual-current-window)
constrained-other-window-loc)))
(window-at (car other-window-loc)
(cdr other-window-loc))))
@@ -568,5 +564,4 @@ Default MODIFIER is 'shift."
(provide 'windmove)
-;; arch-tag: 56267432-bf1a-4296-a9a0-85c6bd9f2375
;;; windmove.el ends here
diff --git a/lisp/window.el b/lisp/window.el
index e8e1c6149fd..9ea00442628 100644
--- a/lisp/window.el
+++ b/lisp/window.el
@@ -1,11 +1,11 @@
;;; window.el --- GNU Emacs window commands aside from those written in C
-;; Copyright (C) 1985, 1989, 1992, 1993, 1994, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+;; Copyright (C) 1985, 1989, 1992-1994, 2000-2011
;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -54,6 +54,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
@@ -105,11 +106,12 @@ even if it is active. Otherwise, the minibuffer is counted
when it is active.
The optional arg ALL-FRAMES t means count windows on all frames.
-If it is `visible', count windows on all visible frames.
-ALL-FRAMES nil or omitted means count only the selected frame,
-plus the minibuffer it uses (which may be on another frame).
-ALL-FRAMES 0 means count all windows in all visible or iconified frames.
-If ALL-FRAMES is anything else, count only the selected frame."
+If it is `visible', count windows on all visible frames on the
+current terminal. ALL-FRAMES nil or omitted means count only the
+selected frame, plus the minibuffer it uses (which may be on
+another frame). ALL-FRAMES 0 means count all windows in all
+visible or iconified frames on the current terminal. If
+ALL-FRAMES is anything else, count only the selected frame."
(let ((base-window (selected-window)))
(if (and nomini (eq base-window (minibuffer-window)))
(setq base-window (next-window base-window)))
@@ -168,9 +170,9 @@ ALL-FRAMES nil or omitted means cycle through all windows on the
ALL-FRAMES t means cycle through all windows on all existing
frames.
ALL-FRAMES `visible' means cycle through all windows on all
- visible frames.
+ visible frames on the current terminal.
ALL-FRAMES 0 means cycle through all windows on all visible and
- iconified frames.
+ iconified frames on the current terminal.
ALL-FRAMES a frame means cycle through all windows on that frame
only.
Anything else means cycle through all windows on the selected
@@ -249,7 +251,7 @@ The optional argument MINIBUF specifies whether the minibuffer
window shall be counted. See `walk-windows' for the precise
meaning of this argument."
(let ((count 0))
- (walk-windows (lambda (w) (setq count (+ count 1)))
+ (walk-windows (lambda (_w) (setq count (+ count 1)))
minibuf)
count))
@@ -421,7 +423,7 @@ subtree is balanced."
Arguments WINDOW, DELTA and HORIZONTAL are passed on to that function."
;; `adjust-window-trailing-edge' may fail if delta is too large.
(while (>= (abs delta) 1)
- (condition-case err
+ (condition-case nil
(progn
(adjust-window-trailing-edge window delta horizontal)
(setq delta 0))
@@ -1066,9 +1068,11 @@ when the specified buffer is already displayed. If the buffer is
already displayed in some window on one of these frames simply
return that window. Possible values of FRAME are:
-`visible' - consider windows on all visible frames.
+`visible' - consider windows on all visible frames on the current
+terminal.
-0 - consider windows on all visible or iconified frames.
+0 - consider windows on all visible or iconified frames on the
+current terminal.
t - consider windows on all frames.
@@ -1078,7 +1082,7 @@ nil - consider windows on the selected frame \(actually the
last non-minibuffer frame\) only. If, however, either
`display-buffer-reuse-frames' or `pop-up-frames' is non-nil
\(non-nil and not graphic-only on a text-only terminal),
-consider all visible or iconified frames."
+consider all visible or iconified frames on the current terminal."
(interactive "BDisplay buffer:\nP")
(let* ((can-use-selected-window
;; The selected window is usable unless either NOT-THIS-WINDOW
@@ -1220,19 +1224,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 +1618,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 +1711,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.")
@@ -1891,5 +2041,4 @@ Otherwise, consult the value of `truncate-partial-width-windows'
(define-key ctl-x-map "+" 'balance-windows)
(define-key ctl-x-4-map "0" 'kill-buffer-and-window)
-;; arch-tag: b508dfcc-c353-4c37-89fa-e773fe10cea9
;;; window.el ends here
diff --git a/lisp/winner.el b/lisp/winner.el
index f1fcb8ff9d9..e5855ad8aac 100644
--- a/lisp/winner.el
+++ b/lisp/winner.el
@@ -1,7 +1,6 @@
;;; winner.el --- Restore old window configurations
-;; Copyright (C) 1997, 1998, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation. Inc.
+;; Copyright (C) 1997-1998, 2001-2011 Free Software Foundation. Inc.
;; Author: Ivar Rummelhoff <ivarru@math.uio.no>
;; Created: 27 Feb 1997
@@ -473,5 +472,4 @@ In other words, \"undo\" changes in window configuration."
minor-mode-map-alist))
(provide 'winner)
-;; arch-tag: 686d1c1b-010e-42ca-a192-b5685112418f
;;; winner.el ends here
diff --git a/lisp/woman.el b/lisp/woman.el
index ff420d9e9a4..eb801b55d4d 100644
--- a/lisp/woman.el
+++ b/lisp/woman.el
@@ -1,13 +1,12 @@
;;; woman.el --- browse UN*X manual pages `wo (without) man'
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Author: Francis J. Wright <F.J.Wright@qmul.ac.uk>
;; 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 +809,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 +845,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)
@@ -1086,6 +1086,9 @@ Set by .PD; used by .SH, .SS, .TP, .LP, .PP, .P, .IP, .HP.")
(defvar woman-nospace nil
"Current no-space mode: nil for normal spacing.
Set by `.ns' request; reset by any output or `.rs' request")
+;; Used for message logging
+(defvar WoMan-current-file nil) ; bound in woman-really-find-file
+(defvar WoMan-Log-header-point-max nil)
(defsubst woman-reset-nospace ()
"Set `woman-nospace' to nil."
@@ -1281,8 +1284,7 @@ cache to be re-read."
;; completions, but to return only a case-sensitive match. This
;; does not seem to work properly by default, so I re-do the
;; completion if necessary.
- (let (files
- (default (current-word)))
+ (let (files)
(or (stringp topic)
(and (if (boundp 'woman-use-topic-at-point)
woman-use-topic-at-point
@@ -1367,16 +1369,17 @@ regexp that is the final component of DIR. Log a warning if list is empty."
(or (file-accessible-directory-p dir)
(WoMan-warn "Ignoring inaccessible `man-page' directory `%s'!" dir)))
-(defun woman-expand-directory-path (woman-manpath woman-path)
- "Expand the manual directories in WOMAN-MANPATH and WOMAN-PATH.
-WOMAN-MANPATH should be a list of general manual directories, while
-WOMAN-PATH should be a list of specific manual directory regexps.
+(defun woman-expand-directory-path (path-dirs path-regexps)
+ "Expand the manual directories in PATH-DIRS and PATH-REGEXPS.
+PATH-DIRS should be a list of general manual directories (like
+`woman-manpath'), while PATH-REGEXPS should be a list of specific
+manual directory regexps (like `woman-path').
Ignore any paths that are unreadable or not directories."
;; Allow each path to be a single string or a list of strings:
- (if (not (listp woman-manpath)) (setq woman-manpath (list woman-manpath)))
- (if (not (listp woman-path)) (setq woman-path (list woman-path)))
+ (if (not (listp path-dirs)) (setq path-dirs (list path-dirs)))
+ (if (not (listp path-regexps)) (setq path-regexps (list path-regexps)))
(let (head dirs path)
- (dolist (dir woman-manpath)
+ (dolist (dir path-dirs)
(when (consp dir)
(unless path
(setq path (split-string (getenv "PATH") path-separator t)))
@@ -1390,7 +1393,7 @@ Ignore any paths that are unreadable or not directories."
(setq dir (woman-canonicalize-dir dir)
dirs (nconc dirs (directory-files
dir t woman-manpath-man-regexp)))))
- (dolist (dir woman-path)
+ (dolist (dir path-regexps)
(if (or (null dir)
(null (setq dir (woman-canonicalize-dir dir)
head (file-name-directory dir)))
@@ -1576,6 +1579,8 @@ Also make each path-info component into a list.
;;; tar-mode support
+(defvar global-font-lock-mode) ; defined in font-core.el
+
(defun woman-tar-extract-file ()
"In tar mode, run the WoMan man-page browser on this file."
(interactive)
@@ -1897,6 +1902,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 +1940,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)
@@ -2239,7 +2248,7 @@ To be called on original buffer and any .so insertions."
This applies to text between .TE and .TS directives.
Currently set only from '\" t in the first line of the source file.")
-(defun woman-decode-region (from to)
+(defun woman-decode-region (from _to)
"Decode the region between FROM and TO in UN*X man-page source format."
;; Suitable for use in format-alist.
;; But this requires care to control major mode implied font locking.
@@ -2439,7 +2448,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 +2479,35 @@ 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))
+ processed-first-hunk
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))
+
+ ;; Process escape sequences prior to first request (Bug#7843).
+ (unless processed-first-hunk
+ (setq processed-first-hunk t)
+ (let ((process-escapes-to-marker (point-marker)))
+ (set-marker-insertion-type process-escapes-to-marker t)
+ (save-match-data
+ (save-excursion
+ (goto-char from)
+ (woman2-process-escapes process-escapes-to-marker)))))
+
+ (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 +2538,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 +2590,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 +2647,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 +2779,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 +3006,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 +3024,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 +3033,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 +3041,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 +3057,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 +3070,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 +3080,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 +3127,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 +3148,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 +3364,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 +3389,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 +3412,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 +3559,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 +3629,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 +3664,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 +3680,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 +3779,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 +3798,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
@@ -4335,9 +4369,9 @@ Format paragraphs upto TO."
(setq tab-stop-list (reverse tab-stop-list))
(woman2-format-paragraphs to))
-(defsubst woman-get-tab-stop (tab-stop-list)
- "If TAB-STOP-LIST is a cons, return its car, else return TAB-STOP-LIST."
- (if (consp tab-stop-list) (car tab-stop-list) tab-stop-list))
+(defsubst woman-get-tab-stop (tab-stops)
+ "If TAB-STOPS is a cons, return its car, else return TAB-STOPS."
+ (if (consp tab-stops) (car tab-stops) tab-stops))
(defun woman-tab-to-tab-stop ()
"Insert spaces to next defined tab-stop column.
@@ -4345,7 +4379,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 +4390,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 +4433,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)
@@ -4455,9 +4489,6 @@ Format paragraphs upto TO."
;; The basis for this logging code was shamelessly pirated from bytecomp.el
;; by Jamie Zawinski <jwz@lucid.com> & Hallvard Furuseth <hbf@ulrik.uio.no>
-(defvar WoMan-current-file nil) ; bound in woman-really-find-file
-(defvar WoMan-Log-header-point-max nil)
-
(defun WoMan-log-begin ()
"Log the beginning of formatting in *WoMan-Log*."
(let ((WoMan-current-buffer (buffer-name)))
@@ -4481,12 +4512,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 +4551,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 a65345a16df..1c6af1f45f2 100644
--- a/lisp/x-dnd.el
+++ b/lisp/x-dnd.el
@@ -1,11 +1,11 @@
;;; x-dnd.el --- drag and drop support for X -*- coding: utf-8 -*-
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;; Author: Jan Djärv <jan.h.d@swipnet.se>
;; Maintainer: FSF
;; Keywords: window, drag, drop
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -145,7 +145,7 @@ any protocol specific data.")
"Return the state in `x-dnd-current-state' for a frame or window."
(cdr (x-dnd-get-state-cons-for-frame frame-or-window)))
-(defun x-dnd-default-test-function (window action types)
+(defun x-dnd-default-test-function (_window _action types)
"The default test function for drag and drop.
WINDOW is where the mouse is when this function is called. It may be
a frame if the mouse is over the menu bar, scroll bar or tool bar.
@@ -219,14 +219,13 @@ 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))
(strings (split-string string "[\r\n]" t))
;; Can one drop more than one moz-url ?? Assume not.
- (url (car strings))
- (title (car (cdr strings))))
+ (url (car strings)))
(x-dnd-handle-uri-list window action url)))
(defun x-dnd-insert-utf8-text (window action text)
@@ -361,7 +360,7 @@ Currently XDND, Motif and old KDE 1.x protocols are recognized."
(declare-function x-window-property "xfns.c"
(prop &optional frame type source delete-p vector-ret-p))
-(defun x-dnd-handle-old-kde (event frame window message format data)
+(defun x-dnd-handle-old-kde (_event frame window _message _format _data)
"Open the files in a KDE 1.x drop."
(let ((values (x-window-property "DndSelection" frame nil 0 t)))
(x-dnd-handle-uri-list window 'private
@@ -434,7 +433,7 @@ otherwise return the frame coordinates."
(declare-function x-get-selection-internal "xselect.c"
(selection-symbol target-type &optional time-stamp))
-(defun x-dnd-handle-xdnd (event frame window message format data)
+(defun x-dnd-handle-xdnd (event frame window message _format data)
"Receive one XDND event (client message) and send the appropriate reply.
EVENT is the client message. FRAME is where the mouse is now.
WINDOW is the window within FRAME where the mouse is now.
@@ -456,11 +455,8 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent."
(x-get-atom-name (aref data 4))))))))
((equal "XdndPosition" message)
- (let* ((x (car (aref data 2)))
- (y (cdr (aref data 2)))
- (action (x-get-atom-name (aref data 4)))
+ (let* ((action (x-get-atom-name (aref data 4)))
(dnd-source (aref data 0))
- (dnd-time (aref data 3))
(action-type (x-dnd-maybe-call-test-function
window
(cdr (assoc action x-dnd-xdnd-to-action))))
@@ -491,7 +487,7 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent."
(x-get-selection-internal
'XdndSelection
(intern (x-dnd-current-type window)))))
- success action ret-action)
+ success action)
(setq action (if value
(condition-case info
@@ -502,11 +498,6 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent."
nil))))
(setq success (if action 1 0))
- (setq ret-action
- (if (eq success 1)
- (or (car (rassoc action x-dnd-xdnd-to-action))
- "XdndActionPrivate")
- 0))
(x-send-client-message
frame dnd-source frame "XdndFinished" 32
@@ -591,7 +582,7 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent."
(2 . private)) ; Motif does not have private, so use copy for private.
"Mapping from number to operation for Motif DND.")
-(defun x-dnd-handle-motif (event frame window message-atom format data)
+(defun x-dnd-handle-motif (event frame window message-atom _format data)
(let* ((message-type (cdr (assoc (aref data 0) x-dnd-motif-message-types)))
(source-byteorder (aref data 1))
(my-byteorder (byteorder))
@@ -765,5 +756,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
diff --git a/lisp/xml.el b/lisp/xml.el
index edcc13d6b8d..52bb0de7ea0 100644
--- a/lisp/xml.el
+++ b/lisp/xml.el
@@ -1,7 +1,6 @@
;;; xml.el --- XML parser
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
;; Author: Emmanuel Briot <briot@gnat.com>
;; Maintainer: Mark A. Hershberger <mah@everybody.org>
@@ -189,7 +188,7 @@ If PARSE-NS is non-nil, then QNAMES are expanded."
(name-chars (concat "-[:digit:]." start-chars))
;;[3] S ::= (#x20 | #x9 | #xD | #xA)+
(whitespace "[ \t\n\r]"))
- ;;[4] NameStartChar ::= ":" | [A-Z] | "_" | [a-z] | [#xC0-#xD6]
+ ;;[4] NameStartChar ::= ":" | [A-Z] | "_" | [a-z] | [#xC0-#xD6]
;; | [#xD8-#xF6] | [#xF8-#x2FF] | [#x370-#x37D] | [#x37F-#x1FFF]
;; | [#x200C-#x200D] | [#x2070-#x218F] | [#x2C00-#x2FEF] | [#x3001-#xD7FF]
;; | [#xF900-#xFDCF] | [#xFDF0-#xFFFD] | [#x10000-#xEFFFF]
@@ -227,7 +226,7 @@ If PARSE-NS is non-nil, then QNAMES are expanded."
(defvar xml-notation-type-re (concat "\\(?:NOTATION" whitespace "(" whitespace "*" xml-name-re
"\\(?:" whitespace "*|" whitespace "*" xml-name-re "\\)*" whitespace "*)\\)"))
;;[59] Enumeration ::= '(' S? Nmtoken (S? '|' S? Nmtoken)* S? ')' [VC: Enumeration] [VC: No Duplicate Tokens]
- (defvar xml-enumeration-re (concat "\\(?:(" whitespace "*" xml-nmtoken-re
+ (defvar xml-enumeration-re (concat "\\(?:(" whitespace "*" xml-nmtoken-re
"\\(?:" whitespace "*|" whitespace "*" xml-nmtoken-re "\\)*"
whitespace ")\\)"))
;;[57] EnumeratedType ::= NotationType | Enumeration
@@ -248,7 +247,7 @@ If PARSE-NS is non-nil, then QNAMES are expanded."
xml-pe-reference-re "\\|" xml-reference-re "\\)*'\\)")))
;;[75] ExternalID ::= 'SYSTEM' S SystemLiteral
;; | 'PUBLIC' S PubidLiteral S SystemLiteral
-;;[76] NDataDecl ::= S 'NDATA' S
+;;[76] NDataDecl ::= S 'NDATA' S
;;[73] EntityDef ::= EntityValue| (ExternalID NDataDecl?)
;;[71] GEDecl ::= '<!ENTITY' S Name S EntityDef S? '>'
;;[74] PEDef ::= EntityValue | ExternalID
@@ -434,7 +433,7 @@ Returns one of:
(let* ((node-name (match-string-no-properties 1))
;; Parse the attribute list.
(attrs (xml-parse-attlist xml-ns))
- children pos)
+ children)
;; add the xmlns:* attrs to our cache
(when (consp xml-ns)
@@ -537,8 +536,7 @@ Leave point at the first non-blank character after the tag."
;; Multiple whitespace characters should be replaced with a single one
;; in the attributes
- (let ((string (match-string-no-properties 1))
- (pos 0))
+ (let ((string (match-string-no-properties 1)))
(replace-regexp-in-string "\\s-\\{2,\\}" " " string)
(let ((expansion (xml-substitute-special string)))
(unless (stringp expansion)
@@ -635,7 +633,7 @@ This follows the rule [28] in the XML specifications."
((string-match "^%[^;]+;[ \t\n\r]*$" type) ;; substitution
nil)
(t
- (if xml-validating-parser
+ (if xml-validating-parser
(error "XML: (Validity) Invalid element type in the DTD"))))
;; rule [45]: the element declaration must be unique
@@ -667,7 +665,7 @@ This follows the rule [28] in the XML specifications."
(goto-char (match-end 0))
(setq xml-entity-alist
(append xml-entity-alist
- (list (cons name
+ (list (cons name
(with-temp-buffer
(insert value)
(goto-char (point-min))
@@ -770,7 +768,7 @@ This follows the rule [28] in the XML specifications."
(let* ((this-part (match-string-no-properties 1 string))
(prev-part (substring string point (match-beginning 0)))
(entity (assoc this-part xml-entity-alist))
- (expansion
+ (expansion
(cond ((string-match "#\\([0-9]+\\)" this-part)
(let ((c (decode-char
'ucs
@@ -911,5 +909,4 @@ The first line is indented with INDENT-STRING."
(provide 'xml)
-;; arch-tag: 5864b283-5a68-4b59-a20d-36a72b353b9b
;;; xml.el ends here
diff --git a/lisp/xt-mouse.el b/lisp/xt-mouse.el
index 5a70e6a6808..403aa5d158b 100644
--- a/lisp/xt-mouse.el
+++ b/lisp/xt-mouse.el
@@ -1,7 +1,6 @@
;;; xt-mouse.el --- support the mouse when emacs run in an xterm
-;; Copyright (C) 1994, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 2000-2011 Free Software Foundation, Inc.
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: mouse, terminals
@@ -51,7 +50,7 @@
M-down-mouse-1 M-down-mouse-2 M-down-mouse-3))
(put event-type 'event-kind 'mouse-click))
-(defun xterm-mouse-translate (event)
+(defun xterm-mouse-translate (_event)
"Read a click and release event from XTerm."
(save-excursion
(save-window-excursion
@@ -229,7 +228,7 @@ down the SHIFT key while pressing the mouse button."
(dolist (terminal (terminal-list))
(turn-on-xterm-mouse-tracking-on-terminal terminal)))
-(defun turn-off-xterm-mouse-tracking (&optional force)
+(defun turn-off-xterm-mouse-tracking (&optional _force)
"Disable Emacs mouse tracking in xterm."
(dolist (terminal (terminal-list))
(turn-off-xterm-mouse-tracking-on-terminal terminal)))
@@ -265,5 +264,4 @@ down the SHIFT key while pressing the mouse button."
(provide 'xt-mouse)
-;; arch-tag: 84962d4e-fae9-4c13-a9d7-ef4925a4ac03
;;; xt-mouse.el ends here